TEdit是经常使用的组件，但其功能不能满足开发要求，虽然高版本的Delphi已经提供一个TButtonEdit组件，但这个组件提供的按钮数量较少，于是本人模仿这个组件，做了一个支持4个按钮的TEdit扩展组件，在Delphi XE下测试通过。
主要代码如下：
unit UWSIEAddress;
interface
uses
SysUtils, Classes, Controls, StdCtrls,ImgList,Messages,Menus,themes,Forms,
Windows,Dialogs,RegularExpressions,Registry,ShellAPI;
const
AltID=111;
ShiftID=1001;
CtrlID=11117;
ASID=1112;
ACID=11228;
SCID=12118;
ASCID=12229;
//这些值是随机定义的，用于判断那些辅助键按下
type
TOnUrlSelectedEvent = procedure(Sender: TObject; Url: WideString; var Cancel: boolean) of object;
TCustomUWSIEAddress = class;
TEditButton = class(TPersistent)
strict private
type
TButtonState = (bsNormal, bsHot, bsPushed);
TGlyph = class(TCustomControl)
private
FButton: TEditButton;
FState: TButtonState;
protected
procedure Click; override;
procedure CreateWnd; override;
procedure Paint; override;
procedure WndProc(var Message: TMessage); override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
public
constructor Create(AButton: TEditButton); reintroduce; virtual;
end;
protected
type
TButtonPosition = (bpLeft, bpRightRight,bpRightMiddle,bpRightLeft);
strict private
FDisabledImageIndex: TImageIndex;
FDropDownMenu: TPopupMenu;
FEditControl: TCustomUWSIEAddress;
FGlyph: TGlyph;
FHotImageIndex: TImageIndex;
FImageIndex: TImageIndex;
FPosition: TButtonPosition;
FPressedImageIndex: TImageIndex;
function GetEnabled: Boolean;
function GetCustomHint: TCustomHint;
function GetHint: string;
function GetImages: TCustomImageList;
function GetVisible: Boolean;
procedure SetDisabledImageIndex(const Value: TImageIndex);
procedure SetEnabled(const Value: Boolean);
procedure SetCustomHint(const Value: TCustomHint);
procedure SetHint(const Value: string);
procedure SetHotImageIndex(const Value: TImageIndex);
procedure SetImageIndex(const Value: TImageIndex);
procedure SetPressedImageIndex(const Value: TImageIndex);
procedure SetVisible(const Value: Boolean);
protected
function GetOwner: TPersistent; override;
procedure UpdateBounds; dynamic;
property EditControl: TCustomUWSIEAddress read FEditControl;
property Glyph: TGlyph read FGlyph;
property Images: TCustomImageList read GetImages;
property Position: TButtonPosition read FPosition;
public
constructor Create(EditControl: TCustomUWSIEAddress; APosition: TButtonPosition); reintroduce; virtual;
destructor Destroy; override;
property Visible: Boolean read GetVisible ;
published
property CustomHint: TCustomHint read GetCustomHint write SetCustomHint;
property DisabledImageIndex: TImageIndex read FDisabledImageIndex write SetDisabledImageIndex default -1;
property DropDownMenu: TPopupMenu read FDropDownMenu write FDropDownMenu;
property Enabled: Boolean read GetEnabled write SetEnabled default True;
property Hint: string read GetHint write SetHint;
property HotImageIndex: TImageIndex read FHotImageIndex write SetHotImageIndex default -1;
property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
property PressedImageIndex: TImageIndex read FPressedImageIndex write SetPressedImageIndex default -1;
end;
TEditButtonClass = class of TEditButton;
TCustomUWSIEAddress = class(TCustomEdit)
private
{ Private declarations }
FShiftKeyID:Integer;
FCanvas: TControlCanvas;
FImages: TCustomImageList;
FImageChangeLink: TChangeLink;
FLeftButton: TEditButton;
FRightButtonRight: TEditButton;
FRightButtonMiddle: TEditButton;
FRightButtonLeft: TEditButton;
FFavIconsSavePath:String;
FOneKeyAddressFile:String;
FAddressAutoFixFile:String;
FOneKeyAddress:TStrings;
FAddressAutoFix:TStrings;
FTypedUrls:TStringList;
FOnUrlSelected: TOnUrlSelectedEvent;
function GetOneKeyAddress: TStrings;
function GetAddressAutoFix: TStrings;
function AdjustTextHint(Margin: Integer; const Value: string): string;
procedure SetOneKeyAddress(Value: TStrings);
procedure SetAddressAutoFix(Value: TStrings);
procedure ImageListChange(Sender: TObject);
procedure SetImages(const Value: TCustomImageList);
function GetOnLeftButtonClick: TNotifyEvent;
function GetOnRightButtonRightClick: TNotifyEvent;
function GetOnRightButtonMiddleClick: TNotifyEvent;
function GetOnRightButtonLeftClick: TNotifyEvent;
procedure SetLeftButton(const Value: TEditButton);
procedure SetOnLeftButtonClick(const Value: TNotifyEvent);
procedure SetRightButtonRight(const Value: TEditButton);
procedure SetOnRightButtonRightClick(const Value: TNotifyEvent);
procedure SetRightButtonMiddle(const Value: TEditButton);
procedure SetOnRightButtonMiddleClick(const Value: TNotifyEvent);
procedure SetRightButtonLeft(const Value: TEditButton);
procedure SetOnRightButtonLeftClick(const Value: TNotifyEvent);
function GetOneKeyAddressUrl(Key:String):string;
function GetFixUrl(SrcKey,Key:String):string;
procedure GetTypedUrls;
protected
{ Protected declarations }
procedure DoSetTextHint(const Value: string); override;
function GetEditButtonClass: TEditButtonClass; dynamic;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure UpdateEditMargins; dynamic;
procedure WndProc(var Message: TMessage); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LoadOneKeyAddressList;
procedure LoadAddressAutoFixList;
procedure SaveOneKeyAddressList;
procedure SaveAddressAutoFixList;
procedure DefaultHandler(var Message); override;
procedure UpdateTypedUrls;
function GetShellIcons:Cardinal;
property Images: TCustomImageList read FImages write SetImages;
property LeftButton: TEditButton read FLeftButton write SetLeftButton;
property RightButtonRight: TEditButton read FRightButtonRight write SetRightButtonRight;
property RightButtonMiddle: TEditButton read FRightButtonMiddle write SetRightButtonMiddle;
property RightButtonLeft: TEditButton read FRightButtonLeft write SetRightButtonLeft;
property OnLeftButtonClick: TNotifyEvent read GetOnLeftButtonClick write SetOnLeftButtonClick;
property OnRightButtonRightClick: TNotifyEvent read GetOnRightButtonRightClick write SetOnRightButtonRightClick;
property OnRightButtonMiddleClick: TNotifyEvent read GetOnRightButtonMiddleClick write SetOnRightButtonMiddleClick;
property OnRightButtonLeftClick: TNotifyEvent read GetOnRightButtonLeftClick write SetOnRightButtonLeftClick;
property FavIconsSavePath:String read FFavIconsSavePath write FFavIconsSavePath;
property OneKeyAddressFile:String read FOneKeyAddressFile write FOneKeyAddressFile;
property AddressAutoFixFile:String read FAddressAutoFixFile write FAddressAutoFixFile;
Property OneKeyAddress:TStrings read GetOneKeyAddress write SetOneKeyAddress;
Property AddressAutoFix:TStrings read GetAddressAutoFix write SetAddressAutoFix;
property OnUrlSelected: TOnUrlSelectedEvent read FOnUrlSelected write FOnUrlSelected;
property TypedUrls:TStringList read FTypedUrls;
published
{ Published declarations }
end;
TUWSIEAddress=class(TCustomUWSIEAddress )
private
protected
public
published
property Align;
property Alignment;
property Anchors;
property AutoSelect;
property AutoSize;
property BevelEdges;
property BevelInner;
property BevelKind default bkNone;
property BevelOuter;
property BevelWidth;
property BiDiMode;
property BorderStyle;
property CharCase;
property Color;
property Constraints;
property Ctl3D;
property DoubleBuffered;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property Images;
property ImeMode;
property ImeName;
property LeftButton;
property MaxLength;
property OEMConvert;
property NumbersOnly;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentDoubleBuffered;
property ParentFont;
property ParentShowHint;
property PasswordChar;
property PopupMenu;
property ReadOnly;
property RightButtonRight;
property RightButtonMiddle;
property RightButtonLeft;
property ShowHint;
property TabOrder;
property TabStop;
property Text;
property TextHint;
property Touch;
property Visible;
property OnChange;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnGesture;
property OnLeftButtonClick;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnRightButtonRightClick;
property OnRightButtonMiddleClick;
property OnRightButtonLeftClick;
property OnStartDock;
property OnStartDrag;
property FavIconsSavePath;
property OneKeyAddressFile;
property AddressAutoFixFile;
Property OneKeyAddress;
Property AddressAutoFix;
property OnUrlSelected;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Unruly Wolf Soft', [TUWSIEAddress]);
end;
function CtrlDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State) ;
Result := ((State[vk_Control] And 128) <> 0) ;
end;
function ShiftDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State) ;
Result := ((State[vk_Shift] and 128) <> 0) ;
end;
function AltDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State) ;
Result := ((State[vk_Menu] and 128) <> 0) ;
end;
{ TEditButton.TGlyph }
constructor TEditButton.TGlyph.Create(AButton: TEditButton);
begin
inherited Create(AButton.FEditControl);
FButton := AButton;
FState := bsNormal;
Parent := FButton.FEditControl;
Visible := True;
ShowHint:=True;
end;
procedure TEditButton.TGlyph.Click;
begin
// Replicate from TControl to set Sender to owning TButtonedEdit control
if Assigned(OnClick) and (Action <> nil) and not DelegatesEqual(@OnClick, @Action.OnExecute) then
OnClick(FButton.EditControl)
else if not (csDesigning in ComponentState) and (ActionLink <> nil) then
ActionLink.Execute(FButton.EditControl)
else if Assigned(OnClick) then
OnClick(FButton.EditControl);
FState := bsNormal;
end;
procedure TEditButton.TGlyph.CreateWnd;
begin
inherited;
if Visible then
FButton.FEditControl.UpdateEditMargins;
end;
procedure TEditButton.TGlyph.Paint;
var
LIndex: Integer;
begin
inherited;
if (FButton.Images <> nil) and Visible then
begin
LIndex := FButton.ImageIndex;
if Enabled then
begin
case FState of
bsHot:
if FButton.HotImageIndex <> -1 then
LIndex := FButton.HotImageIndex;
bsPushed:
if FButton.PressedImageIndex <> -1 then
LIndex := FButton.PressedImageIndex;
end;
end
else
if FButton.DisabledImageIndex <> -1 then
LIndex := FButton.DisabledImageIndex;
if LIndex <> -1 then
FButton.Images.Draw(Canvas, 0, 0, LIndex);
end;
end;
procedure TEditButton.TGlyph.WndProc(var Message: TMessage);
var
LPoint: TPoint;
begin
if (Message.Msg = WM_CONTEXTMENU) and (FButton.EditControl.PopupMenu = nil) then
begin
FState := bsNormal;
Exit;
end;
inherited;
case Message.Msg of
CM_MOUSEENTER: FState := bsHot;
CM_MOUSELEAVE: FState := bsNormal;
WM_LBUTTONDOWN:
begin
if FButton.FDropDownMenu <> nil then
begin
if not (csDesigning in Parent.ComponentState) then
begin
LPoint := ClientToScreen(Point(0, FButton.EditControl.Height));
FButton.FDropDownMenu.Popup(LPoint.X, LPoint.Y);
if Assigned(OnClick) and (Action <> nil) and not DelegatesEqual(@OnClick, @Action.OnExecute) then
OnClick(FButton.EditControl)
else if not (csDesigning in ComponentState) and (ActionLink <> nil) then
ActionLink.Execute(FButton.EditControl)
else if Assigned(OnClick) then
OnClick(FButton.EditControl);
end;
end
else
FState := bsPushed;
end;
WM_LBUTTONUP: FState := bsNormal;
WM_RBUTTONUP:
begin
if FButton.FDropDownMenu <> nil then
begin
if not (csDesigning in Parent.ComponentState) then
begin
LPoint := ClientToScreen(Point(0, FButton.EditControl.Height));
FButton.FDropDownMenu.Popup(LPoint.X, LPoint.Y);
FState := bsNormal;
end;
end;
end;
CM_VISIBLECHANGED: FButton.UpdateBounds;
else
Exit;
end;
Invalidate;
end;
procedure TEditButton.TGlyph.CMHintShow(var Message: TCMHintShow);
begin
if Hint<>'' then
Message.HintInfo^.HintStr := Hint
end;
{ TEditButton }
constructor TEditButton.Create(EditControl: TCustomUWSIEAddress; APosition: TButtonPosition);
begin
inherited Create;
FEditControl := EditControl;
FGlyph := TGlyph.Create(Self);
FHotImageIndex := -1;
FImageIndex := -1;
FPosition := APosition;
FPressedImageIndex := -1;
FDisabledImageIndex := -1;
end;
destructor TEditButton.Destroy;
begin
FGlyph.Parent.RemoveControl(FGlyph);
FGlyph.Free;
inherited;
end;
function TEditButton.GetEnabled: Boolean;
begin
Result := FGlyph.Enabled;
end;
function TEditButton.GetCustomHint: TCustomHint;
begin
Result := FGlyph.CustomHint;
end;
function TEditButton.GetHint: string;
begin
Result := FGlyph.Hint;
end;
function TEditButton.GetImages: TCustomImageList;
begin
Result := FEditControl.Images;
end;
function TEditButton.GetOwner: TPersistent;
begin
Result := FEditControl;
end;
function TEditButton.GetVisible: Boolean;
begin
Result := FGlyph.Visible;
end;
procedure TEditButton.SetDisabledImageIndex(const Value: TImageIndex);
begin
if Value <> FDisabledImageIndex then
begin
FDisabledImageIndex := Value;
if not Enabled then
FGlyph.Invalidate;
end;
end;
procedure TEditButton.SetEnabled(const Value: Boolean);
begin
if Value <> FGlyph.Enabled then
begin
FGlyph.Enabled := Value;
FGlyph.Invalidate;
end;
end;
procedure TEditButton.SetCustomHint(const Value: TCustomHint);
begin
if Value <> FGlyph.CustomHint then
FGlyph.CustomHint := Value;
end;
procedure TEditButton.SetHint(const Value: string);
begin
if Value <> FGlyph.Hint then
FGlyph.Hint := Value;
end;
procedure TEditButton.SetHotImageIndex(const Value: TImageIndex);
begin
if Value <> FHotImageIndex then
begin
FHotImageIndex := Value;
if FGlyph.FState = bsHot then
FGlyph.Invalidate;
end;
end;
procedure TEditButton.SetImageIndex(const Value: TImageIndex);
begin
if Value <> FImageIndex then
begin
FImageIndex := Value;
if FGlyph.FState = bsNormal then
FGlyph.Invalidate;
end;
end;
procedure TEditButton.SetPressedImageIndex(const Value: TImageIndex);
begin
if Value <> FPressedImageIndex then
begin
FPressedImageIndex := Value;
if FGlyph.FState = bsPushed then
FGlyph.Invalidate;
end;
end;
procedure TEditButton.SetVisible(const Value: Boolean);
begin
if Value <> FGlyph.Visible then
begin
FGlyph.Visible := Value;
FEditControl.UpdateEditMargins;
end;
end;
procedure TEditButton.UpdateBounds;
var
EdgeSize, NewLeft: Integer;
begin
if FGlyph <> nil then
begin
if Images <> nil then
begin
FGlyph.Width := Images.Width;
FGlyph.Height := Images.Height;
end
else
begin
FGlyph.Width := 0;
FGlyph.Height := 0;
end;
FGlyph.Top := (FEditControl.Height-FGlyph.Height) div 2-1;
NewLeft := FGlyph.Left;
if not ThemeServices.ThemesEnabled then
FGlyph.Top :=(FEditControl.Height-FGlyph.Height) div 2;
case FPosition of
bpLeft:
begin
if ThemeServices.ThemesEnabled then
NewLeft := 0
else
NewLeft := 1;
end;
bpRightRight:
begin
NewLeft := FEditControl.Width - FGlyph.Width-2;
if FEditControl.BorderStyle <> bsNone then
Dec(NewLeft, 4);
if FEditControl.BevelKind <> bkNone then
begin
EdgeSize := 0;
if FEditControl.BevelInner <> bvNone then
Inc(EdgeSize, FEditControl.BevelWidth);
if FEditControl.BevelOuter <> bvNone then
Inc(EdgeSize, FEditControl.BevelWidth);
if beRight in FEditControl.BevelEdges then
Dec(NewLeft, EdgeSize);
if beLeft in FEditControl.BevelEdges then
Dec(NewLeft, EdgeSize);
end;
if not ThemeServices.ThemesEnabled then
Dec(NewLeft);
end;
bpRightMiddle:
begin
NewLeft := FEditControl.Width - FGlyph.Width*2-4;
if FEditControl.BorderStyle <> bsNone then
Dec(NewLeft, 4);
if FEditControl.BevelKind <> bkNone then
begin
EdgeSize := 0;
if FEditControl.BevelInner <> bvNone then
Inc(EdgeSize, FEditControl.BevelWidth);
if FEditControl.BevelOuter <> bvNone then
Inc(EdgeSize, FEditControl.BevelWidth);
if beRight in FEditControl.BevelEdges then
Dec(NewLeft, EdgeSize);
if beLeft in FEditControl.BevelEdges then
Dec(NewLeft, EdgeSize);
end;
if not ThemeServices.ThemesEnabled then
Dec(NewLeft);
end;
bpRightLeft:
begin
NewLeft := FEditControl.Width - FGlyph.Width*3-8;
if FEditControl.BorderStyle <> bsNone then
Dec(NewLeft, 4);
if FEditControl.BevelKind <> bkNone then
begin
EdgeSize := 0;
if FEditControl.BevelInner <> bvNone then
Inc(EdgeSize, FEditControl.BevelWidth);
if FEditControl.BevelOuter <> bvNone then
Inc(EdgeSize, FEditControl.BevelWidth);
if beRight in FEditControl.BevelEdges then
Dec(NewLeft, EdgeSize);
if beLeft in FEditControl.BevelEdges then
Dec(NewLeft, EdgeSize);
end;
if not ThemeServices.ThemesEnabled then
Dec(NewLeft);
end;
end;
if (not FEditControl.Ctl3D) and (FEditControl.BorderStyle <> bsNone) then
begin
FGlyph.Top := (FEditControl.Height-FGlyph.Height) div 2;
Inc(NewLeft, 2);
end;
FGlyph.Left := NewLeft;
if (csDesigning in FEditControl.ComponentState) and not Visible then
FGlyph.Width := 0;
end;
end;
constructor TCustomUWSIEAddress.Create(AOwner: TComponent);
begin
inherited;
FCanvas := TControlCanvas.Create;
FCanvas.Control := Self;
FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := ImageListChange;
FLeftButton := GetEditButtonClass.Create(Self, bpLeft);
FRightButtonRight := GetEditButtonClass.Create(Self, bpRightRight);
FRightButtonMiddle := GetEditButtonClass.Create(Self, bpRightMiddle);
FRightButtonLeft := GetEditButtonClass.Create(Self, bpRightLeft);
font.Size:=12;
FShiftKeyID:=0;
FFavIconsSavePath:='';
FOneKeyAddressFile:='';
FAddressAutoFixFile:='';
FOneKeyAddress:=TStringlist.Create ;
FAddressAutoFix:=TStringlist.Create ;
FTypedUrls:=TStringlist.Create ;
LoadOneKeyAddressList;
LoadAddressAutoFixList;
GetTypedUrls;
end;
destructor TCustomUWSIEAddress.Destroy;
begin
FreeAndNil(FCanvas);
FreeAndNil(FImageChangeLink);
FreeAndNil(FLeftButton);
FreeAndNil(FRightButtonRight);
FreeAndNil(FRightButtonMiddle);
FreeAndNil(FRightButtonLeft);
SaveOneKeyAddressList;
SaveAddressAutoFixList;
FOneKeyAddress.Free ;
FAddressAutoFix.Free;
FTypedUrls.Free ;
inherited;
end;
function TCustomUWSIEAddress.AdjustTextHint(Margin: Integer; const Value: string): string;
var
LWidth, Count: Integer;
begin
if (Margin = 0) or (Win32MajorVersion >= 6) then
inherited DoSetTextHint(Value)
else
begin
// This is a hack!! Due to a presumed bug in Windows XP any text hint
// set with EM_SETCUEBANNER does not respect left margins set with
// EM_SETMARGINS. The following works around the issue.
FCanvas.Font := Font;
LWidth := FCanvas.TextWidth(' '); // do not localize
Count := Margin div LWidth;
if (Margin mod LWidth) > 0 then
Inc(Count);
inherited DoSetTextHint(StringOfChar(' ', Count) + Value);
end;
end;
procedure TCustomUWSIEAddress.DoSetTextHint(const Value: string);
begin
AdjustTextHint(0, Value);
end;
function TCustomUWSIEAddress.GetEditButtonClass: TEditButtonClass;
begin
Result := TEditButton;
end;
function TCustomUWSIEAddress.GetOnLeftButtonClick: TNotifyEvent;
begin
Result := LeftButton.Glyph.OnClick;
end;
function TCustomUWSIEAddress.GetOnRightButtonRightClick: TNotifyEvent;
begin
Result := RightButtonRight.Glyph.OnClick;
end;
function TCustomUWSIEAddress.GetOnRightButtonMiddleClick: TNotifyEvent;
begin
Result := RightButtonMiddle.Glyph.OnClick;
end;
function TCustomUWSIEAddress.GetOnRightButtonLeftClick: TNotifyEvent;
begin
Result := RightButtonLeft.Glyph.OnClick;
end;
procedure TCustomUWSIEAddress.ImageListChange(Sender: TObject);
begin
if HandleAllocated then
begin
FLeftButton.UpdateBounds;
FRightButtonRight.UpdateBounds;
FRightButtonMiddle.UpdateBounds;
FRightButtonLeft.UpdateBounds;
UpdateEditMargins;
end;
end;
procedure TCustomUWSIEAddress.DefaultHandler(var Message);
{$IF DEFINED(CLR)}
var
LMessage: TMessage;
{$IFEND}
begin
inherited;
{$IF DEFINED(CLR)}
LMessage := UnwrapMessage(TObject(Message));
case LMessage.Msg of
{$ELSE}
case TMessage(Message).Msg of
{$IFEND}
CN_CTLCOLOREDIT:
begin
FLeftButton.Glyph.Invalidate;
FRightButtonRight.Glyph.Invalidate;
FRightButtonMiddle.Glyph.Invalidate;
FRightButtonLeft.Glyph.Invalidate;
end;
WM_SIZE:
begin
FRightButtonRight.UpdateBounds;
FRightButtonMiddle.UpdateBounds;
FRightButtonLeft.UpdateBounds;
end;
end;
end;
procedure TCustomUWSIEAddress.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = FImages then
begin
FImages := nil;
FLeftButton.UpdateBounds;
FRightButtonRight.UpdateBounds;
FRightButtonMiddle.UpdateBounds;
FRightButtonLeft.UpdateBounds;
UpdateEditMargins;
end
else if (LeftButton <> nil) and (AComponent = LeftButton.DropDownMenu) then
LeftButton.DropDownMenu := nil
else if (RightButtonRight <> nil) and (AComponent = RightButtonRight.DropDownMenu) then
RightButtonRight.DropDownMenu := nil
else if (RightButtonMiddle <> nil) and (AComponent = RightButtonMiddle.DropDownMenu) then
RightButtonMiddle.DropDownMenu := nil
else if (RightButtonLeft <> nil) and (AComponent = RightButtonLeft.DropDownMenu) then
RightButtonLeft.DropDownMenu := nil;
end;
end;
procedure TCustomUWSIEAddress.SetImages(const Value: TCustomImageList);
begin
if Value <> FImages then
begin
if FImages <> nil then
FImages.UnRegisterChanges(FImageChangeLink);
FImages := Value;
if FImages <> nil then
begin
FImages.RegisterChanges(FImageChangeLink);
FImages.FreeNotification(Self);
end;
FLeftButton.UpdateBounds;
FRightButtonRight.UpdateBounds;
FRightButtonMiddle.UpdateBounds;
FRightButtonLeft.UpdateBounds;
UpdateEditMargins;
end;
end;
procedure TCustomUWSIEAddress.SetLeftButton(const Value: TEditButton);
begin
FLeftButton.Assign(Value);
end;
procedure TCustomUWSIEAddress.SetOnLeftButtonClick(const Value: TNotifyEvent);
begin
LeftButton.Glyph.OnClick := Value;
end;
procedure TCustomUWSIEAddress.SetOnRightButtonRightClick(const Value: TNotifyEvent);
begin
RightButtonRight.Glyph.OnClick := Value;
end;
procedure TCustomUWSIEAddress.SetOnRightButtonMiddleClick(const Value: TNotifyEvent);
begin
RightButtonMiddle.Glyph.OnClick := Value;
end;
procedure TCustomUWSIEAddress.SetOnRightButtonLeftClick(const Value: TNotifyEvent);
begin
RightButtonLeft.Glyph.OnClick := Value;
end;
procedure TCustomUWSIEAddress.SetRightButtonRight(const Value: TEditButton);
begin
FRightButtonRight.Assign(Value);
end;
procedure TCustomUWSIEAddress.SetRightButtonMiddle(const Value: TEditButton);
begin
FRightButtonMiddle.Assign(Value);
end;
procedure TCustomUWSIEAddress.SetRightButtonLeft(const Value: TEditButton);
begin
FRightButtonLeft.Assign(Value);
end;
procedure TCustomUWSIEAddress.UpdateEditMargins;
var
LMargin, RMargin: Integer;
begin
if HandleAllocated then
begin
LMargin := 0;
RMargin := 0;
if (Images <> nil) then
begin
if LeftButton.Visible then
LMargin := Images.Width + 2;
if RightButtonLeft.Visible then
RMargin := 3*Images.Width+16;
end;
SendMessage(Handle, EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, MakeLong(LMargin, RMargin));
AdjustTextHint(LMargin, TextHint);
Invalidate;
end;
end;
procedure TCustomUWSIEAddress.WndProc(var Message: TMessage);
var
LLeft, LTop: Integer;
begin
case Message.Msg of
CN_CTLCOLORSTATIC,
CN_CTLCOLOREDIT:
if FImages <> nil then
begin
if LeftButton.Visible then
begin
LLeft := LeftButton.Glyph.Left;
LTop := (Height-LeftButton.Glyph.Height) div 2-1;
if ThemeServices.ThemesEnabled and Ctl3D then
begin
Inc(LLeft);
Inc(LTop);
end;
ExcludeClipRect(Message.WParam, LLeft + 1, LTop + 1,
LeftButton.Glyph.Width + LeftButton.Glyph.Left, LeftButton.Glyph.Height);
end;
if RightButtonRight.Visible then
begin
LTop := (Height-RightButtonRight.Glyph.Height) div 2-1;
if ThemeServices.ThemesEnabled and Ctl3D then
Inc(LTop);
ExcludeClipRect(Message.WParam, RightButtonRight.Glyph.Left, LTop + 1,
RightButtonRight.Glyph.Width + RightButtonRight.Glyph.Left, RightButtonRight.Glyph.Height);
end;
if RightButtonMiddle.Visible then
begin
LTop := (Height-RightButtonMiddle.Glyph.Height) div 2-1;
if ThemeServices.ThemesEnabled and Ctl3D then
Inc(LTop);
ExcludeClipRect(Message.WParam, RightButtonMiddle.Glyph.Left, LTop + 1,
RightButtonMiddle.Glyph.Width + RightButtonMiddle.Glyph.Left, RightButtonMiddle.Glyph.Height);
end;
if RightButtonLeft.Visible then
begin
LTop :=(Height-RightButtonLeft.Glyph.Height) div 2-1;
if ThemeServices.ThemesEnabled and Ctl3D then
Inc(LTop);
ExcludeClipRect(Message.WParam, RightButtonLeft.Glyph.Left, LTop + 1,
RightButtonLeft.Glyph.Width + RightButtonLeft.Glyph.Left, RightButtonLeft.Glyph.Height);
end;
end;
end;
inherited;
case Message.Msg of
CM_BORDERCHANGED,
CM_CTL3DCHANGED:
begin
if not (csLoading in ComponentState) then
begin
LeftButton.UpdateBounds;
RightButtonRight.UpdateBounds;
RightButtonMiddle.UpdateBounds;
RightButtonLeft.UpdateBounds;
end;
end;
CM_FONTCHANGED:
if not (csLoading in ComponentState) then
UpdateEditMargins;
end;
end;
function TCustomUWSIEAddress.GetOneKeyAddress: TStrings;
begin
Result:=FOneKeyAddress;
end;
function TCustomUWSIEAddress.GetAddressAutoFix: TStrings;
begin
Result:=FAddressAutoFix;
end;
procedure TCustomUWSIEAddress.SetOneKeyAddress(Value: TStrings);
begin
FOneKeyAddress.Assign(Value);
end;
procedure TCustomUWSIEAddress.SetAddressAutoFix(Value: TStrings);
begin
FAddressAutoFix.Assign(Value);
end;
procedure TCustomUWSIEAddress.LoadOneKeyAddressList;
begin
if (csDesigning in ComponentState) then Exit;
if FOneKeyAddressFile='' then
FOneKeyAddressFile:=Format('%s\OneKeyAddress.dat',[ExtractFileDir(Application.ExeName)]);
if fileExists(FOneKeyAddressFile) then
FOneKeyAddress.LoadFromFile(FOneKeyAddressFile);
if FOneKeyAddress.Count=0 then
begin
FOneKeyAddress.Add('123=www.hao123.com');
FOneKeyAddress.Add('d123=123.duba.net');
FOneKeyAddress.Add('baidu=www.baidu.com');
FOneKeyAddress.Add('b=www.baidu.com');
FOneKeyAddress.Add('百度=www.baidu.com');
FOneKeyAddress.Add('g=www.google.com');
FOneKeyAddress.Add('google=www.google.com');
FOneKeyAddress.Add('谷歌=www.google.com');
FOneKeyAddress.Add('k=www.kingsoft.com');
FOneKeyAddress.Add('kingsoft=www.kingsoft.com');
FOneKeyAddress.Add('金山=www.kingsoft.com');
FOneKeyAddress.Add('i=www.ijinshan.com');
FOneKeyAddress.Add('duba=www.ijinshan.com');
FOneKeyAddress.Add('毒霸=www.ijinshan.com');
FOneKeyAddress.Add('金山毒霸=www.ijinshan.com');
FOneKeyAddress.Add('金山卫士=www.ijinshan.com');
FOneKeyAddress.Add('卫士=www.ijinshan.com');
FOneKeyAddress.Add('wps=www.wps.cn');
FOneKeyAddress.Add('q=www.qq.com');
FOneKeyAddress.Add('sina=www.sina.com');
FOneKeyAddress.Add('新浪=www.sina.com');
end;
end;
procedure TCustomUWSIEAddress.LoadAddressAutoFixList;
begin
if (csDesigning in ComponentState) then Exit;
if FAddressAutoFixFile='' then
FAddressAutoFixFile:=Format('%s\AddressAutoFix.dat',[ExtractFileDir(Application.ExeName)]);
if FileExists(FAddressAutoFixFile) then
FAddressAutoFix.LoadFromFile(FAddressAutoFixFile);
if FAddressAutoFix.Count=0 then
begin
FAddressAutoFix.Add('Ctrl+Enter=www. .com');
FAddressAutoFix.Add('Alt+Enter=www. .cn');
FAddressAutoFix.Add('Shift+Enter=www. .com.cn');
FAddressAutoFix.Add('Ctrl+Alt+Enter=www. .net');
FAddressAutoFix.Add('Ctrl+Shift+Enter=www. .org');
FAddressAutoFix.Add('Alt+Shift+Enter=www. .cc');
FAddressAutoFix.Add('Ctrl+Shift+Alt+Enter=http://www.baidu.com/s?wd=');
end;
end;
procedure TCustomUWSIEAddress.SaveOneKeyAddressList;
begin
if FOneKeyAddressFile='' then
FOneKeyAddressFile:=Format('%s\OneKeyAddress.dat',[ExtractFileDir(Application.ExeName)]);
FOneKeyAddress.SavetoFile(FOneKeyAddressFile);
end;
procedure TCustomUWSIEAddress.SaveAddressAutoFixList;
begin
if FAddressAutoFixFile='' then
FAddressAutoFixFile:=Format('%s\AddressAutoFix.dat',[ExtractFileDir(Application.ExeName)]);
FAddressAutoFix.SavetoFile(FAddressAutoFixFile);
end;
function TCustomUWSIEAddress.GetOneKeyAddressUrl(Key:String):string;
begin
Result:=Key;
if (FOneKeyAddress.Count>0) and (Key<>'') then
begin
Result:=FOneKeyAddress.Values[Key];
if Result='' then
Result:=Key ;
end;
end;
function TCustomUWSIEAddress.GetFixUrl(SrcKey,Key:String):string;
var
SubUrlList:TStringList;
I,K:Integer;
SubUrls:TArray<string>;
SubUrl,TempResult:string;
begin
Result:=key;
if (SrcKey<>'') and (Key<>'') then
begin
SubUrlList:=TStringList.Create ;
try
SubUrls:=TRegEx.Split(SrcKey,'[ ]');
for SubUrl in SubUrls do
SubUrlList.Add(SubUrl);
K:=SubUrlList.Count;
if k>0 then
begin
TempResult:=SubUrlList[0]+Key;
if K>1 then
TempResult:=TempResult+SubUrlList[1];
end
else
TempResult:=Key ;
finally
SubUrlList.Free ;
end;
Result:=TempResult ;
end;
end;
procedure TCustomUWSIEAddress.GetTypedUrls;
var
Reg:TRegistry;
Urls:TStringList;
I:Integer ;
TmpUrl:string;
begin
Reg:=TRegistry.Create;
Urls:=TStringList.Create;
try
Reg.RootKey:=HKEY_CURRENT_USER;
if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then
begin
Reg.GetValueNames(Urls);
if Urls.Count>0 then
for I:=0 to Urls.Count-1 do
begin
TmpUrl:=Reg.ReadString(Urls[I]);
TmpUrl:=Trim(TmpUrl);
if (TmpUrl<>'') and (FTypedUrls.IndexOf(TmpUrl)=-1) then
FTypedUrls.Add(TmpUrl);
end;
Reg.CloseKey ;
end;
if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedAddress', false) then
begin
Reg.GetValueNames(Urls);
if Urls.Count>0 then
for I:=0 to Urls.Count-1 do
begin
TmpUrl:=Reg.ReadString(Urls[I]);
TmpUrl:=Trim(TmpUrl);
if (TmpUrl<>'') and (FTypedUrls.IndexOf(TmpUrl)=-1) then
FTypedUrls.Add(TmpUrl);
end;
Reg.CloseKey ;
end;
finally
Reg.Free;
Urls.Free;
end;
end;
procedure TCustomUWSIEAddress.UpdateTypedUrls;
var
reg:TRegistry ;
begin
GetTypedUrls ;
if Text='' then Exit;
if FTypedUrls.IndexOf(Text)=-1 then
begin
reg:=TRegistry.Create ;
try
if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then
begin
reg.WriteString(Format('url%d',[FTypedUrls.Count+1]),Text);
end;
reg.CloseKey ;
finally
reg.Free;
end;
end;
end;
function TCustomUWSIEAddress.GetShellIcons:Cardinal;
var
sfi: TShFileInfo;
aHandle: Cardinal;
begin
Result:=0;
aHandle := ShGetFileInfo('', 0, sfi, sizeOf(sfi), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
if (aHandle <> 0) then
Result:= aHandle;
end;
procedure TCustomUWSIEAddress.KeyDown(var Key: Word; Shift: TShiftState);
begin
FShiftKeyID:=0;
if CtrlDown then
FShiftKeyID:=FShiftKeyID+ctrlID;
if ShiftDown then
FShiftKeyID:=FShiftKeyID+ShiftID;
if AltDown then
FShiftKeyID:=FShiftKeyID+AltID;
inherited;
end;
procedure TCustomUWSIEAddress.KeyUp(var Key: Word; Shift: TShiftState);
var
SrcKey:string;
bCancel:Boolean ;
begin
bCancel:=False ;
if Key=13 then
begin
case FShiftKeyID of
0:begin
Text:=GetOneKeyAddressUrl(Text);
end;
CtrlID:begin
SrcKey:=FAddressAutoFix.Values['Ctrl+Enter'];
Text:=GetFixUrl(SrcKey,Text);
end;
AltID:begin
SrcKey:=FAddressAutoFix.Values['Alt+Enter'];
Text:=GetFixUrl(SrcKey,Text);
end;
ShiftID:begin
SrcKey:=FAddressAutoFix.Values['Shift+Enter'];
Text:=GetFixUrl(SrcKey,Text);
end;
ACID:begin
SrcKey:=FAddressAutoFix.Values['Ctrl+Alt+Enter'];
Text:=GetFixUrl(SrcKey,Text);
end;
SCID:begin
SrcKey:=FAddressAutoFix.Values['Ctrl+Shift+Enter'];
Text:=GetFixUrl(SrcKey,Text);
end;
ASID:begin
SrcKey:=FAddressAutoFix.Values['Alt+Shift+Enter'];
Text:=GetFixUrl(SrcKey,Text);
end;
ASCID:begin
SrcKey:=FAddressAutoFix.Values['Ctrl+Shift+Alt+Enter'];
Text:=GetFixUrl(SrcKey,Text);
end;
end;
if Text='' then
Text:='about:blank'
{else if (Pos('.',Text)=0) and (not FileExists(Text)) and
(not DirectoryExists(Text)) then
Text:='http://www.baidu.com/s?wd='+Text};
UpdateTypedUrls;
if Assigned(FOnUrlSelected) then
FOnUrlSelected(Self, Text, bCancel);
end;
FShiftKeyID:=0;
inherited;
end;
end.
代码没有整理，习惯没养好
完整组件这里下载