300大洋，请高手帮忙看看这个控件为什么不能正常工作??(300分)

这个控件实现IE地址栏的功能，可是不知道为什么在上面用鼠标乱点几下就会
使程序失去相应(次数不定，有时点好多次都没事，有时点一下就死)，请高手帮忙!!


unit IEAddress;

interface

uses
Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ActiveX, shellapi, shlobj, ImgList, filectrl, urlmon;

const
SHACF_DEFAULT = $00000000; // Currently (SHACF_FILESYSTEM | SHACF_URLALL)
SHACF_FILESYSTEM = $00000001; // This includes the File System as well as the rest of the shell (Desktop/My Computer/Control Panel/)
SHACF_URLHISTORY = $00000002; // URLs in the User's History
SHACF_URLMRU = $00000004; // URLs in the User's Recently Used list.
SHACF_URLALL = (SHACF_URLHISTORY + SHACF_URLMRU);
SHACF_AUTOSUGGEST_FORCE_ON = $10000000; // Ignore the registry default and force the feature on.
SHACF_AUTOSUGGEST_FORCE_OFF = $20000000; // Ignore the registry default and force the feature off.
SHACF_AUTOAPPEND_FORCE_ON = $40000000; // Ignore the registry default and force the feature on. (Also know as AutoComplete)
SHACF_AUTOAPPEND_FORCE_OFF = $80000000; // Ignore the registry default and force the feature off. (Also know as AutoComplete)


type

TFileOption = (FileSystem, UrlHistory, UrlMRU);
TFileOptions = set of TFileOption;

TAutoComplete = (acDefault, acForceOn, acForceOff);
TAutoSuggest = (asDefault, asForceOn, asForceOff);

TOnUrlSelectedEvent = procedure(Sender : TObject; Url: string) of object;

TCustomIEAddress = class(TCustomComboBox)
private
FIconLeft,
FIconTop : Integer;
FDefaultProtocol : String;
FUrl: string;
FRegistryUpdate: Boolean;
FAbout: String;
FAutoComplete: TAutoComplete;
FAutoSuggest: TAutoSuggest;
FFileOptions: TFileOptions;
FOnUrlSelected: TOnUrlSelectedEvent;
FHasBorder,
FHasDropDown: Boolean;
FCanvas: TControlCanvas;
FImageList:TImageList;
FImageSize:Integer;
FSelImageIndex,FImageIndex:Integer;
function GetImageIndex(aUrl:string):Integer;
procedure SetDropDown(const Value: Boolean);
procedure SetHasBorder(const Value: Boolean);

protected
procedure CalculateRGN;
procedure Click; override;
procedure CreateWindowHandle(const Params: TCreateParams);override;
procedure Change;override;
procedure GetTypedURLs;
procedure Keydown(var Key: Word; Shift: TShiftState); override;
procedure Loaded; override;
procedure CreateWnd; override;
procedure CreateParams( var Params: TCreateParams); override;
procedure SetUrl(UrlToSet: string);
Procedure UpdateTypedUrls;
procedure DrawItem(Index: Integer;Rect:TRect; State: TOwnerDrawState);override;
procedure SetEdit;
procedure WndProc(var Message : TMessage); override;

procedure WMPaint(var Msg: TMessage); message WM_Paint;

property AutoComplete: TAutoComplete read FAutoComplete write FAutoComplete;
property AutoSuggest: TAutoSuggest read FAutoSuggest write FAutoSuggest;
property DefaultProtocol : String Read FDefaultProtocol write FDefaultProtocol;
property DropDownCount;
property FileOptions: TFileOptions read FFileOptions write FFileOptions;
property HasBorder : Boolean read FHasBorder write SetHasBorder;
property HasDropDown : Boolean read FHasDropDown write SetDropDown;
property IconLeft : Integer read FIconLeft write FIconLeft;
property IconTop : Integer read FIconTop write FIconTop;
property RegistryUpdate : Boolean read FRegistryUpdate write FRegistryUpdate;
property Url: string read FUrl write SetUrl;

property OnUrlSelected: TOnUrlSelectedEvent read FOnUrlSelected write FOnUrlSelected;
public
procedure SetBounds(Left, Top, Width, Height: Integer);override;
constructor Create(AOwner: TComponent);override;
destructor Destroy;override;
published
property About: String read FAbout write FAbout;
end;

TIEAddress = class(TCustomIEAddress)
public
property URL;
published
property Style; //Apparently this must be published first (see VCL);

