Listing 1. The PSIDBEdit unit. unit PSIDBEdit; interface uses Windows, SysUtils, Classes, Controls, Forms, Dialogs, DBCtrls, Menus, db, StrFunc; type TPSICharCase = (ecNormal, ecUpperCase, ecLowerCase, ecProperCase); TPSIDBEdit = class(TDBEdit) private fCharCase : TPSICharCase ; fIsChanging : Boolean ; fAllowUserChange : Boolean ; fStartMove : Boolean ; fTop : Integer ; fLeft : Integer ; fChangeMenu : TpopupMenu ; fPopupSave : TPopupMenu ; Procedure SetAllowUserChange(Value:Boolean); Procedure SetChangeMenu(Value:TpopupMenu) ; Procedure SetPopUpMenu ; Procedure SetCharCase(Value:TPSICharCase); Procedure SetTextCase(Const bCheckState:Boolean) ; protected public Procedure Loaded ; Override ; Procedure Change ; Override ; procedure KeyDown(var Key: Word; Shift: TShiftState); override; Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override ; procedure MouseMove(Shift: TShiftState; X, Y: Integer); Override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; published Property AllowUserChange : Boolean Read fAllowUserChange Write SetAllowUserChange ; Property CharCase : TPSICharCase Read fCharCase Write SetCharCase ; Property PopupChangeMenu : TPopupMenu Read fChangeMenu Write SetChangeMenu ; end; |
Listing 2. The Loaded method. Procedure TPSIDBEdit.Loaded; Begin Try If (csDesigning in ComponentState) Then Exit ; // Capture PopupMenu Assignment fPopupSave := PopupMenu ; SetPopupMenu ; Finally inherited Loaded; End; End; |
Listing 3. The Change method. Procedure TPSIDBEdit.Change ; Var iSelStart : Integer ; Begin Try If (csDesigning in ComponentState) Or fIsChanging Then Exit ; // Capture Cursor Position iSelStart := SelStart ; SetTextCase(False) ; // Restore Cursor Position SelStart := iSelStart ; Finally Inherited ; End; End; |
Listing 4. The SetTextCase method. Procedure TPSIDBEdit.SetTextCase(Const bCheckState: Boolean) ; Var bPost : Boolean ; Function CanChange : Boolean ; Begin Try If Not bCheckState Then Begin Result := True ; Exit ; End; If (DataSource <> Nil) Then Begin If Not (DataSource.DataSet.State In [dsEdit, dsInsert]) Then Begin If DataSource.DataSet.Active Then Begin DataSource.DataSet.Edit ; bPost := True ; End; End; End; Result := True ; Except Result := False ; End; End; Begin // If the Text changes and the DataSet // is not in EditState, then an Exception // is generated. Make sure DataSet is // in EditState before changing Text. fIsChanging := True ; Try bPost := False ; If CanChange Then Begin Case CharCase Of ecNormal : {Do Nothing} ; ecUpperCase : Text := UpperCase(Text) ; ecLowerCase : Text := LowerCase(Text) ; ecProperCase: Text := ToProper(Text); End; If bPost Then DataSource.DataSet.Post ; End Else MessageDlg('Another user may be using this '+ 'record.'+#13+#13+ 'TextCase changes may not be '+ 'visible for this record.' , mtWarning,[mbOK],0); Finally fIsChanging := False ; End; End; |
Listing 5. The SetCharCase method. Procedure TPSIDBEdit.SetCharCase(Value:TPSICharCase); Begin If fCharCase <> Value Then Begin fCharCase := Value ; SetTextCase(True) ; End; End; |
Listing 6. The KeyDown method. Procedure TPSIDBEdit.KeyDown(var Key: Word; Shift: TShiftState); Begin If (Key in [vk_up,vk_down,vk_left,vk_right]) And AllowUserChange Then Begin If (Shift = [ssCtrl]) Then Begin // Change position Case Key Of vk_Up : Top := Top - 1; vk_Down : Top := Top + 1; vk_Left : Left := Left - 1; vk_Right: Left := Left + 1 ; End; End Else If (Shift = [ssShift]) Then Begin // Change Size Case Key Of vk_Up : Height := Height - 1; vk_Down : Height := Height + 1; vk_Left : Width := Width - 1; vk_Right: Width := Width + 1 ; End; End; Key := 0 ; End Else Begin inherited KeyDown(Key,Shift); End; End; |
Listing 7. Getting and Setting an object's property at runtime. Function GetProperty(Sender:TComponent ;sPropName:String):Variant Var PropInfo : PPropinfo; Begin // From the class information, get the property PropInfo := GetPropInfo(Sender.ClassInfo, sPropName); // Does the property exist? If (PropInfo <> Nil) Then Begin Case propinfo^.PropType^.Kind Of tkEnumeration,tkInteger: Begin Result := GetOrdProp(Sender,PropInfo) End; tkString,tkLString,tkWString: Begin Result := GetStrProp(Sender,PropInfo) End; End; End Else Result := Null; End; Procedure SetProperty(Sender:TComponent ;sPropName:String ;vValue:Variant) Var PropInfo : PPropinfo; Begin // From the class information, get the property PropInfo := GetPropInfo(Sender.ClassInfo, sPropName); // Does the property exist? If (PropInfo <> Nil) Then Begin Case propinfo^.PropType^.Kind Of tkEnumeration,tkInteger: Begin SetOrdProp(Sender,PropInfo,vValue); End; tkString,tkLString,tkWString: Begin SetStrProp(Sender,PropInfo,vValue); End; End; End; End; |
SetProperty(DBEdit1,'Ctl3D',False); DBEdit2.Ctrl3D := GetProperty(DBEdit1.'Ctl3D') ; |
If IsProperty(Form1.Components[i],'Ctl3D') Then Components[i].Ctl3D := False ; |
Listing 8. The ChangeMenu unit. unit ChangeMenu; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus,comctrls, StdCtrls,dbctrls, db,extctrls ; type TChangeMenu = class(TPopupMenu) private { Private declarations } pm_Font : TMenuItem ; pm_bgColor : TMenuItem ; pm_TabOrder : TMenuItem ; pm_Ctrl3D : TMenuItem ; pm_BorderStyle: TMenuItem ; pm_Columns : TMenuItem ; pm_Caption : TMenuItem ; pm_Divider1 : TMenuItem ; pm_UpperCase : TMenuItem ; pm_LowerCase : TMenuItem ; pm_MixedCase : TMenuItem ; pm_ProperCase : TMenuItem ; pm_Height : TMenuItem ; pm_Width : TMenuItem ; pm_Style : TMenuItem ; fFontDialog :TFontDialog ; fColorDialog :TColorDialog ; Procedure SetColorDialog(Value:TColorDialog); Procedure SetFontDialog(Value:TFontDialog); Procedure MenuClick(Sender:TObject); Procedure OnMenuPopup(Sender:TObject) ; protected { Protected declarations } public { Public declarations } Procedure Loaded ; Override ; Destructor destroy; override ; Constructor Create(AOwner: TComponent); override; published { Published declarations } Property FontDialog :TFontDialog Read fFontDialog Write SetFontDialog ; Property ColorDialog : TColorDialog Read fColorDialog Write SetColorDialog ; end; procedure Register; implementation uses PropFunc, col_edit ; |
Listing 9. The Loaded method. Procedure TChangeMenu.Loaded; Begin Try // Save pointer to Component's OnPopup Method FOtherOnPopup := OnPopup ; // Assign OnPopup Method OnPopup := OnMenuPopup ; Finally Inherited ; End; End; |
Listing 10. The OnMenuPopup method. Procedure TChangeMenu.OnMenuPopup(Sender:TObject) ; // Initialize menu items based on the // focused component's type and properties. Var bSet : Boolean ; Begin // Don't show Font item if the Font // Dialog property is Nil or the Font // Property doesn't exist in the focused // component. pm_Font.Visible := (Not (FontDialog = Nil)) And IsProperty(PopupComponent,'Font'); // Don't show Color item if the ColorDialog // Property is Nil or the Color property doesn't // exist in the focused component. pm_bgColor.Visible := Not (ColorDialog = Nil) And IsProperty(PopupComponent,'Color'); // Initialize Radio and Checked Menu Items If IsProperty(PopupComponent, 'BorderStyle') Then Begin pm_BorderStyle.Checked := (GetProperty(PopupComponent, 'BorderStyle') = bsSingle) ; pm_BorderStyle.Visible := True ; End Else Begin pm_BorderStyle.Visible := False ; End; If IsProperty(PopupComponent,'Ctl3D') Then Begin pm_Ctrl3D.Checked := GetProperty(PopupComponent,'Ctl3D'); pm_Ctrl3D.Visible := True ; End Else Begin pm_Ctrl3D.Visible := False ; End; // If the TabOrder property exists in the component, // show the Menu item 'Tab Order'. pm_TabOrder.Visible:= IsProperty(PopupComponent,'TabOrder') ; // If the Columns property exists in the component // and the component is TListView, // show the menu item. If (PopupComponent Is TListView) Then pm_columns.Visible := ( IsProperty(PopupComponent,'Columns') And (TListView(PopupComponent).Columns.Count >0)) Else pm_columns.Visible := False ; // You should have the idea by now ... pm_Caption.Visible := IsProperty(PopupComponent,'Caption'); // If the focused component has CharCase and // AllowUser Change properties, then process more // menu items. If (IsProperty(PopupComponent,'CharCase') And IsProperty(PopupComponent, 'AllowUserChange')) Then Begin bSet := True ; // Don't show CharCase items if the // DataType isn't String. If IsProperty(PopupComponent, 'DataSource') Then Begin If (PopupComponent is TDBEdit) Then Begin With TDBEdit(PopupComponent) Do Begin If (DataField <> '') Then Begin If Not (Field.DataType = ftString) Then Begin bSet := False ; End; End Else bSet := False ; End; End; End; pm_UpperCase.Visible := bSet ; pm_LowerCase.Visible := bSet ; pm_MixedCase.Visible := bSet ; pm_ProperCase.Visible := bSet ; pm_Divider1.Visible := bSet ; // Initialize CharCase Radio Items. Case GetProperty(PopupComponent,'CharCase') Of //ecNormal 0: pm_MixedCase.Checked := True ; //ecUpperCase 1: pm_UpperCase.Checked := True ; //ecLowerCase 2: pm_LowerCase.Checked := True ; //ecProperCase 3: pm_ProperCase.Checked := True ; End; End Else Begin pm_UpperCase.Visible := False ; pm_LowerCase.Visible := False ; pm_MixedCase.Visible := False ; pm_ProperCase.Visible := False ; pm_Divider1.Visible := False ; End; pm_Width.Visible := (PopupComponent is TBevel); pm_Height.Visible := (PopupComponent is TBevel); pm_Style.Visible := (PopupComponent is TBevel); If pm_Style.Visible Then Begin If GetProperty(PopupComponent,'Style')=0 Then pm_Style.Caption := 'Raised Bevel' Else pm_Style.Caption := 'Lowered Bevel' ; End; // execute component's OnPopup Event. If Assigned(FOtherOnPopup) Then FOtherOnPopup(Sender); End; |
Listing 11. The MenuClick method. Procedure TChangeMenu.MenuClick(Sender:TObject); // Process the menu selection for the focused // component. Var sString : String ; i,iInt : Integer ; b : Boolean ; Begin If (TMenuItem(Sender)= pm_Ctrl3D) Then Begin // Process 3D - If 3D is selected // then BorderStyle must be changed // to Single. b := Not Boolean(GetProperty(PopupComponent, 'Ctl3D')); SetProperty(PopupComponent,'Ctl3D',Ord(b)); If b And (GetProperty(PopupComponent, 'BorderStyle') = bsNone) Then SetProperty(PopupComponent, 'BorderStyle',bsSingle); End Else If (TMenuItem(Sender)= pm_BorderStyle) Then Begin // Process BorderStyle If (GetProperty(PopupComponent, 'BorderStyle') = bsSingle) Then Begin SetProperty(PopupComponent, 'BorderStyle',bsNone); // If BorderStyle is set to None, then // turn 3D Off. SetProperty(PopupComponent,'Ctl3D',False); End Else SetProperty(PopupComponent, 'BorderStyle',bsSingle); End Else If (TMenuItem(Sender)= pm_TabOrder) Then Begin // Process TabOrder sString := IntToStr(GetProperty(PopupComponent, 'TabOrder')); Try sString := InputBox('Set Tab Order', 'Enter Tab Order',sString); iInt := StrToInt(sString); SetProperty(PopupComponent,'TabOrder',iInt) ; Except Raise Exception.Create('Tab Order Must '+ 'Be An Integer'); End; End Else If (TMenuItem(Sender)= pm_Font) Then Begin // Process Font selection If (FontDialog <> Nil) Then Begin FontDialog.Font.Name := GetProperty(PopupComponent,'Font.Name') ; FontDialog.Font.Size := GetProperty(PopupComponent,'Font.Size') ; FontDialog.Font.Color := GetProperty(PopupComponent,'Font.Color') ; FontDialog.Font.Style := TFontStyles(TFontStyle( GetProperty(PopupComponent,'Font.Style'))); If FontDialog.Execute Then Begin SetProperty(PopupComponent,'Font.Name' ,FontDialog.Font.Name); SetProperty(PopupComponent,'Font.Size', FontDialog.Font.Size); SetProperty(PopupComponent,'Font.Color', FontDialog.Font.Color); SetProperty(PopupComponent,'Font.Style', Ord(TFontStyle(FontDialog.Font.Style))); // Force Font Height to refresh // the component i:= GetProperty(PopupComponent, 'Font.Height'); SetProperty(PopupComponent, 'Font.Height',i+(-5)); SetProperty(PopupComponent, 'Font.Height',i); End; End; End Else If (TMenuItem(Sender) = pm_BgColor) Then Begin // Process Color If ColorDialog <> Nil Then Begin ColorDialog.Color := GetProperty(PopupComponent,'Color') ; If ColorDialog.Execute Then Begin SetProperty(PopupComponent,'Color', ColorDialog.Color) ; End; End; End Else If (TMenuItem(Sender) = pm_Caption) Then Begin // Process Caption sString := GetProperty(PopupComponent,'Caption'); sString := InputBox('Change Caption', 'Enter Caption',sString); SetProperty(PopupComponent,'Caption',sString) ; End Else If (TMenuItem(Sender) = pm_columns) Then Begin // Process Columns for TListView. This is done // with an external form. Application.CreateForm(TfrmEditColumns, frmEditColumns); Try frmEditColumns.ColObject := TListView(PopupComponent) ; frmEditColumns.ShowModal ; Finally frmEditColumns.Free ; End; End Else If (TMenuItem(Sender)=pm_Width) Then Begin // Process Width for TBevel sString := IntToStr(GetProperty(PopupComponent, 'Width')); Try sString := InputBox('Set Width', 'Enter Width',sString); iInt := StrToInt(sString); SetProperty(PopupComponent,'Width',iInt) ; Except Raise Exception.Create('Width Must Be '+ 'An Integer'); End; End Else If (TMenuItem(Sender)=pm_Height) Then Begin // Process Height for TBevel sString := IntToStr(GetProperty(PopupComponent, 'Height')); Try sString := InputBox('Set Height', 'Enter Height',sString); iInt := StrToInt(sString); SetProperty(PopupComponent,'Height',iInt) ; Except Raise Exception.Create('Height Must Be '+ 'An Integer'); End; End Else If (TMenuItem(Sender)=pm_Style) Then Begin // Process Bevel Stype for TBevel // Raised or Lowered If GetProperty(PopupComponent,'Style')=0 Then SetProperty(PopupComponent,'Style',1) Else SetProperty(PopupComponent,'Style',0) End Else Begin TMenuItem(Sender).Checked := Not TMenuItem(Sender).Checked; If pm_MixedCase.Checked Then Begin // Normal SetProperty(PopupComponent,'CharCase',0) ; End Else If pm_UpperCase.Checked Then Begin //CharCase := ecUpperCase ; SetProperty(PopupComponent,'CharCase',1) ; End Else If pm_LowerCase.Checked Then Begin //CharCase := ecLowerCase ; SetProperty(PopupComponent,'CharCase',2) ; End Else If pm_ProperCase.Checked Then Begin //CharCase := ecProperCase ; SetProperty(PopupComponent,'CharCase',3) ; End; End; End; |
ComponentStates1.SetProperties(Form1,'TDBEdit', 'Font.Name','Arial'); ComponentStates1.SetProperties(Form1,'TDBEdit', 'Font.Size',12); |
Listing 12. The SetProperties method. Procedure TComponentStates.SetProperties( Const Frm:TForm ;Const sClassName:String ;Const sPropertyName:String ;Const vValue:Variant); //**************************************************** //Sets all components properties on the Form Frm where //component.classname = sClassName with vValue. //**************************************************** Var i : Integer ; Begin With Frm Do Begin For i := 0 To (ComponentCount-1) Do Begin If Components[i].ClassNameIs(sClassName) Then Begin SetProperty(Components[i],sPropertyName, vValue); End; End; End; //with Frm End; |
TPSIDBEdit.Left TPSIDBEdit.Top TPSIDBEdit.Height TPSIDBEdit.Width TPSIDBEdit.TabOrder TPSIDBEdit.Font.Name TPSIDBEdit.Font.Size TPSIDBEdit.Font.Style TPSIDBEdit.Font.Color TPSIDBEdit.Color TPSIDBEdit.Ctl3D TPSIDBEdit.BorderStyle TPSIDBEdit.CharCase |
[Form1] PSIDBEdit1.Left=313 PSIDBEdit1.Top=319 PSIDBEdit1.Height=21 PSIDBEdit1.Width=121 PSIDBEdit1.TabOrder=5 PSIDBEdit1.Font.Name=MS Sans Serif PSIDBEdit1.Font.Size=8 PSIDBEdit1.Font.Style=0 PSIDBEdit1.Font.Color=-2147483640 PSIDBEdit1.Color=-2147483643 PSIDBEdit1.Ctl3D=1 PSIDBEdit1.BorderStyle=1 PSIDBEdit1.CharCase=0 |
Listing 13. The Process method. Procedure TComponentStates.Process(bSave:Boolean); Var i,ii : Integer ; sPropertyName : String ; sSection : String ; sClassName : String ; sID : String ; vValue : Variant ; slPropList : TStrings ; Begin If Not Active Then Exit ; slPropList := TStringList.Create ; fIniFile := TIniFile.Create(FIniPath+ SaveToINIFileName); Try // Use the form's name for the section ID in // the INI file. sSection := fOwner.Name ; For i := 0 To (fOwner.ComponentCount-1) Do Begin slPropList.Clear ; sClassName := fOwner.Components[i].ClassName ; // Get Property List For Class slPropList.Text := ProcessClass(fOwner.Components[i]) ; If (slPropList.Text <> '') Then Begin //********************************************* //Process all defined properties for this Class //********************************************* For ii := 0 To (slPropList.Count-1) Do Begin sPropertyName := slPropList.Strings[ii] ; sID := fOwner.Components[i].Name+'.'+ sPropertyName ; If bSave Then Begin // Write Property Values to INI file vValue := GetProperty(fOwner.Components[i], sPropertyName); If (vValue <> Null) Then Begin Case VarType(vValue) Of varInteger: fIniFile.WriteInteger(sSection,sID, vValue); varString: fIniFile.WriteString(sSection, sID,vValue); End; // Case VarType(vValue) End; End Else Begin // *********************************** // Read property from INI file and set // component's property. // *********************************** // Get Current Property Value as a default vValue := GetProperty(fOwner.Components[i], sPropertyName); If (vValue <> Null) Then Begin // Read property value from INI file Case VarType(vValue) Of varInteger: Begin vValue := fIniFile.ReadInteger(sSection, sID, vValue); End; varString: Begin vValue := fIniFile.ReadString(sSection, sID, vValue); End; Else vValue := Null ; End; // Case VarType(vValue) If (vValue <> Null) Then Begin SetProperty(fOwner.Components[i], sPropertyName,vValue); End; End; End; // If bSave End; // For ii End; // If (slPropList.Text <> '') End; // For i Finally slPropList.Free ; fIniFile.Free ; End; End; |
procedure TForm1.FormShow(Sender: TObject); begin DataModule1.ComponentStates1.Restore(Self); end; |
procedure TForm1.FormClose(Sender: Tobject ;var Action: TCloseAction); begin DataModule1.ComponentStates1.Save(Self); end; |
procedure TForm1.cbAllowUserChangeClick(Sender: TObject); begin // Globally set the property of AllowUserChange on // all Components that are of type TPSIDBEdit // and TLabel3D With DataModule1.ComponentStates1 Do Begin SetProperties(Self,'TPSIDBEdit','AllowUserChange', cbAllowUserChange.Checked); SetProperties(Self,'TLabel3D','AllowUserChange', cbAllowUserChange.Checked); End; end; |
procedure TForm1.btnGlobalBGClick(Sender: TObject); begin // Globally set the Color property of // all Components that are of type TPSIDBEdit. With DataModule1 Do Begin If ColorDialog1.Execute Then Begin ComponentStates1.SetProperties( Self,'TPSIDBEdit','Color', ColorDialog1.Color); End; End; end; procedure TForm1.btnGlobalFGClick(Sender: TObject); begin // Globally set the Font.Color property of // all Components that are of type TPSIDBEdit. With DataModule1 Do Begin If ColorDialog1.Execute Then Begin ComponentStates1.SetProperties( Self,'TPSIDBEdit','Font.Color', ColorDialog1.Color); End; End; end; |