1 楼Gold2000（Gold2000）回复于 2006-02-27 09:44:57
实现点击ComboBox(DBComboBox)按钮下拉出现MonthCalendar效果
unit LMS_DBComboBox_Date;
interface
uses Variants, Windows, SysUtils, Messages, Controls, Forms, Classes,VDBConsts,DateUtils,
Graphics, Menus, StdCtrls, ExtCtrls, Mask, Buttons, ComCtrls, DB,DBCtrls,Dialogs,dbComboBoxEX;
type
TMyMonthCalendar = class(TMonthCalendar)
private
procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
end ;
TLMS_DBComboBox_Date = class(TdbComboBox) //TCustomComboBox
private
MyMonthCalendar:TMyMonthCalendar ;
// FDataLink: TFieldDataLink;
FPaintControl: TPaintControl;
procedure MyMonthCalendarExit(Sender: TObject);
procedure MyMonthCalendarClick(Sender: TObject);
procedure MyMonthCalendarDblClick(Sender: TObject);
procedure DataChange(Sender: TObject);
procedure EditingChange(Sender: TObject);
function GetComboText: string;
function GetDataField: string;
function GetDataSource: TDataSource;
function GetField: TField;
function GetReadOnly: Boolean;
procedure SetComboText(const Value: string);
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure SetEditReadOnly;
procedure SetReadOnly(Value: Boolean);
// procedure UpdateData(Sender: TObject);
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
function CompareTime(MyDate1 , MyDate2:TDateTime):boolean ;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override ;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override ;
protected
// procedure Change; override;
procedure Click; override;
procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
ComboProc: Pointer); override;
procedure CreateWnd; override;
procedure DropDown; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure Loaded; override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure SetItems(const Value: TStrings); override;
procedure SetStyle(Value: TComboboxStyle); override;
procedure WndProc(var Message: TMessage); override;
public
FDataLink: TFieldDataLink;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function ExecuteAction(Action: TBasicAction): Boolean; override;
function UpdateAction(Action: TBasicAction): Boolean; override;
function UseRightToLeftAlignment: Boolean; override;
property Field: TField read GetField;
//property Text;
procedure Change; override;
procedure UpdateData(Sender: TObject);
published
property Text;//:string read FText write SetText;
property Style; {Must be published before Items}
property Anchors;
property AutoComplete;
property AutoDropDown;
property BevelEdges;
property BevelInner;
property BevelOuter;
property BevelKind;
property BevelWidth;
property BiDiMode;
property CharCase;
property Color;
property Constraints;
property Ctl3D;
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property DragCursor;
property DragKind;
property DragMode;
property DropDownCount;
property Enabled;
property Font;
property ImeMode;
property ImeName;
property ItemHeight;
property Items write SetItems;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
property ShowHint;
property Sorted;
property TabOrder;
property TabStop;
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;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('LMS_DB', [TLMS_DBComboBox_Date]);
end;
constructor TLMS_DBComboBox_Date.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnUpdateData := UpdateData;
FDataLink.OnEditingChange := EditingChange;
FPaintControl := TPaintControl.Create(Self, 'COMBOBOX');
//Font.Name := '宋体' ;
//Font.Size := 10 ;
end;Top
2 楼Gold2000（Gold2000）回复于 2006-02-27 09:46:11
destructor TLMS_DBComboBox_Date.Destroy;
begin
//if Assigned(MyMonthCalendar) then MyMonthCalendar.Free ;
FPaintControl.Free;
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TLMS_DBComboBox_Date.Loaded;
begin
inherited Loaded;
if (csDesigning in ComponentState) then DataChange(Self);
end;
procedure TLMS_DBComboBox_Date.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TLMS_DBComboBox_Date.CreateWnd;
begin
inherited CreateWnd;
SetEditReadOnly;
end;
procedure TLMS_DBComboBox_Date.DataChange(Sender: TObject);
begin
if not (Style = csSimple) and DroppedDown then Exit;
if FDataLink.Field <> nil then
SetComboText(FDataLink.Field.Text)
else
if csDesigning in ComponentState then
SetComboText(Name)
else
SetComboText('');
end;
procedure TLMS_DBComboBox_Date.UpdateData(Sender: TObject);
var MyDate :TDateTime ;
begin
FDataLink.Field.Text := FormatDateTime('YYYY-MM-DD HH:MM:SS',StrToDateTimeDef(GetComboText,now)) ; // kkk =GetComboText
MyDate := StrToDateTimeDef(FDataLink.Field.Text , now) ;
if CompareTime(MyDate , now) then
beep ;
DataChange(Self) ;
end;
procedure TLMS_DBComboBox_Date.SetComboText(const Value: string);
var
I: Integer;
Redraw: Boolean;
begin
if Value <> GetComboText then
begin
if Style <> csDropDown then
begin
Redraw := (Style <> csSimple) and HandleAllocated;
if Redraw then SendMessage(Handle, WM_SETREDRAW, 0, 0);
try
if Value = '' then I := -1 else I := Items.IndexOf(Value);
ItemIndex := I;
finally
if Redraw then
begin
SendMessage(Handle, WM_SETREDRAW, 1, 0);
Invalidate;
end;
end;
if I >= 0 then Exit;
end;
if Style in [csDropDown, csSimple] then Text := Value;
end;
end;
function TLMS_DBComboBox_Date.GetComboText: string;
var
I: Integer;
begin
if Style in [csDropDown, csSimple] then Result := Text else
begin
I := ItemIndex;
if I < 0 then Result := '' else Result := Items[I];
end;
end;
procedure TLMS_DBComboBox_Date.Change;
begin
FDataLink.Edit;
inherited Change;
FDataLink.Modified;
end;
procedure TLMS_DBComboBox_Date.Click;
begin
FDataLink.Edit;
inherited Click;
FDataLink.Modified;
end;
procedure TLMS_DBComboBox_Date.DropDown;
begin
inherited DropDown;
if ReadOnly then
begin
Enabled := false ;
Enabled := true ;
exit ;
end ;
try
Enabled := false ;
if not Assigned(MyMonthCalendar) then
MyMonthCalendar := TMyMonthCalendar.Create(self) ;
//with MyMonthCalendar do
begin
MyMonthCalendar.Visible := false ;
MyMonthCalendar.Parent := Parent ;
MyMonthCalendar.Left := Left ;
MyMonthCalendar.Top := Top + Height ;
MyMonthCalendar.Width := 267 ;
MyMonthCalendar.Height := 154 ;
MyMonthCalendar.Date := StrToDateTimeDef(Text,now) ;
MyMonthCalendar.Visible := true ;
MyMonthCalendar.SetFocus ;
MyMonthCalendar.OnExit := MyMonthCalendarExit ;
MyMonthCalendar.OnClick := MyMonthCalendarClick ;
MyMonthCalendar.OnDblClick :=MyMonthCalendarDblClick ;
end ;
Enabled := true ;
except
Enabled := true ;
end ;
end;
procedure TLMS_DBComboBox_Date.MyMonthCalendarExit(Sender: TObject);
begin
TMonthCalendar(Sender).Visible := false ;
end ;
procedure TLMS_DBComboBox_Date.MyMonthCalendarClick(Sender: TObject);
begin
FDataLink.Edit;
Text := DateToStr(MyMonthCalendar.Date) + ' ' +
FormatDateTime('HH:MM:SS',StrToDateTimeDef(Text,now)) ;
FDataLink.Modified;
end ;
procedure TLMS_DBComboBox_Date.MyMonthCalendarDblClick(Sender: TObject);
begin
MyMonthCalendarClick(Sender) ;
MyMonthCalendar.Visible := false ;
end ;
function TLMS_DBComboBox_Date.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TLMS_DBComboBox_Date.SetDataSource(Value: TDataSource);
begin
if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
function TLMS_DBComboBox_Date.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;Top
3 楼Gold2000（Gold2000）回复于 2006-02-27 09:46:18
procedure TLMS_DBComboBox_Date.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TLMS_DBComboBox_Date.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TLMS_DBComboBox_Date.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TLMS_DBComboBox_Date.GetField: TField;
begin
Result := FDataLink.Field;
end;
procedure TLMS_DBComboBox_Date.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
if Key in [VK_BACK, VK_DELETE, VK_UP, VK_DOWN, 32..255] then
begin
if not FDataLink.Edit and (Key in [VK_UP, VK_DOWN]) then
Key := 0;
end;
end;
procedure TLMS_DBComboBox_Date.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
not FDataLink.Field.IsValidChar(Key) then
begin
MessageBeep(0);
Key := #0;
end;
case Key of
^H, ^V, ^X, #32..#255:
FDataLink.Edit;
#27:
begin
FDataLink.Reset;
SelectAll;
end;
end;
end;
procedure TLMS_DBComboBox_Date.EditingChange(Sender: TObject);
begin
SetEditReadOnly;
end;
procedure TLMS_DBComboBox_Date.SetEditReadOnly;
begin
if (Style in [csDropDown, csSimple]) and HandleAllocated then
SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.Editing), 0);
end;
procedure TLMS_DBComboBox_Date.WndProc(var Message: TMessage);
begin
if not (csDesigning in ComponentState) then
case Message.Msg of
WM_COMMAND:
if TWMCommand(Message).NotifyCode = CBN_SELCHANGE then
if not FDataLink.Edit then
begin
if Style <> csSimple then
PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);
Exit;
end;
CB_SHOWDROPDOWN:
if Message.WParam <> 0 then FDataLink.Edit else
if not FDataLink.Editing then DataChange(Self); {Restore text}
WM_CREATE,
WM_WINDOWPOSCHANGED,
CM_FONTCHANGED:
FPaintControl.DestroyHandle;
end;
inherited WndProc(Message);
end;
procedure TLMS_DBComboBox_Date.ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
ComboProc: Pointer);
begin
if not (csDesigning in ComponentState) then
case Message.Msg of
WM_LBUTTONDOWN:
if (Style = csSimple) and (ComboWnd <> EditHandle) then
if not FDataLink.Edit then Exit;
end;
inherited ComboWndProc(Message, ComboWnd, ComboProc);
end;
procedure TLMS_DBComboBox_Date.CMEnter(var Message: TCMEnter);
begin
inherited;
if SysLocale.FarEast and FDataLink.CanModify then
SendMessage(EditHandle, EM_SETREADONLY, Ord(False), 0);
end;
procedure TLMS_DBComboBox_Date.CMExit(var Message: TCMExit);
begin
try
//Text := FormatDateTime('YYYY-MM-DD HH:MM:SS',StrToDateTimeDef(GetComboText,now)) ;
FDataLink.UpdateRecord;
except
SelectAll;
SetFocus;
raise;
end;
inherited;
end;
procedure TLMS_DBComboBox_Date.WMPaint(var Message: TWMPaint);
var
S: string;
R: TRect;
P: TPoint;
Child: HWND;
begin
if csPaintCopy in ControlState then
begin
if FDataLink.Field <> nil then S := FDataLink.Field.Text else S := '';
if Style = csDropDown then
begin
SendMessage(FPaintControl.Handle, WM_SETTEXT, 0, Longint(PChar(S)));
SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
Child := GetWindow(FPaintControl.Handle, GW_CHILD);
if Child <> 0 then
begin
Windows.GetClientRect(Child, R);
Windows.MapWindowPoints(Child, FPaintControl.Handle, R.TopLeft, 2);
GetWindowOrgEx(Message.DC, P);
SetWindowOrgEx(Message.DC, P.X - R.Left, P.Y - R.Top, nil);
IntersectClipRect(Message.DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
SendMessage(Child, WM_PAINT, Message.DC, 0);
end;
end else
begin
SendMessage(FPaintControl.Handle, CB_RESETCONTENT, 0, 0);
if Items.IndexOf(S) <> -1 then
begin
SendMessage(FPaintControl.Handle, CB_ADDSTRING, 0, Longint(PChar(S)));
SendMessage(FPaintControl.Handle, CB_SETCURSEL, 0, 0);
end;
SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
end;
end else
inherited;
end;
procedure TLMS_DBComboBox_Date.SetItems(const Value: TStrings);
begin
inherited SetItems(Value);
DataChange(Self);
end;
procedure TLMS_DBComboBox_Date.SetStyle(Value: TComboboxStyle);
begin
if (Value = csSimple) and Assigned(FDatalink) and FDatalink.DatasourceFixed then
DatabaseError(SNotReplicatable);
inherited SetStyle(Value);
end;
function TLMS_DBComboBox_Date.UseRightToLeftAlignment: Boolean;
begin
Result := DBUseRightToLeftAlignment(Self, Field);
end;
procedure TLMS_DBComboBox_Date.CMGetDatalink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;
function TLMS_DBComboBox_Date.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TLMS_DBComboBox_Date.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
function TLMS_DBComboBox_Date.CompareTime(MyDate1 , MyDate2:TDateTime):boolean ;
var y,m,d,h,mm,ss,ms , y2,m2,d2,h2,mm2,ss2,ms2:word ;
begin
DecodeDateTime(MyDate1 , y , m ,d , h , mm , ss ,ms) ;
DecodeDateTime(MyDate1 , y2 , m2 ,d2 , h2 , mm2 , ss2 ,ms2) ;
if (y=y2) and (m=m2) and (d=d2) and (h=h2) and (mm=mm2) and (ss=ss2) then
Result := true
else Result := false
end ;
procedure TLMS_DBComboBox_Date.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
//var i , j , iLen , ib , ie:integer ;
begin
inherited ;
{ iLen := Length(Text) ;
if iLen >= 8 then
begin
i := SelStart ;
if (i+1 < iLen) and (not( (Text[i+1]) in [' ',':','-'] )) then
i := i + 1
else if (i-1 > 0) and (not( (Text[i-1]) in [' ',':','-'] )) then
i := i - 1 ;
ib := i ; ie := i ;
for j := i to iLen do
if (not( (Text[j]) in [' ',':','-'] )) then ie := j
else Break ;
for j := i downto 0 do
if (not( (Text[j]) in [' ',':','-'] )) then ib := j
else Break ;
SelStart := ib ;
SelLength := ie - ib ;
end ;}
//showmessage('u')
end ;
procedure TLMS_DBComboBox_Date.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited ;
//showmessage('d')
end ;
procedure TMyMonthCalendar.CMCancelMode(var Message: TCMCancelMode);
begin
if Message.Sender.Name <> self.Name then
visible := False;
inherited;
end;
end.