//New stuff
property AutoComplete;
property AutoSuggest;
property DefaultProtocol;
property FileOptions;
property HasBorder;
property HasDropDown;
property IconLeft;
property IconTop;
property RegistryUpdate;

property OnUrlSelected;

//inherited stuff
property Align;
property Anchors;
property BiDiMode;
property Color;
property Constraints;
property Cursor;
property DragCursor;
property DragKind;
property DragMode;
property DropDownCount;
property Enabled;
property Font;
property HelpContext;
property Hint;
property ImeMode;
property ImeName;
property ItemHeight;
property MaxLength;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Sorted;
property TabOrder;
property TabStop;
property Text;
property Visible;

property OnChange;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnDrawItem;
property OnDropDown;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMeasureItem;
property OnStartDock;
property OnStartDrag;

property Items; //And this must be published last
end;

procedure Register;


implementation

function SHAutoComplete(hwndEdit: HWND; dwFlags: DWORD): HRESULT; stdcall; external 'shlwapi.dll';

procedure Register;
begin
RegisterComponents('Internet', [TIEAddress]);
end;

procedure TCustomIEAddress.Change;
var
ImageIndex:Integer;
TopPos : Integer;
begin
sendmessage(Handle,CB_SHOWDROPDOWN,0,0);
ImageIndex:=GetImageIndex(Text);
FImageList.Draw(FCanvas, IconLeft, IconTop, ImageIndex,True);
end;

procedure TCustomIEAddress.SetBounds(Left, Top, Width, Height: Integer);
begin
inherited SetBounds(Left, Top, Width, Height);
SetEdit;
CalculateRGN;
end;

procedure TCustomIEAddress.CreateWindowHandle(const Params: TCreateParams);
begin
inherited CreateWindowHandle(Params);
SetEdit;
end;

procedure TCustomIEAddress.SetEdit;
begin
SetWindowPos(EditHandle,0, FImageSize+7,5,Width-46, Height-7, 0);
end;

Procedure TCustomIEAddress.WMPaint(var Msg: TMessage);
var
ImageIndex:Integer;
Begin
inherited;
ImageIndex:=GetImageIndex(Text);
FImageList.Draw(FCanvas, IconLeft, IConTop, ImageIndex,True);
SetEdit;
CalculateRGN;
End;

destructor TCustomIEAddress.Destroy;
begin
FImageList.free;
inherited Destroy;
end;

constructor TCustomIEAddress.Create(AOwner: TComponent);
var
sfi: TShFileInfo;
ahandle:Cardinal;
begin
inherited Create(AOwner);
Width := 145;
Height := 22; //HF - 00/01/17 - Corresponds to new ItemHeight
TabOrder := 0;
ItemHeight := 16; //HF - 00/01/17 - Should be the same as FImageList.Height
FImageSize := 16; //HF - 00/01/17 - Should be the same as FImageList.Height
FSelImageIndex:=-1;
FImageIndex:=-1;
FImageList:=TImageList.Create(self);
FImageList.ShareImages:=true;
FImageList.DrawingStyle:=dsNormal;
FImageList.Height:=16;
FImageList.Width:=16;
ahandle:=ShGetFileInfo('', 0, sfi, sizeOf(sfi),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
if (ahandle <>0) then FImageList.Handle:=ahandle;
FCanvas := TControlCanvas.Create;
FCanvas.Control := self;
FCanvas.Handle := EditHandle;
style:=csDropDown;
FHasBorder := True;
FHasDropDown := True;
Sorted := False;
IconLeft := 4;
IconTop := 3;
end;

procedure TCustomIEAddress.CreateParams( var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or cbs_OwnerDrawFixed or ES_MULTILINE;
end;

procedure TCustomIEAddress.DrawItem(Index: Integer;Rect:TRect; State: TOwnerDrawState);
var
ImageIndex:Integer;
Bitmap: TBitmap;
offset: Integer;
begin
offset := 16;
ImageIndex:= GetImageIndex(Items[Index]);
if (odSelected in State) then
FImageIndex:=ImageIndex;
Bitmap:=TBitMap.Create();
with Canvas do
begin
FillRect(Rect);
if Index < Items.Count then
begin
FImageList.GetBitmap(ImageIndex,Bitmap);
if Assigned(Bitmap) then
begin
BrushCopy(Bounds(Rect.Left + 4,(Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
Bitmap.Width, Bitmap.Height),Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
offset := Bitmap.width + 6;
end;
TextOut(Rect.Left + offset, Rect.Top, Items[Index])
end;
end;
BitMap.free;
end;

function TCustomIEAddress.GetImageIndex(aUrl:string):Integer;
var
Malloc:Imalloc;
SpecialFolder:Cardinal;
sfi:TShFileInfo;
pidl: PItemIDList;

function GetSpecialFolderNo(bUrl:string):Cardinal;
var
Url:string;
begin
Result:=3000;
Url:=UpperCase(bUrl);

if(Url='DESKTOP') then
Result:=CSIDL_DESKTOP

else if(Url='PRINTERS') then
Result:=CSIDL_PRINTERS

else if(Url='MY DOCUMENTS') then
Result:=CSIDL_PERSONAL

else if(Url='RECYCLE BIN') then
Result:=CSIDL_BITBUCKET

else if(Url='NETWORK NEIGHBORHOOD') then
Result:=CSIDL_NETWORK

else if(Url='MY COMPUTER') then
Result:=CSIDL_DRIVES // My Computer

else if(Url='PROGRAMS') then
Result:=CSIDL_PROGRAMS

else if(Url='CONTROL PANEL') then
Result:=CSIDL_CONTROLS

else if(Url='FAVORITES') then
Result:=CSIDL_FAVORITES

else if(Url='STARTUP') then
Result:=CSIDL_STARTUP

else if(Url='RECENT') then
Result:=CSIDL_RECENT

else if(Url='SENDTO') then
Result:=CSIDL_SENDTO

else if(Url='STARTMENU') then
Result:=CSIDL_STARTMENU

else if(Url='DESKTOP DIRECTORY') then
Result:=CSIDL_DESKTOPDIRECTORY

else if(Url='NETHOOD') then
Result:=CSIDL_NETHOOD

else if(Url='FONTS') then
Result:=CSIDL_FONTS

else if(Url='TEMPLATES') then
Result:=CSIDL_TEMPLATES

else if(Url='APPDATA') then
Result:=CSIDL_APPDATA

else if(Url='PRINTHOOD') then
Result:=CSIDL_PRINTHOOD;
end;
begin
Result:=-1;
try
ShGetMalloc(Malloc);
SpecialFolder:=GetSpecialFolderNo(aUrl);
if(SUCCEEDED(SHGetSpecialFolderLocation(Handle,SpecialFolder, Pidl))) then
ShGetFileInfo(PChar(pidl), 0, sfi, sizeof(sfi), SHGFI_ICON or SHGFI_PIDL)
else
begin
if FileExists(aUrl) or (CompareText(Copy(aURL,1,7),'file://')=0) then
ShGetFileInfo(PChar(aUrl), FILE_ATTRIBUTE_NORMAL,
sfi, sizeOf(sfi), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or
SHGFI_SMALLICON)
else if DirectoryExists(aUrl) then
ShGetFileInfo(PChar(aUrl), FILE_ATTRIBUTE_DIRECTORY,
sfi, sizeOf(sfi), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or
SHGFI_SMALLICON)
// else if(IsValidURL(nil,PWideChar(WideString(aUrl)),0)=S_OK) then
else if aURL <> '' then
ShGetFileInfo('*.htm', FILE_ATTRIBUTE_NORMAL,
sfi, sizeOf(sfi), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or
SHGFI_SMALLICON);
end;
Result := sfi.iIcon;
finally
Malloc.Free(pidl);
end;
end;

procedure TCustomIEAddress.UpdateTypedUrls;
var
Max, Counter: Integer;
Name: string;
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try //HF - 00/01/17 - added try block
//PMorris
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('Software/Microsoft/Internet Explorer/TypedURLs', True) then begin
if Items.Count < 24 then Max := Items.Count + 1 else Max := 25;
for Counter := 1 to Max do begin
Name := 'Url' + IntToStr(Counter);
Reg.WriteString(Name, items[Counter - 1]);
end;
end;
reg.CloseKey;
finally
Reg.Free;
end;
end;

procedure TCustomIEAddress.CreateWnd;
const
FileOptionsValues: array[TFileOption] of Cardinal =
(SHACF_FILESYSTEM, SHACF_URLHISTORY, SHACF_URLMRU);
var
i: TFileOption;
Options: DWORD;
begin
inherited CreateWnd;
Options := 0;
if not (csDesigning in ComponentState) then //HF - 00/01/17 - Otherwise Combo is filled at DesignTime
GetTypedURLs;
if (FFileOptions <> []) then
for i := Low(TFileOption) to High(TFileOption) do
if (i in FFileOptions) then Inc(Options, FileOptionsValues);
if FAutoSuggest = asForceOn then inc(Options, SHACF_AUTOSUGGEST_FORCE_ON) else
if FAutoSuggest = asForceOff then Inc(options, SHACF_AUTOSUGGEST_FORCE_OFF);
if FAutoComplete = acForceOn then inc(Options, SHACF_AUTOAPPEND_FORCE_ON) else
if FAutoComplete = acForceOff then Inc(options, SHACF_AUTOAPPEND_FORCE_OFF);
SHAutoComplete(EditHandle, Options);
end;

procedure TCustomIEAddress.Click;
var
Rec: TRect;
pt: TPoint;
begin
inherited; // Khalid 23/1/2000
// Khalid 23/1/2000 we need the effect take place only when
// clicking is inside the ComboBox erea
// FUrl := Text; // so this has been moved to the if block //---|
GetCursorPos(pt); // |
sendmessage(Handle, CB_GETDROPPEDCONTROLRECT, 0, longint(@rec)); // |
if((pt.x >= Rec.Left) and (pt.x <= Rec.Right) // |
and(pt.y >= Rec.Top) and (pt.y <= Rec.Bottom)) then // |
begin // |
FUrl := Text; // <-|Here
FSelImageIndex := FImageIndex;
FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
if assigned(FOnUrlSelected) then FOnUrlSelected(Self, Text); //<--|Here
end; // |
// Khalid 23/1/2000 and this too // |
// if assigned(FOnUrlSelected) then FOnUrlSelected(Self, Text); //---|
// Khalid 23/1/2000
// When closing the dropped list put the EditBox to it's default
SendMessage(EditHandle, EM_SETREADONLY, 0, 0);
SendMessage(EditHandle, EM_SETSEL, 0, -1);
// end Khalid
end;

procedure TCustomIEAddress.Keydown(var Key: Word; Shift: TShiftState);
var
FListIndex:integer;
begin
// khalid 23/1/2000
inherited;
if (DroppedDown) then
begin
if (Key = VK_RETURN) then
begin
Key := VK_CLEAR;
FListIndex:=SendMessage(Handle, CB_GETCURSEL, 0,0);
Items.Move(FListIndex,0); // Move Item to the top
Text:= Items[0];
FUrl := Text;
sendmessage(Handle,CB_SHOWDROPDOWN,0,0);
SendMessage(handle, CB_SETCURSEL, 0,0); // The item to select is in the top
SendMessage(Edithandle, EM_SETREADONLY, 0, 0);
SendMessage(EditHandle, EM_SETSEL, 0, -1);
if FRegistryUpdate then UpdateTypedUrls;
if assigned(FOnUrlSelected) then FOnUrlSelected(Self, Text);
FSelImageIndex := FImageIndex;
FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
end
else if ((ssAlt in Shift) and ((Key = VK_DOWN)or (Key = VK_UP))) or
(Key = VK_ESCAPE) then
begin
Key := VK_CLEAR;
sendmessage(Handle,CB_SHOWDROPDOWN,0,0);
SendMessage(edithandle, EM_SETREADONLY, 0, 0);
SendMessage(edithandle, EM_SETSEL, 0, -1);
end
else if (not (ssAlt in Shift)) and (Key = VK_DOWN) then
begin
Key := VK_CLEAR;
FListIndex:=SendMessage(Handle, CB_GETCURSEL, 0,0);
if FListIndex >=24 then Exit;
SendMessage(Handle, CB_SETCURSEL,(FListIndex+1),0);
SendMessage(EditHandle, EM_SETSEL, -1, 0);
FSelImageIndex := FImageIndex;
FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
end
else if (not (ssAlt in Shift)) and (Key = VK_UP) then
begin
Key := VK_CLEAR;
FListIndex:=SendMessage(Handle, CB_GETCURSEL, 0,0);
if FListIndex <=0 then Exit;
SendMessage(Handle, CB_SETCURSEL,(FListIndex-1),0);
SendMessage(edithandle, EM_SETSEL, -1, 0);
FSelImageIndex := FImageIndex;
FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
end;
end
else
begin
if (Key = VK_RETURN) then
begin
// Old part code
FUrl := Text; // this is moved to inside this block
if DefaultProtocol <> '' then
begin
if (Pos('://', FUrl) = 0) and not (FileExists(FUrl)) then
FUrl := DefaultProtocol + FUrl;
end;
Items.Insert(0, FUrl);
If FRegistryUpdate then UpdateTypedUrls;
if assigned(FOnUrlSelected) then FOnUrlSelected(Self, Text);
// end Old part code
end
else if (Key = VK_DOWN) or ((ssAlt in Shift) and (Key = VK_DOWN))then
begin
Key := VK_CLEAR;
FListIndex:=SendMessage(Handle, CB_GETCURSEL, 0,0);
SendMessage(EditHandle, EM_SETREADONLY, 1, 0);
SendMessage(EditHandle, EM_SETSEL, -1, 0);
sendmessage(Handle,CB_SHOWDROPDOWN,1,0);
end
else if (Key = VK_UP)then
begin
Key := VK_CLEAR;
Exit;
end;
end;
// end khalid
end;

procedure TCustomIEAddress.SetUrl(UrlToSet: string);
begin
FUrl := UrlToSet;
text := FUrl;
end;

procedure TCustomIEAddress.CalculateRGN;
var
BorderRGN,
ShrunkenRGN,
DropDownRGN : HRGN;

BorderHeight,
BorderWidth,
W : Integer;
begin
if Parent = nil then exit;

if HasBorder or HasDropDown then
SetWindowRGN(Handle,0,True)
else begin
//Calculate the size of the border
BorderRGN := CreateRectRGN(0,0,Width,Height);

BorderWidth := GetSystemMetrics(SM_CXDLGFRAME);
BorderHeight := GetSystemMetrics(SM_CYDLGFRAME);

//Calculate the size of the DropDown
if not HasDropDown and not (Style in [csSimple]) then begin
W := GetSystemMetrics(SM_CXVSCROLL);
DropDownRGN := CreateRectRGN(Width-W-BorderWidth,0,Width,Height);
CombineRgn(BorderRGN, BorderRGN, DropDownRGN, RGN_XOR);
DeleteObject(DropDownRGN);
end;

if not HasBorder then begin
ShrunkenRGN := CreateRectRGN(BorderWidth,Borderheight,Width-BorderWidth,Height-BorderHeight);
CombineRGN(BorderRGN, BorderRGN, ShrunkenRGN, RGN_AND);
DeleteObject(ShrunkenRGN);
end;
SetWindowRGN(Handle,BorderRGN, True);
end;

end;

procedure TCustomIEAddress.SetDropDown(const Value: Boolean);
begin
FHasDropDown := Value;
CalculateRGN;
end;

procedure TCustomIEAddress.SetHasBorder(const Value: Boolean);
begin
FHasBorder := Value;
CalculateRGN;
end;

procedure TCustomIEAddress.Loaded;
begin
inherited;
CalculateRGN;
GetTypedURLs;
end;

procedure TCustomIEAddress.GetTypedURLs;
var
Counter : Integer;
S : String;
begin
Items.Clear;
with TRegistry.Create do
try
//PMorris
RootKey := HKEY_CURRENT_USER;
if OpenKey('Software/Microsoft/Internet Explorer/TypedURLs', FALSE) then begin
for Counter := 1 to 25 do begin
if ValueExists('Url' + IntToStr(Counter)) then begin
S := ReadString('Url' + IntToStr(Counter));
if S <> '' then Items.Add(S);
end;
end;
end;
finally
Free;
end;
Text:=Items[0]; //Khalid 23/1/2000 just to make sure that the Edit box is not empty
end;

procedure TCustomIEAddress.WndProc(var Message: TMessage);
begin
inherited;
if (Message.msg = CBN_DropDown) or
(Message.msg = CB_ShowDropDown) then SetEdit;
end;

initialization
Oleinitialize(nil);

finalization
OleUninitialize;
end.

顶顶。

问题好象出在这里：
initialization
Oleinitialize(nil);

finalization
OleUninitialize;
你把这两句去掉看看

to zm30:
为什么呀??

不知为什么，可能是DELPHI对COM的支持有问题，不过我看去掉这两句对这个构件的影响只
是下拉列表中的图标不对了，这个我想通过别的途径可以解决的吧。

这个IEAddress还有个问题，当的的text为空是，你看看他的图标，再输入网址看看，好像也有问题

关注

可能是SetEdit中 SetWindowPos 引起 Windows Paint该控件，
而WMPaint过程中又调用SetEdit，不断重复调用WMPaint过程引起的。

关注

动态创建很好啊，你在窗口放了什么？
我放图象，编辑框，Memo都很好！
var
Form1: TForm1;
c:TCustomIEAddress;
implementation



procedure TForm1.FormCreate(Sender: TObject);
begin
c:=TCustomIEAddress.create(self);
c.parent:=self;
c.width:=300;
c.visible:=true;
end;

多人接受答案了。