diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.dpr b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.dpr new file mode 100644 index 0000000..ea78c08 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.dpr @@ -0,0 +1,13 @@ +program AdvInputTaskDialogDemo; + +uses + Forms, + UAdvInputTaskDialogDemo in 'UAdvInputTaskDialogDemo.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.dproj b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.dproj new file mode 100644 index 0000000..cbce3c2 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.dproj @@ -0,0 +1,113 @@ + + + {40ed30c4-44b3-4d9c-8bf7-596b00214c5a} + Debug + AnyCPU + DCC32 + AdvInputTaskDialogDemo.exe + AdvInputTaskDialogDemo.dpr + + + 7.0 + False + False + 0 + RELEASE + + + 7.0 + DEBUG + + + Delphi.Personality + + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Microsoft Office XP Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components + CodeGear C++Builder Office 2000 Servers Package + CodeGear C++Builder Office XP Servers Package + + + AdvInputTaskDialogDemo.dpr + + + + + + + MainSource + + +
Form1
+ + + \ No newline at end of file diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.res b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.res new file mode 100644 index 0000000..be94ddf Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvInputTaskDialogDemo.res differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.dpr b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.dpr new file mode 100644 index 0000000..bc37470 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.dpr @@ -0,0 +1,14 @@ +program AdvMsgBoxExplorer; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.dproj b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.dproj new file mode 100644 index 0000000..79dd07c --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.dproj @@ -0,0 +1,41 @@ + + + {3be14241-b500-4048-b206-8a73172c37f9} + AdvMsgBoxExplorer.dpr + Debug + AnyCPU + DCC32 + AdvMsgBoxExplorer.exe + + + 7.0 + False + False + 0 + RELEASE + + + 7.0 + DEBUG + + + Delphi.Personality + VCLApplication + +FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0 + Microsoft Office XP Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components + CodeGear C++Builder Office 2000 Servers Package + CodeGear C++Builder Office XP Servers Package + AdvMsgBoxExplorer.dpr + + + + + MainSource + + +
Form1
+ + + \ No newline at end of file diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.res b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.res new file mode 100644 index 0000000..42a5081 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/AdvMsgBoxExplorer.res differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.dpr b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.dpr new file mode 100644 index 0000000..e1ac7bc --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.dpr @@ -0,0 +1,14 @@ +program TaskDialogExplorer; + +uses + Forms, + fmMain in 'fmMain.pas' {MainForm}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.dproj b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.dproj new file mode 100644 index 0000000..9ae7939 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.dproj @@ -0,0 +1,41 @@ + + + {15a8d16e-1063-4b59-8cb3-07496f176779} + TaskDialogExplorer.dpr + Debug + AnyCPU + DCC32 + TaskDialogExplorer.exe + + + 7.0 + False + False + 0 + RELEASE + + + 7.0 + DEBUG + + + Delphi.Personality + VCLApplication + +FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0 + Microsoft Office XP Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components + CodeGear C++Builder Office 2000 Servers Package + CodeGear C++Builder Office XP Servers Package + TaskDialogExplorer.dpr + + + + + MainSource + + +
MainForm
+ + + \ No newline at end of file diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.res b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.res new file mode 100644 index 0000000..42a5081 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/TaskDialogExplorer.res differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/UAdvInputTaskDialogDemo.dfm b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/UAdvInputTaskDialogDemo.dfm new file mode 100644 index 0000000..685effd --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/UAdvInputTaskDialogDemo.dfm @@ -0,0 +1,100 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'TAdvInputTaskDialog demo' + ClientHeight = 225 + ClientWidth = 406 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 264 + Top = 22 + Width = 91 + Height = 13 + Caption = 'Preset input value:' + end + object Label2: TLabel + Left = 264 + Top = 103 + Width = 34 + Height = 13 + Caption = 'Result:' + end + object RadioGroup1: TRadioGroup + Left = 16 + Top = 16 + Width = 233 + Height = 161 + Caption = 'Select input control' + ItemIndex = 0 + Items.Strings = ( + 'Edit' + 'Combo editor' + 'Combo list' + 'Memo' + 'Date picker' + 'Custom control (spin editor)') + TabOrder = 0 + end + object Button1: TButton + Left = 264 + Top = 72 + Width = 121 + Height = 25 + Caption = 'Show inputdialog' + TabOrder = 1 + OnClick = Button1Click + end + object Edit1: TEdit + Left = 264 + Top = 45 + Width = 121 + Height = 21 + TabOrder = 2 + Text = 'preset' + end + object Edit2: TEdit + Left = 264 + Top = 122 + Width = 121 + Height = 21 + TabOrder = 3 + end + object SpinEdit1: TSpinEdit + Left = 16 + Top = 195 + Width = 121 + Height = 22 + MaxValue = 0 + MinValue = 0 + TabOrder = 4 + Value = 0 + Visible = False + end + object AdvInputTaskDialog1: TAdvInputTaskDialog + CommonButtons = [] + DefaultButton = 0 + Icon = tiInformation + InputType = itEdit + InputItems.Strings = ( + 'BMW' + 'Audi' + 'Mercedes' + 'Porsche' + 'VW' + 'Ferrari') + Title = 'Windows Vista Input dialog' + Content = 'Enter value here' + OnDialogInputSetText = AdvInputTaskDialog1DialogInputSetText + OnDialogInputGetText = AdvInputTaskDialog1DialogInputGetText + Left = 352 + Top = 152 + end +end diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/UAdvInputTaskDialogDemo.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/UAdvInputTaskDialogDemo.pas new file mode 100644 index 0000000..ee4bdd9 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/UAdvInputTaskDialogDemo.pas @@ -0,0 +1,69 @@ +unit UAdvInputTaskDialogDemo; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls, TaskDialog, Spin; + +type + TForm1 = class(TForm) + AdvInputTaskDialog1: TAdvInputTaskDialog; + RadioGroup1: TRadioGroup; + Button1: TButton; + Edit1: TEdit; + Label1: TLabel; + Label2: TLabel; + Edit2: TEdit; + SpinEdit1: TSpinEdit; + procedure Button1Click(Sender: TObject); + procedure AdvInputTaskDialog1DialogInputGetText(Sender: TObject; + var Text: string); + procedure AdvInputTaskDialog1DialogInputSetText(Sender: TObject; + Text: string); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.AdvInputTaskDialog1DialogInputGetText(Sender: TObject; + var Text: string); +begin + Text := SpinEdit1.Text; +end; + +procedure TForm1.AdvInputTaskDialog1DialogInputSetText(Sender: TObject; + Text: string); +begin + SpinEdit1.Text := Text; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + case radiogroup1.ItemIndex of + 0: AdvInputTaskDialog1.InputType := itEdit; + 1: AdvInputTaskDialog1.InputType := itComboEdit; + 2: AdvInputTaskDialog1.InputType := itComboList; + 3: AdvInputTaskDialog1.InputType := itMemo; + 4: AdvInputTaskDialog1.InputType := itDate; + 5: + begin + AdvInputTaskDialog1.InputType := itCustom; + AdvInputTaskDialog1.InputControl := SpinEdit1; + + end; + end; + AdvInputTaskDialog1.InputText := Edit1.Text; + AdvInputTaskDialog1.Execute; + Edit2.Text := AdvInputTaskDialog1.InputText; +end; + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/Unit1.dfm b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/Unit1.dfm new file mode 100644 index 0000000..3f3e4c6 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/Unit1.dfm @@ -0,0 +1,130 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'AdvMessageBox Test' + ClientHeight = 303 + ClientWidth = 380 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 14 + Top = 16 + Width = 47 + Height = 13 + Caption = 'Caption: ' + end + object Label2: TLabel + Left = 30 + Top = 48 + Width = 25 + Height = 13 + Caption = 'Icon:' + end + object Label3: TLabel + Left = 29 + Top = 76 + Width = 26 + Height = 13 + Caption = 'Text:' + end + object Label4: TLabel + Left = 14 + Top = 184 + Width = 41 + Height = 13 + Caption = 'Buttons:' + end + object Label5: TLabel + Left = 24 + Top = 232 + Width = 34 + Height = 13 + Caption = 'Result:' + end + object lbresults: TLabel + Left = 64 + Top = 232 + Width = 3 + Height = 13 + end + object BtnTMS: TButton + Left = 65 + Top = 264 + Width = 145 + Height = 25 + Caption = 'TMS TAdvMessageBox' + TabOrder = 0 + OnClick = BtnTMSClick + end + object BtnWindows: TButton + Left = 216 + Top = 264 + Width = 145 + Height = 25 + Caption = 'Windows Messagebox' + TabOrder = 1 + OnClick = BtnWindowsClick + end + object edCaption: TEdit + Left = 61 + Top = 13 + Width = 300 + Height = 21 + TabOrder = 2 + Text = 'Test of MessageBox' + end + object cbIcon: TComboBox + Left = 61 + Top = 45 + Width = 300 + Height = 21 + ItemHeight = 13 + ItemIndex = 0 + TabOrder = 3 + Text = 'Select Icon' + Items.Strings = ( + 'Select Icon' + 'MB_ICONEXCLAMATION' + 'MB_ICONWARNING' + 'MB_ICONASTERISK' + 'MB_ICONINFORMATION' + 'MB_ICONQUESTION' + 'MB_ICONSTOP' + 'MB_ICONERROR' + 'MB_ICONHAND') + end + object MemoInfo: TMemo + Left = 61 + Top = 76 + Width = 300 + Height = 89 + Lines.Strings = ( + 'Sample short message.') + TabOrder = 4 + end + object cbButtons: TComboBox + Left = 64 + Top = 184 + Width = 297 + Height = 21 + ItemHeight = 13 + TabOrder = 5 + Text = 'Pick Buttons' + Items.Strings = ( + 'Pick the buttons to show' + 'ABORT, RETRY, IGNORE' + 'CANCEL, TRY AGAIN, CONTINUE' + 'OK' + 'OK, CANCEL' + 'RETRY, CANCEL' + 'YES, NO' + 'YES, NO, CANCEL') + end +end diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/Unit1.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/Unit1.pas new file mode 100644 index 0000000..9ab33f9 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/Unit1.pas @@ -0,0 +1,125 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls; + +type + TForm1 = class(TForm) + BtnTMS: TButton; + BtnWindows: TButton; + Label1: TLabel; + edCaption: TEdit; + Label2: TLabel; + cbIcon: TComboBox; + Label3: TLabel; + MemoInfo: TMemo; + Label4: TLabel; + cbButtons: TComboBox; + Label5: TLabel; + lbresults: TLabel; + procedure BtnWindowsClick(Sender: TObject); + procedure BtnTMSClick(Sender: TObject); + private + Fmbtitle: string; + FBoxInformation: string; + FBoxflags: integer; + { Private declarations } + procedure MakeDialog(id: string); + procedure Setmbtitle(const Value: string); + procedure SetBoxInformation(const Value: string); + procedure SetBoxflags(const Value: integer); + public + { Public declarations } + + property BoxTitle: string read Fmbtitle write Setmbtitle; + property BoxInformation: string read FBoxInformation write SetBoxInformation; + property Boxflags: integer read FBoxflags write SetBoxflags; + end; + +var + Form1: TForm1; + +implementation + +uses + TaskDialog; + +{$R *.dfm} + +const + MB_CANCELTRYCONTINUE = $00000006; + iconlist: array[1..8] of integer = + (MB_ICONEXCLAMATION, + MB_ICONWARNING, + MB_ICONINFORMATION, + MB_ICONASTERISK, + MB_ICONQUESTION, + MB_ICONSTOP, + MB_ICONERROR, + MB_ICONHAND); + btnlist: array[1..7] of integer = + ( MB_ABORTRETRYIGNORE, + MB_CANCELTRYCONTINUE, + MB_OK, + MB_OKCANCEL, + MB_RETRYCANCEL, + MB_YESNO, + MB_YESNOCANCEL); + + + +// Create dialog fields for the messagebox +procedure TForm1.MakeDialog(id: string); +var + i: Integer; +begin + // make box fields from ui + BoxTitle := edCaption.text + ' ('+id+')'; // title + BoxInformation := memoInfo.Lines[0]; // info + for i := 1 to memoInfo.Lines.count - 1 do + BoxInformation := BoxInformation + #10+MemoInfo.Lines[i]; + BoxFlags := 0; + if cbIcon.ItemIndex > 0 then + BoxFlags := BoxFlags or IconList[cbIcon.ItemIndex]; + if cbButtons.ItemIndex > 0 then + BoxFlags := boxFlags or btnlist[cbButtons.itemindex]; +end; + +procedure TForm1.BtnTMSClick(Sender: TObject); +var + res: integer; +begin + MakeDialog('TMS'); + res := AdvMessagebox(0,pchar(BoxInformation), pchar(BoxTitle), BoxFlags); + lbResults.caption := IntToStr(res); +end; + +procedure TForm1.BtnWindowsClick(Sender: TObject); +var + res: integer; +begin + MakeDialog('WINDOWS'); + res := Messagebox(0,pchar(BoxInformation),pchar(BoxTitle),BoxFlags); + lbResults.caption := InttoStr(res); +end; + + +procedure TForm1.SetBoxflags(const Value: integer); +begin + FBoxflags := Value; +end; + +procedure TForm1.SetBoxInformation(const Value: string); +begin + FBoxInformation := Value; +end; + +procedure TForm1.Setmbtitle(const Value: string); +begin + Fmbtitle := Value; +end; + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/fmMain.dfm b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/fmMain.dfm new file mode 100644 index 0000000..a1d4604 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/fmMain.dfm @@ -0,0 +1,310 @@ +object MainForm: TMainForm + Left = 0 + Top = 0 + Hint = 'Thiis the Windows title for the dialog b ox' + Caption = 'TMS TAdvTaskDialog Explorer' + ClientHeight = 426 + ClientWidth = 530 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + Position = poDesktopCenter + ShowHint = True + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 136 + Top = 278 + Width = 321 + Height = 13 + Caption = 'Separate button names with spaces (Use quotes to embed spaces)' + end + object Label3: TLabel + Left = 8 + Top = 4 + Width = 81 + Height = 13 + Caption = 'Include elements' + end + object Label2: TLabel + Left = 36 + Top = 238 + Width = 81 + Height = 13 + Caption = 'Common Buttons' + end + object Label4: TLabel + Left = 58 + Top = 164 + Width = 61 + Height = 13 + Caption = 'Expand label' + end + object Label5: TLabel + Left = 306 + Top = 163 + Width = 72 + Height = 13 + Caption = 'Collapse Label:' + end + object Label6: TLabel + Left = 19 + Top = 367 + Width = 74 + Height = 13 + Caption = 'Default button:' + end + object Button1: TButton + Left = 242 + Top = 393 + Width = 264 + Height = 25 + Caption = 'Test TAdvTaskDialog' + TabOrder = 0 + OnClick = Button1Click + end + object cbFooter: TCheckBox + Left = 18 + Top = 325 + Width = 97 + Height = 17 + Caption = 'Include Footer' + Checked = True + State = cbChecked + TabOrder = 1 + OnClick = cbFooterClick + end + object cbExpanded: TCheckBox + Left = 18 + Top = 126 + Width = 84 + Height = 17 + Caption = 'More Details' + Checked = True + State = cbChecked + TabOrder = 2 + OnClick = cbExpandedClick + end + object cbVerify: TCheckBox + Left = 19 + Top = 303 + Width = 81 + Height = 12 + Caption = 'Verify text' + Checked = True + State = cbChecked + TabOrder = 3 + OnClick = cbVerifyClick + end + object cbRadioButtons: TCheckBox + Left = 19 + Top = 187 + Width = 89 + Height = 17 + Caption = 'Radio buttons' + Checked = True + State = cbChecked + TabOrder = 4 + OnClick = cbRadioButtonsClick + end + object edCustomButtons: TEdit + Left = 128 + Top = 261 + Width = 378 + Height = 21 + TabOrder = 5 + Text = '"Custom 1" "Custom 2"' + end + object memoRadiobuttons: TMemo + Left = 128 + Top = 185 + Width = 377 + Height = 45 + Lines.Strings = ( + 'Radio Button 1' + 'Radio Button 2' + 'Radio Button 3') + TabOrder = 6 + end + object cbCustom: TCheckBox + Left = 19 + Top = 263 + Width = 89 + Height = 17 + Caption = 'Custom Buttons' + Checked = True + State = cbChecked + TabOrder = 7 + OnClick = cbCustomClick + end + object edVerifyText: TEdit + Left = 127 + Top = 299 + Width = 377 + Height = 21 + TabOrder = 8 + Text = 'Check box if you can read :)' + end + object cbCaption: TCheckBox + Left = 19 + Top = 23 + Width = 89 + Height = 17 + Caption = 'Caption' + Checked = True + State = cbChecked + TabOrder = 9 + OnClick = cbCaptionClick + end + object edCaption: TEdit + Left = 129 + Top = 21 + Width = 378 + Height = 21 + Hint = 'Text for the Windows dialog box caption.' + TabOrder = 10 + Text = 'Test of AdvTaskDialog' + end + object MemoFooter: TMemo + Left = 127 + Top = 323 + Width = 378 + Height = 35 + Lines.Strings = ( + 'Sample Footer message' + 'For example: If you do this you will loose all unsaved changes!') + TabOrder = 11 + end + object cbInstruction: TCheckBox + Left = 19 + Top = 46 + Width = 83 + Height = 17 + Caption = 'Instruction' + Checked = True + State = cbChecked + TabOrder = 12 + OnClick = cbInstructionClick + end + object MemoInstruction: TMemo + Left = 128 + Top = 48 + Width = 377 + Height = 33 + Lines.Strings = ( + 'This is the bold blue main instruction and' + 'can be mulitple lines.') + TabOrder = 13 + end + object cbContent: TCheckBox + Left = 19 + Top = 86 + Width = 64 + Height = 17 + Caption = 'Content' + Checked = True + State = cbChecked + TabOrder = 14 + OnClick = cbContentClick + end + object MemoContent: TMemo + Left = 128 + Top = 87 + Width = 377 + Height = 32 + Lines.Strings = ( + 'This is the normal "content" of the dialog.' + ' Notice it'#39's in relatively small print.') + TabOrder = 15 + end + object cbBtnOK: TCheckBox + Left = 129 + Top = 240 + Width = 50 + Height = 10 + Caption = 'cbOK' + Checked = True + State = cbChecked + TabOrder = 16 + end + object cbBtnNo: TCheckBox + Left = 246 + Top = 240 + Width = 50 + Height = 10 + Caption = 'cbNo' + TabOrder = 17 + end + object cbBtnCancel: TCheckBox + Left = 366 + Top = 240 + Width = 66 + Height = 10 + Caption = 'cbCancel' + TabOrder = 18 + end + object cbBtnClose: TCheckBox + Left = 442 + Top = 240 + Width = 62 + Height = 10 + Caption = 'cbClose' + TabOrder = 19 + end + object cbBtnRetry: TCheckBox + Left = 304 + Top = 240 + Width = 60 + Height = 10 + Caption = 'cbRetry' + TabOrder = 20 + end + object cbBtnYes: TCheckBox + Left = 182 + Top = 240 + Width = 55 + Height = 10 + Caption = 'cbYes' + TabOrder = 21 + end + object MemoExpand: TMemo + Left = 128 + Top = 125 + Width = 376 + Height = 33 + Lines.Strings = ( + 'This is for extended details that are initiall hidden' + 'unless user clicks the "view more" button.') + TabOrder = 22 + end + object edExpand: TEdit + Left = 127 + Top = 161 + Width = 121 + Height = 21 + TabOrder = 23 + Text = 'More Detail' + end + object edCollapse: TEdit + Left = 384 + Top = 161 + Width = 121 + Height = 21 + TabOrder = 24 + Text = 'Less Detail' + end + object spnDefButton: TSpinEdit + Left = 127 + Top = 364 + Width = 46 + Height = 22 + MaxValue = 0 + MinValue = 0 + TabOrder = 25 + Value = 0 + end +end diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Demo/fmMain.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/fmMain.pas new file mode 100644 index 0000000..440d6e9 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Demo/fmMain.pas @@ -0,0 +1,293 @@ +unit fmMain; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, TaskDialog, StdCtrls, Spin; + +type + TMainForm = class(TForm) + Button1: TButton; + cbFooter: TCheckBox; + cbExpanded: TCheckBox; + cbVerify: TCheckBox; + cbRadioButtons: TCheckBox; + cbBtnOK: TCheckBox; + cbBtnYes: TCheckBox; + cbBtnNo: TCheckBox; + cbBtnCancel: TCheckBox; + cbBtnRetry: TCheckBox; + cbBtnClose: TCheckBox; + edCustomButtons: TEdit; + Label1: TLabel; + Label3: TLabel; + memoRadiobuttons: TMemo; + cbCustom: TCheckBox; + edVerifyText: TEdit; + cbCaption: TCheckBox; + edCaption: TEdit; + MemoFooter: TMemo; + cbInstruction: TCheckBox; + MemoInstruction: TMemo; + cbContent: TCheckBox; + MemoContent: TMemo; + Label2: TLabel; + MemoExpand: TMemo; + edExpand: TEdit; + edCollapse: TEdit; + Label4: TLabel; + Label5: TLabel; + Label6: TLabel; + spnDefButton: TSpinEdit; + procedure Button1Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure specialButtonClick(sender: tObject; buttonid: integer); + procedure cbCaptionClick(Sender: TObject); + procedure cbRadioButtonsClick(Sender: TObject); + procedure cbCustomClick(Sender: TObject); + procedure cbVerifyClick(Sender: TObject); + procedure cbFooterClick(Sender: TObject); + procedure cbInstructionClick(Sender: TObject); + procedure cbContentClick(Sender: TObject); + procedure cbExpandedClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MainForm: TMainForm; + +implementation + +{$R *.dfm} + +procedure tmsShowmessage(const Title,Instruction,content: string; icon: tTaskDialogIcon); +var + td: tAdvTaskDialog; +begin + td := tAdvTaskDialog.Create(application); + td.Title := title; + td.Instruction := Instruction; + td.Content := Content; + td.icon := icon; + td.Execute; + td.Free; +end {ShowmessageEx}; + +procedure TMainForm.Button1Click(Sender: TObject); +var + td : tAdvTaskDialog; + msg: string; + ButtonChecked: integer; // custom button number checked + lab: string; + txt: string; + i: Integer; + inQuote: boolean; + resname: string; +begin + // + td := tAdvTaskDialog.Create(self); + td.Clear; + td.DialogPosition := dpOwnerFormCenter; + + // Dialog box Caption or Title + if cbCaption.checked then + td.Title := edCaption.text; + + // Main Instruction field + if cbInstruction.checked then + begin + // Note this field will not transform \n to #13#10 + td.Instruction := memoInstruction.lines.text; + end; + + // Content -- relatively small black text + if cbContent.checked then + td.Content := MemoContent.lines.text; + + // Radio buttons optional + if cbradioButtons.checked then + begin + td.RadioButtons.Add('Button 1'); + td.RadioButtons.Add('Button 2'); +// for i := 0 to MemoRadioButtons.Lines.count - 1 do +// td.RadioButtons.Add(MemoRadioButtons.Lines[i]); + td.DefaultRadioButton := -1; + end; + // verification checkbox: probably most used for 'Do Not Show again' + if cbVerify.checked then + td.VerificationText := edVerifytext.Text; + + // Expansiion text + if cbExpanded.checked then + td.ExpandedText := memoExpand.lines.text; + // these don't show if expandedtext is blank + td.ExpandControlText := edCollapse.text; + td.CollapsControlText := edExpand.Text; + + // Programmer defined Custom Buttons + if cbCustom.Checked and (length(edCustombuttons.text) > 0) then + begin + td.CommonButtons := []; + txt := edCustomButtons.text; + if length(txt) > 0 then + begin + lab := ''; + inquote := false; + for i := 1 to length(txt) do + begin + if txt[i] = '"' then + inQuote := not Inquote; + if ((txt[i] = ' ') and (not inQuote)) or (i = length(txt)) then + begin // have end of a button + if (i = length(txt)) and (txt[i] <> ' ') then + lab := lab + txt[i]; + if length(lab) > 0 then + td.CustomButtons.add(lab); + lab := ''; + end else if txt[i] <> '"' then + lab := lab + txt[i]; + end; + end; + end; + // Common buttons To be shown + if cbBtnOK.checked then + td.CommonButtons := td.CommonButtons + [cbOK]; + if cbBtnYes.checked then + td.CommonButtons := td.CommonButtons + [cbYes]; + if cbBtnNo.checked then + td.CommonButtons := td.CommonButtons + [cbNo]; + if cbBtnCancel.checked then + td.CommonButtons := td.CommonButtons + [cbCancel]; + if cbBtnRetry.checked then + td.CommonButtons := td.CommonButtons + [cbRetry]; + if cbBtnClose.checked then + td.CommonButtons := td.CommonButtons + [cbClose]; + + if spnDefButton.Value <> 0 then + td.DefaultButton := spnDefButton.Value; + + // Footer message + if cbFooter.checked then + begin + msg := ''; + for i := 0 to MemoFooter.Lines.count - 1 do + msg := msg +memoFooter.lines[i]+ '\n'; + setlength(msg,length(msg)-2); + td.Footer := msg; + end; + + td.Icon := tiWarning; + td.FooterIcon := tfiError; + + ButtonChecked := td.Execute; + + msg := ''; + if cbRadioButtons.checked then + msg := 'Radio Button #'+IntToStr(td.RadioButtonResult-199)+' was selected.'+#13#10; + if buttonChecked < 100 then + begin // it's a standard button + case ButtonChecked of + id_OK: resname := 'cbOK'; + id_YES: resname := 'cbYES'; + id_NO: resname := 'cbNO'; + id_CANCEL: resname := 'cbCANCEL'; + id_RETRY: resname := 'cbRETRY'; + id_ABORT: resname := 'cbCLOSE'; + else + resname := 'UNKNOWN'; + end; + end else begin + resName := td.CustomButtons[ButtonChecked-100]; + end; + msg := msg +'<'+resname+'> Button (#'+IntToStr(ButtonChecked)+') was clicked.'; + if cbVerify.Checked then + begin + msg := msg + #13#10+'Verify box was '; + if not td.VerifyResult then + msg := msg +'NOT '; + msg := msg + 'checked.'; + end; + td.Free; + tmsShowmessage('TaskDialog Espoerer',msg,'',tiInformation); + +end; + +procedure TMainForm.Button3Click(Sender: TObject); +begin + tmsShowmessage('This is the Title','This is the Instruction','This is the content',tiWarning); +end; + +procedure TMainForm.cbCaptionClick(Sender: TObject); +begin + edCaption.Enabled := (sender as tCheckbox).checked; + if edCaption.Enabled and (edCaption.Text = '') then + edCaption.text := 'Test of AdvTaskDialog'; +end; + +procedure TMainForm.cbContentClick(Sender: TObject); +begin + MemoContent.Enabled := (sender as tCheckbox).checked; + if MemoContent.Enabled and (MemoContent.lines.count = 0) then + memoContent.lines.text := 'This is the normal "content" of the dialog.'#13#10+ + 'Notice it''s in relatively small print.'; +end; + +procedure TMainForm.cbCustomClick(Sender: TObject); +begin + edCustomButtons.Enabled := (sender as tCheckbox).checked; + if edCustomButtons.enabled and (edCustomButtons.Text = '') then + edCustomButtons.text := '"Custom 1" "Custom 2"'; +end; + +procedure TMainForm.cbExpandedClick(Sender: TObject); +begin + MemoExpand.enabled := (sender as tCheckbox).checked; +end; + +procedure TMainForm.cbFooterClick(Sender: TObject); +begin + MemoFooter.Enabled := (sender as tcheckbox).checked; + if MemoFooter.Enabled and (MemoFooter.Lines.count = 0) then + memoFooter.Lines.Text := 'Sample footer Message'#13#10+ + 'For Example: If you do this you will loose all unsaved changes.'; +end; + +procedure TMainForm.cbInstructionClick(Sender: TObject); +begin + MemoInstruction.Enabled := (sender as tCheckbox).Checked; + if MemoInstruction.Enabled and (memoInstruction.lines.count = 0) then + MemoInstruction.Lines.text := 'This is the bold blue main instruction and'#1310+ + 'can be mulitple lines.'; +end; + +procedure TMainForm.cbRadioButtonsClick(Sender: TObject); +begin + memoRadioButtons.Enabled := (sender as tCheckbox).checked; + if memoradioButtons.Enabled and (memoRadioButtons.lines.count = 0) then + begin + memoRadioButtons.Lines.Add('Test Radio Button #1'); + memoRadioButtons.Lines.Add('Test Radio button #2'); + MemoRadioButtons.Lines.Add('Test Radio Button #3'); + end; +end; + +procedure TMainForm.cbVerifyClick(Sender: TObject); +begin + edVerifyText.enabled := (sender as tCheckbox).Checked; + if edverifyText.Enabled and (edVerifyText.Text = '') then + edVerifyText.text := 'Check Box if you can read :)'; +end; + +procedure TMainForm.specialButtonClick(sender: tObject; buttonid: integer); +var + td: tAdvTaskDialog; +begin + td := sender as tAdvTaskDialog; + td.tag := buttonid; +end; + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGDIP.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGDIP.dcu new file mode 100644 index 0000000..5a42a59 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGDIP.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGlowButton.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGlowButton.dcu new file mode 100644 index 0000000..1da9ac8 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGlowButton.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGroupBox.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGroupBox.dcu new file mode 100644 index 0000000..d37d030 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvGroupBox.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvHintInfo.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvHintInfo.dcu new file mode 100644 index 0000000..405bf38 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvHintInfo.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvOfficeButtons.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvOfficeButtons.dcu new file mode 100644 index 0000000..9eb6131 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvOfficeButtons.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvStyleIF.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvStyleIF.dcu new file mode 100644 index 0000000..334e69e Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/AdvStyleIF.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/GDIPicture.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/GDIPicture.dcu new file mode 100644 index 0000000..65d7e2b Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/GDIPicture.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/PictureContainer.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/PictureContainer.dcu new file mode 100644 index 0000000..e131d53 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/PictureContainer.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialog.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialog.dcu new file mode 100644 index 0000000..55a132e Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialog.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogDE.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogDE.dcu new file mode 100644 index 0000000..df50021 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogDE.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogEx.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogEx.dcu new file mode 100644 index 0000000..3d23f88 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogEx.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.bpl b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.bpl new file mode 100644 index 0000000..b057518 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.bpl differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.dcp b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.dcp new file mode 100644 index 0000000..7b1e7c4 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.dcp differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.dcu new file mode 100644 index 0000000..c85646f Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogPkgD2007.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogRegDE.dcu b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogRegDE.dcu new file mode 100644 index 0000000..794b759 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Lib/D11/TaskDialogRegDE.dcu differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvGroupBox.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvGroupBox.pas new file mode 100644 index 0000000..22174d8 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvGroupBox.pas @@ -0,0 +1,661 @@ +{***************************************************************************} +{ TAdvGroupBox component } +{ for Delphi & C++Builder } +{ version 1.0 } +{ } +{ written by TMS Software } +{ copyright © 2007 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit AdvGroupBox; + +{$I TMSDEFS.INC} + +interface + +uses + Classes, Windows, Forms, Dialogs, Controls, Graphics, Messages, ExtCtrls, + SysUtils, Math, StdCtrls, ImgList; + +const + + MAJ_VER = 1; // Major version nr. + MIN_VER = 0; // Minor version nr. + REL_VER = 0; // Release nr. + BLD_VER = 0; // Build nr. + + +type + TCaptionPosition = (cpTopLeft, cpTopRight, cpTopCenter, cpBottomLeft, cpBottomRight, cpBottomCenter); + TBorderStyle = (bsNone, bsSingle, bsDouble); + + TWinCtrl = class(TWinControl) + public + procedure PaintCtrls(DC: HDC; First: TControl); + end; + + TAdvCustomGroupBox = class(TCustomGroupBox) + private + FTransparent: Boolean; + FBorderColor: TColor; + FImageIndex: Integer; + FImages: TCustomImageList; + FBorderStyle: TBorderStyle; + FCaptionPosition: TCaptionPosition; + FRoundEdges: Boolean; + Procedure WMEraseBkGnd( Var msg: TWMEraseBkGnd ); message WM_ERASEBKGND; + procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED; + procedure SetTransparent(const Value: Boolean); + procedure SetBorderColor(const Value: TColor); + procedure SetImageIndex(const Value: Integer); + procedure SetImages(const Value: TCustomImageList); + function GetVersion: string; + procedure SetVersion(const Value: string); + procedure SetBorderStyle(const Value: TBorderStyle); + procedure SetCaptionPosition(const Value: TCaptionPosition); + procedure SetRoundEdges(const Value: Boolean); + protected + procedure Loaded; override; + procedure Paint; override; + procedure Notification(AComponent: TComponent; AOperation: TOperation); override; + procedure AdjustClientRect(var Rect: TRect); override; + procedure CreateParams(var Params: TCreateParams); override; + function GetCaptionHeight: Integer; + function GetCaptionRect: TRect; + function GetBorderWidth: Integer; + function GetBorderRect: TRect; + + property CaptionPosition: TCaptionPosition read FCaptionPosition write SetCaptionPosition default cpTopLeft; + property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; + property Transparent: Boolean read FTransparent write SetTransparent default true; + property BorderColor: TColor read FBorderColor write SetBorderColor default clSilver; + property Images: TCustomImageList read FImages write SetImages; + property ImageIndex: Integer read FImageIndex write SetImageIndex default -1; + property Version: string read GetVersion write SetVersion stored false; + property RoundEdges: Boolean read FRoundEdges write SetRoundEdges default False; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function GetVersionNr: integer; + end; + + TAdvGroupBox = class(TAdvCustomGroupBox) + published + property BorderColor; + property BorderStyle; + property CaptionPosition; + property Images; + property ImageIndex; + property Transparent; + property RoundEdges; + property Version; + + property Align; + property Anchors; + property BiDiMode; + property Caption; + property Color; + property Constraints; + property Ctl3D default False; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + {$IFDEF DELPHI7_LVL} + property ParentBackground default True; + {$ENDIF} + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D default False; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDockDrop; + property OnDockOver; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +implementation + +//------------------------------------------------------------------------------ + +{TWinCtrl} + +procedure TWinCtrl.PaintCtrls(DC: HDC; First: TControl); +begin + PaintControls(DC, First); +end; + +//------------------------------------------------------------------------------ + +{ TAdvCustomGroupBox } + +constructor TAdvCustomGroupBox.Create(AOwner: TComponent); +begin + inherited; + ControlStyle := ControlStyle - [csOpaque]; + FTransparent := True; + FImages := nil; + FImageIndex := -1; + FBorderStyle := bsSingle; + FCaptionPosition := cpTopLeft; + FRoundEdges := false; + Ctl3D := false; + ParentCtl3D := false; + FBorderColor := clSilver; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams( params ); + //params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT; +end; + +//------------------------------------------------------------------------------ + +destructor TAdvCustomGroupBox.Destroy; +begin + + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.Loaded; +begin + inherited; + +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.Notification(AComponent: TComponent; + AOperation: TOperation); +begin + inherited; + if not (csDestroying in ComponentState) and (AOperation = opRemove) then + begin + if (AComponent = Images) then + begin + Images := nil; + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.AdjustClientRect(var Rect: TRect); +var + R: TRect; +begin + R := Rect; + inherited AdjustClientRect(Rect); + Rect := R; + if CaptionPosition in [cpTopLeft, cpTopCenter, cpTopRight] then + begin + Inc(Rect.Top, Max(GetBorderWidth,GetCaptionHeight)); + Rect := Classes.Rect(Rect.Left +GetBorderWidth, Rect.Top, Rect.Right -GetBorderWidth, Rect.Bottom-GetBorderWidth); + end + else if CaptionPosition in [cpBottomLeft, cpBottomCenter, cpBottomRight] then + begin + Dec(Rect.Bottom, Max(GetBorderWidth,GetCaptionHeight)); + Rect := Classes.Rect(Rect.Left +GetBorderWidth, Rect.Top + GetBorderWidth, Rect.Right -GetBorderWidth, Rect.Bottom); + end; + + InflateRect(Rect, -1, -1); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.Paint; +var + R, CapR: TRect; + i, rt: Integer; + P: TPoint; + bmp: TBitmap; +begin + if Transparent then + begin + i := SaveDC(Canvas.Handle); + p := ClientOrigin; + Windows.ScreenToClient(Parent.Handle, p); + p.x := -p.x; + p.y := -p.y; + MoveWindowOrg(Canvas.Handle, p.x, p.y); + + SendMessage(Parent.Handle, WM_ERASEBKGND, Canvas.Handle, 0); + // transparency ? + SendMessage(Parent.Handle, WM_PAINT, Canvas.Handle, 0); + + if (Parent is TWinCtrl) then + (Parent as TWinCtrl).PaintCtrls(Canvas.Handle, nil); + + RestoreDC(Canvas.Handle, i); + end; + + R := ClientRect; + CapR := GetCaptionRect; + bmp := TBitmap.Create; + bmp.Height := (CapR.Bottom - CapR.Top); + bmp.Width := (CapR.Right - CapR.Left) + 2; + i := CapR.Left; + rt := 6; + + //--- Draw Image + if Assigned(Images) and (ImageIndex >= 0) then + begin + Images.Draw(Canvas, CapR.Left, CapR.Top, ImageIndex, Enabled); + i := CapR.Left + Images.Width + 3; + end; + + Canvas.Brush.Style := bsClear; + //--- Draw Caption + if (Caption <> '') then + begin + Canvas.Font.Assign(Self.Font); + R := Rect(i, CapR.Top, CapR.Right, CapR.Bottom); + DrawText(Canvas.Handle,PChar(Caption),Length(Caption), R, DT_SINGLELINE or DT_LEFT or DT_VCENTER); + end; + + bmp.Canvas.CopyRect(Rect(0, 0, bmp.Width, bmp.Height), Canvas, Rect(CapR.Left-1, CapR.Top, CapR.Right+1, CapR.Bottom)); + R := GetBorderRect; + //--- Draw Borders + case BorderStyle of + bsSingle: + begin + if Ctl3D then + begin + Canvas.Brush.Style := bsClear; + Canvas.Pen.Color := clWhite; + R.Left := R.Left + 1; + R.Top := R.Top + 1; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + Canvas.Pen.Color := clGray; + R.Bottom := R.Bottom -1; + R.Right := R.Right - 1; + R.Left := R.Left - 1; + R.Top := R.Top - 1; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + end + else + begin + Canvas.Brush.Style := bsClear; + Canvas.Pen.Color := BorderColor; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + end; + end; + bsDouble: + begin + if Ctl3D then + begin + Canvas.Brush.Style := bsClear; + Canvas.Pen.Color := clWhite; + R.Left := R.Left + 1; + R.Top := R.Top + 1; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + Canvas.Pen.Color := clGray; + R.Bottom := R.Bottom -1; + R.Right := R.Right - 1; + R.Left := R.Left - 1; + R.Top := R.Top - 1; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + + R.Bottom := R.Bottom +1; + R.Right := R.Right + 1; + + R := Rect(R.Left+2, R.Top+2, R.Right-2, R.Bottom-2); + + Canvas.Pen.Color := clWhite; + R.Left := R.Left + 1; + R.Top := R.Top + 1; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + Canvas.Pen.Color := clGray; + R.Bottom := R.Bottom -1; + R.Right := R.Right - 1; + R.Left := R.Left - 1; + R.Top := R.Top - 1; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + end + else + begin + Canvas.Brush.Style := bsClear; + Canvas.Pen.Color := BorderColor; + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + R := Rect(R.Left+2, R.Top+2, R.Right-2, R.Bottom-2); + if FRoundEdges then + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt) + else + Canvas.Rectangle(R); + end; + end; + end; + + if ((Caption <> '') or (Assigned(Images) and (ImageIndex >= 0))) then + begin + Canvas.CopyRect(Rect(CapR.Left-1, CapR.Top, CapR.Right+1, CapR.Bottom), bmp.Canvas, Rect(0, 0, bmp.Width, bmp.Height)); + end; + bmp.Free; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetBorderColor(const Value: TColor); +begin + if (FBorderColor <> Value) then + begin + FBorderColor := Value; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetImageIndex(const Value: Integer); +begin + if (FImageIndex <> Value) then + begin + FImageIndex := Value; + Invalidate; + Realign; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetImages(const Value: TCustomImageList); +begin + if (FImages <> Value) then + begin + FImages := Value; + if not Assigned(FImages) then + begin + ImageIndex := -1; + end; + Invalidate; + Realign; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetTransparent(const Value: Boolean); +begin + if (FTransparent <> Value) then + begin + FTransparent := Value; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.WMEraseBkGnd(var msg: TWMEraseBkGnd); +begin + inherited; + //SetBkMode( msg.DC, TRANSPARENT ); + //msg.result := 1; +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGroupBox.GetVersion: string; +var + vn: Integer; +begin + vn := GetVersionNr; + Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn))); +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGroupBox.GetVersionNr: integer; +begin + Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER)); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetVersion(const Value: string); +begin + +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGroupBox.GetCaptionHeight: Integer; +var + R: TRect; +begin + R := GetCaptionRect; + Result := Max(GetBorderWidth, R.Bottom - R.Top); +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGroupBox.GetBorderWidth: Integer; +begin + Result := 0; + case BorderStyle of + bsNone: Result := 1; + bsSingle: + begin + Result := 1; + if Ctl3D then + Result := Result + 1; + end; + bsDouble: + begin + Result := 2; + if Ctl3D then + Result := Result + 2; + end; + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGroupBox.GetBorderRect: TRect; +begin + Result := ClientRect; + if CaptionPosition in [cpTopLeft, cpTopCenter, cpTopRight] then + begin + Result.Top := Result.Top + (GetCaptionHeight div 2); + end + else if CaptionPosition in [cpBottomLeft, cpBottomCenter, cpBottomRight] then + begin + if ((Caption <> '') or (Assigned(Images) and (ImageIndex >= 0))) then + begin + Result.Bottom := Result.Bottom - (GetCaptionHeight div 2); + if (BorderStyle = bsDouble) then + Result.Bottom := Result.Bottom + 1; + end; + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGroupBox.GetCaptionRect: TRect; +var + ImgH, ImgW, CapH, CapW, sp, st, w, h: Integer; + R: TRect; +begin + Result := Rect(0, 0, 0, 0); + ImgH := 0; + ImgW := 0; + CapH := 0; + CapW := 0; + st := 8; + sp := 0; + if (Caption <> '') then + begin + Canvas.Font.Assign(Self.Font); + R := Rect(0, 0, 1000, 100); + DrawText(Canvas.Handle,PChar(Caption),Length(Caption), R, DT_CALCRECT or DT_LEFT or DT_SINGLELINE); + CapH := R.Bottom - R.Top; + CapW := R.Right - R.Left; + end; + + if Assigned(Images) and (ImageIndex >= 0) then + begin + ImgH := Images.Height; + ImgW := Images.Width; + end; + + if (CapW > 0) and (ImgW > 0) then + begin + sp := 3; + end; + + w := ImgW + sp + CapW; + h := Max(ImgH, CapH) + 2; + case CaptionPosition of + cpTopLeft: + begin + Result.Left := st; + Result.Right := Result.Left + w; + Result.Bottom := Result.Top + h; + end; + cpTopRight: + begin + Result.Right := Width - st; + Result.Left := Result.Right - w; + Result.Bottom := Result.Top + h; + end; + cpTopCenter: + begin + Result.Left := (Width - w) div 2; + Result.Right := Result.Left + w; + Result.Bottom := Result.Top + h; + end; + cpBottomLeft: + begin + Result.Left := st; + Result.Right := Result.Left + w; + Result.Top := Height - h; + Result.Bottom := Result.Top + h; + end; + cpBottomRight: + begin + Result.Right := Width - st; + Result.Left := Result.Right - w; + Result.Top := Height - h; + Result.Bottom := Result.Top + h; + end; + cpBottomCenter: + begin + Result.Left := (Width - w) div 2; + Result.Right := Result.Left + w; + Result.Top := Height - h; + Result.Bottom := Result.Top + h; + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.CMCtl3DChanged(var Message: TMessage); +begin + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetBorderStyle(const Value: TBorderStyle); +begin + if (FBorderStyle <> Value) then + begin + FBorderStyle := Value; + Invalidate; + Realign; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetCaptionPosition( + const Value: TCaptionPosition); +begin + if (FCaptionPosition <> Value) then + begin + FCaptionPosition := Value; + Invalidate; + Realign; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGroupBox.SetRoundEdges(const Value: Boolean); +begin + if (FRoundEdges <> Value) then + begin + FRoundEdges := Value; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +{$IFDEF FREEWARE} +{$I TRIAL.INC} +{$ENDIF} + + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvOfficeButtons.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvOfficeButtons.pas new file mode 100644 index 0000000..4736673 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvOfficeButtons.pas @@ -0,0 +1,2698 @@ +{*************************************************************************} +{ TAdvOfficeButtons components } +{ for Delphi & C++Builder } +{ } +{ written by } +{ TMS Software } +{ copyright © 2007 - 2008 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{*************************************************************************} + +unit AdvOfficeButtons; + +{$I TMSDEFS.INC} +{$R AdvOfficeButtons.res} +{$DEFINE REMOVESTRIP} +{$DEFINE REMOVEDRAW} + +interface + +uses + SysUtils, Windows, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, + Forms, Dialogs, StdCtrls, Menus, Buttons, ComObj, ActiveX, + PictureContainer, AdvGroupBox; + +const + MAJ_VER = 1; // Major version nr. + MIN_VER = 1; // Minor version nr. + REL_VER = 0; // Release nr. + BLD_VER = 8; // Build nr. + + // version history + // 1.0.0.1 : Fixed compatibility issue with TRadioGroup of TAdvOfficeRadioGroup + // 1.0.1.0 : Improved : exposed Visible property in TAdvOfficeRadioButton + // 1.0.2.0 : New : Added OnEnter, OnExit events in TAdvOfficeRadioButton, TAdvOfficeCheckBox + // 1.0.3.0 : Improved : painting hot state of controls + // 1.1.0.0 : New property Value added in AdvOfficeCheckGroup + // : New component TDBAdvOfficeCheckGroup added + // 1.1.0.1 : Improved : painting of focus rectangle + // 1.1.0.2 : Fixed : issue with ImageIndex for caption + // 1.1.0.3 : Fixed : issue with arrow keys & TAdvOfficeRadioGroup + // 1.1.0.4 : Fixed : issue with dbl click & mouseup handling + // 1.1.0.5 : Fixed : small painting issue with ClearType fonts + // 1.1.0.6 : Fixed : issue with runtime creating controls + // 1.1.0.7 : Fixed : issue with setting separate radiobuttons in group as disabled + // 1.1.0.8 : Fixed : issue with OnClick event for TAdvOfficeRadioGroup + +type + TAnchorClick = procedure (Sender:TObject; Anchor:string) of object; + + TCustomAdvOfficeCheckBox = class(TCustomControl) + private + FDown:Boolean; + FState:TCheckBoxState; + FFocused:Boolean; + FReturnIsTab:Boolean; + FImages:TImageList; + FAnchor: string; + FAnchorClick: TAnchorClick; + FAnchorEnter: TAnchorClick; + FAnchorExit: TAnchorClick; + FURLColor: TColor; + FImageCache: THTMLPictureCache; + FBtnVAlign: TTextLayout; + FAlignment: TLeftRight; + FEllipsis: Boolean; + FCaption: string; + FContainer: TPictureContainer; + FShadowOffset: Integer; + FShadowColor: TColor; + FIsWinXP: Boolean; + FHot: Boolean; + FClicksDisabled: Boolean; + FOldCursor: TCursor; + FReadOnly: Boolean; + {$IFNDEF TMSDOTNET} + FBkgBmp: TBitmap; + FBkgCache: boolean; + FTransparentCaching: boolean; + {$ENDIF} + FDrawBkg: boolean; + FGotClick: boolean; + procedure WMEraseBkGnd(var Message:TMessage); message WM_ERASEBKGND; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure SetState(Value:TCheckBoxState); + procedure SetChecked(Value:Boolean); + function GetChecked:Boolean; + procedure SetCaption(Value: string); + procedure SetImages(const Value: TImageList); + procedure SetURLColor(const Value:TColor); + function IsAnchor(x,y:integer):string; + procedure SetButtonVertAlign(const Value: TTextLayout); + procedure SetAlignment(const Value: TLeftRight); + procedure SetEllipsis(const Value: Boolean); + procedure SetContainer(const Value: TPictureContainer); + procedure SetShadowColor(const Value: TColor); + procedure SetShadowOffset(const Value: Integer); + function GetVersion: string; + procedure SetVersion(const Value: string); + {$IFNDEF TMSDOTNET} + procedure DrawParentImage (Control: TControl; Dest: TCanvas); + {$ENDIF} + protected + function GetVersionNr: Integer; virtual; + procedure Notification(AComponent: TComponent; AOperation: TOperation); override; + procedure DrawCheck; + procedure Paint; override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState;X, Y: Integer); override; + procedure KeyDown(var Key:Word;Shift:TShiftSTate); override; + procedure KeyUp(var Key:Word;Shift:TShiftSTate); override; + procedure SetDown(Value:Boolean); + procedure DoEnter; override; + procedure DoExit; override; + procedure Loaded; override; + property Checked: Boolean read GetChecked write SetChecked default False; + property ClicksDisabled: Boolean read FClicksDisabled write FClicksDisabled; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Toggle; virtual; + {$IFNDEF TMSDOTNET} + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + property TransparentChaching: boolean read FTransparentCaching write FTransparentCaching; + {$ENDIF} + property DrawBkg: Boolean read FDrawBkg write FDrawBkg; + published + property Action; + property Anchors; + property Constraints; + property Color; + property Alignment: TLeftRight read FAlignment write SetAlignment; + property ButtonVertAlign: TTextLayout read FBtnVAlign write setButtonVertAlign default tlTop; + property Caption: string read FCaption write SetCaption; + property Down: Boolean read FDown write SetDown default False; + property DragCursor; + property DragKind; + property DragMode; + property Ellipsis: Boolean read FEllipsis write SetEllipsis default False; + property Enabled; + property Font; + property Images: TImageList read FImages write SetImages; + property ParentFont; + property ParentColor; + property PictureContainer: TPictureContainer read FContainer write SetContainer; + property PopupMenu; + property ReadOnly: Boolean read FReadOnly write FReadOnly default False; + property ReturnIsTab: Boolean read FReturnIsTab write FReturnIsTab; + property ShadowColor: TColor read FShadowColor write SetShadowColor default clGray; + property ShadowOffset: Integer read FShadowOffset write SetShadowOffset default 1; + property ShowHint; + property State: TCheckBoxState read FState write SetState default cbUnchecked; + property TabOrder; + property TabStop; + property URLColor: TColor read FURLColor write SetURLColor default clBlue; + property Visible; + property OnClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnAnchorClick: TAnchorClick read fAnchorClick write fAnchorClick; + property OnAnchorEnter: TAnchorClick read fAnchorEnter write fAnchorEnter; + property OnAnchorExit: TAnchorClick read fAnchorExit write fAnchorExit; + property Version: string read GetVersion write SetVersion; + end; + + TAdvOfficeCheckBox = class(TCustomAdvOfficeCheckBox) + published + property Checked; + end; + + TAdvOfficeRadioButton = class(TCustomControl) + private + FDown: Boolean; + FChecked: Boolean; + FFocused: Boolean; + FGroupIndex: Byte; + FReturnIsTab: Boolean; + FImages: TImageList; + FAnchor: string; + FAnchorClick: TAnchorClick; + FAnchorEnter: TAnchorClick; + FAnchorExit: TAnchorClick; + FURLColor: TColor; + FImageCache: THTMLPictureCache; + FBtnVAlign: TTextLayout; + FAlignment: TLeftRight; + FEllipsis: Boolean; + FCaption: string; + FContainer: TPictureContainer; + FShadowOffset: Integer; + FShadowColor: TColor; + FIsWinXP: Boolean; + FHot: Boolean; + FClicksDisabled: Boolean; + FOldCursor: TCursor; + {$IFNDEF TMSDOTNET} + FBkgBmp: TBitmap; + FBkgCache: boolean; + FTransparentCaching: boolean; + {$ENDIF} + FDrawBkg: Boolean; + FGotClick: boolean; + procedure TurnSiblingsOff; + procedure SetDown(Value:Boolean); + procedure SetChecked(Value:Boolean); + procedure SetImages(const Value: TImageList); + procedure SetURLColor(const Value:TColor); + function IsAnchor(x,y:integer):string; + procedure WMLButtonDown(var Message:TWMLButtonDown); message WM_LBUTTONDOWN; + procedure WMEraseBkGnd(var Message:TMessage); message WM_ERASEBKGND; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure SetButtonVertAlign(const Value: TTextLayout); + procedure SetAlignment(const Value: TLeftRight); + procedure SetEllipsis(const Value: Boolean); + procedure SetCaption(const Value: string); + procedure SetContainer(const Value: TPictureContainer); + procedure SetShadowColor(const Value: TColor); + procedure SetShadowOffset(const Value: Integer); + function GetVersion: string; + procedure SetVersion(const Value: string); + function GetVersionNr: Integer; + {$IFNDEF TMSDOTNET} + procedure DrawParentImage (Control: TControl; Dest: TCanvas); + {$ENDIF} + protected + procedure DrawRadio; + procedure Paint; override; + procedure Notification(AComponent: TComponent; AOperation: TOperation); override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState;X, Y: Integer); override; + procedure KeyDown(var Key:Word;Shift:TShiftSTate); override; + procedure KeyUp(var Key:Word;Shift:TShiftSTate); override; + procedure DoEnter; override; + procedure DoExit; override; + procedure Loaded; override; + procedure Click; override; + procedure DoClick; virtual; + property ClicksDisabled: Boolean read FClicksDisabled write FClicksDisabled; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + {$IFNDEF TMSDOTNET} + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + property TransparentChaching: boolean read FTransparentCaching write FTransparentCaching; + {$ENDIF} + property DrawBkg: Boolean read FDrawBkg write FDrawBkg; + published + {$IFDEF DELPHI4_LVL} + property Action; + property Anchors; + property Constraints; + {$ENDIF} + property Color; + property Alignment: TLeftRight read fAlignment write SetAlignment; + property URLColor:TColor read FURLColor write SetURLColor default clBlue; + property ButtonVertAlign: TTextLayout read fBtnVAlign write SetButtonVertAlign default tlTop; + property Caption: string read FCaption write SetCaption; + property Checked:Boolean read FChecked write SetChecked default False; + property Down:Boolean read FDown write SetDown default False; + property DragCursor; + {$IFDEF DELPHI4_LVL} + property DragKind; + {$ENDIF} + property DragMode; + property Ellipsis: Boolean read FEllipsis write SetEllipsis default False; + property Enabled; + property Font; + property GroupIndex:Byte read FGroupIndex write FGroupIndex + default 0; + property Images:TImageList read fImages write SetImages; + property ParentFont; + property ParentColor; + property PictureContainer: TPictureContainer read FContainer write SetContainer; + property PopupMenu; + property ReturnIsTab:Boolean read FReturnIsTab write FReturnIsTab; + property ShadowColor: TColor read FShadowColor write SetShadowColor default clGray; + property ShadowOffset: Integer read FShadowOffset write SetShadowOffset default 1; + property ShowHint; + property TabOrder; + property TabStop; + property OnClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnAnchorClick:TAnchorClick read fAnchorClick write fAnchorClick; + property OnAnchorEnter:TAnchorClick read fAnchorEnter write fAnchorEnter; + property OnAnchorExit:TAnchorClick read fAnchorExit write fAnchorExit; + property Version: string read GetVersion write SetVersion; + property Visible; + end; + + TEnabledEvent = procedure (Sender:TObject; ItemIndex: Integer; var Enabled: Boolean) of object; + + + TCustomAdvOfficeRadioGroup = class(TAdvGroupbox) + private + FButtons: TList; + FItems: TStrings; + FItemIndex: Integer; + FColumns: Integer; + FReading: Boolean; + FUpdating: Boolean; + FAlignment: TAlignment; + FBtnVAlign: TTextLayout; + FImages: TImageList; + FContainer: TPictureContainer; + FEllipsis: Boolean; + FShadowOffset: Integer; + FShadowColor: TColor; + FOnIsEnabled: TEnabledEvent; + FIsReadOnly: boolean; + procedure ArrangeButtons; + procedure ButtonClick(Sender: TObject); + procedure ItemsChange(Sender: TObject); + procedure SetButtonCount(Value: Integer); + procedure SetColumns(Value: Integer); + procedure SetItemIndex(Value: Integer); + procedure SetItems(Value: TStrings); + procedure UpdateButtons; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure WMSize(var Message: TWMSize); message WM_SIZE; + procedure SetAlignment(const Value: TAlignment); + procedure SetButtonVertAlign(const Value: TTextLayout); + procedure SetContainer(const Value: TPictureContainer); + procedure SetImages(const Value: TImageList); + procedure SetEllipsis(const Value: Boolean); + procedure SetShadowColor(const Value: TColor); + procedure SetShadowOffset(const Value: Integer); + function GetVersion: string; + procedure SetVersion(const Value: string); + protected + function GetVersionNr: Integer; virtual; + procedure Loaded; override; + procedure ReadState(Reader: TReader); override; + function CanModify: Boolean; virtual; + procedure Notification(AComponent: TComponent; AOperation: TOperation); override; + property Columns: Integer read FColumns write SetColumns default 1; + property ItemIndex: Integer read FItemIndex write SetItemIndex default -1; + property Items: TStrings read FItems write SetItems; + property IsReadOnly: boolean read FIsReadOnly write FIsReadOnly; + public + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + {$IFDEF DELPHI4_LVL} + procedure FlipChildren(AllLevels: Boolean); override; + {$ENDIF} + procedure PushKey(var Key: Char); + procedure PushKeyDown(var Key: Word; Shift: TShiftState); + published + property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; + property ButtonVertAlign: TTextLayout read fBtnVAlign write SetButtonVertAlign default tlTop; + property Ellipsis: Boolean read FEllipsis write SetEllipsis; + property Images: TImageList read FImages write SetImages; + property PictureContainer: TPictureContainer read FContainer write SetContainer; + property ShadowColor: TColor read FShadowColor write SetShadowColor default clSilver; + property ShadowOffset: Integer read FShadowOffset write SetShadowOffset default 1; + property OnIsEnabled: TEnabledEvent read FOnIsEnabled write FOnIsEnabled; + property Version: string read GetVersion write SetVersion; + end; + + TAdvOfficeRadioGroup = class(TCustomAdvOfficeRadioGroup) + private + protected + public + published + property Align; + {$IFDEF DELPHI4_LVL} + property Anchors; + property BiDiMode; + property Constraints; + property DragKind; + property ParentBiDiMode; + {$ENDIF} + property Caption; + property Color; + property Columns; + property Ctl3D; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property ItemIndex; + property Items; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + {$IFDEF DELPHI5_LVL} + property OnContextPopup; + {$ENDIF} + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + {$IFDEF DELPHI4_LVL} + property OnEndDock; + property OnStartDock; + {$ENDIF} + property OnStartDrag; + end; + + TCustomAdvOfficeCheckGroup = class(TAdvGroupBox) + private + FButtons: TList; + FItems: TStrings; + FColumns: Integer; + FReading: Boolean; + FUpdating: Boolean; + FAlignment: TAlignment; + FBtnVAlign: TTextLayout; + FImages: TImageList; + FContainer: TPictureContainer; + FEllipsis: Boolean; + FShadowOffset: Integer; + FShadowColor: TColor; + FOnIsEnabled: TEnabledEvent; + FValue: DWord; + procedure ArrangeButtons; + procedure ButtonClick(Sender: TObject); + procedure ItemsChange(Sender: TObject); + procedure SetButtonCount(Value: Integer); + procedure SetColumns(Value: Integer); + procedure SetItems(Value: TStrings); + procedure UpdateButtons; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure WMSize(var Message: TWMSize); message WM_SIZE; + procedure SetAlignment(const Value: TAlignment); + procedure SetButtonVertAlign(const Value: TTextLayout); + procedure SetContainer(const Value: TPictureContainer); + procedure SetImages(const Value: TImageList); + procedure SetEllipsis(const Value: Boolean); + procedure SetShadowColor(const Value: TColor); + procedure SetShadowOffset(const Value: Integer); + function GetChecked(Index: Integer): Boolean; + procedure SetChecked(Index: Integer; const Value: Boolean); + function GetReadOnly(Index: Integer): Boolean; + procedure SetReadOnly(Index: Integer; const Value: Boolean); + function GetVersion: string; + procedure SetVersion(const Value: string); + function GetVersionNr: Integer; + procedure SetValue(const Value: DWord); + function GetValue: DWord; + protected + procedure Loaded; override; + procedure ReadState(Reader: TReader); override; + function CanModify: Boolean; virtual; + procedure Notification(AComponent: TComponent; AOperation: TOperation); override; + procedure UpdateValue; + property Columns: Integer read FColumns write SetColumns default 1; + property Items: TStrings read FItems write SetItems; + property Value: DWord read GetValue write SetValue; + public + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + {$IFDEF DELPHI4_LVL} + procedure FlipChildren(AllLevels: Boolean); override; + {$ENDIF} + procedure PushKey(var Key: Char); + procedure PushKeyDown(var Key: Word; Shift: TShiftState); + property Checked[Index: Integer]: Boolean read GetChecked write SetChecked; + property ReadOnly[Index: Integer]: Boolean read GetReadOnly write SetReadOnly; + published + property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; + property ButtonVertAlign: TTextLayout read fBtnVAlign write SetButtonVertAlign default tlTop; + property Ellipsis: Boolean read FEllipsis write SetEllipsis; + property Images: TImageList read FImages write SetImages; + property PictureContainer: TPictureContainer read FContainer write SetContainer; + property ShadowColor: TColor read FShadowColor write SetShadowColor default clSilver; + property ShadowOffset: Integer read FShadowOffset write SetShadowOffset default 1; + property OnIsEnabled: TEnabledEvent read FOnIsEnabled write FOnIsEnabled; + property Version: string read GetVersion write SetVersion; + end; + + TAdvOfficeCheckGroup = class(TCustomAdvOfficeCheckGroup) + private + protected + public + property Value; + published + property Align; + {$IFDEF DELPHI4_LVL} + property Anchors; + property BiDiMode; + property Constraints; + property DragKind; + property ParentBiDiMode; + {$ENDIF} + property Caption; + property Color; + property Columns; + property Ctl3D; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property Items; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + {$IFDEF DELPHI5_LVL} + property OnContextPopup; + {$ENDIF} + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + {$IFDEF DELPHI4_LVL} + property OnEndDock; + property OnStartDock; + {$ENDIF} + property OnStartDrag; + end; + + + + +implementation +uses + ShellApi, CommCtrl, Math +{$IFDEF DELPHI4_LVL} + ,Imglist +{$ENDIF} + ; + +{$I HTMLENGO.PAS} + + +const + BW = 12; + +procedure PaintFocusRect(ACanvas: TCanvas; R: TRect; Clr: TColor); +var + LB: TLogBrush; + HPen, HOldPen: THandle; +begin + ACanvas.Pen.Color := Clr; + + lb.lbColor := ColorToRGB(Clr); + lb.lbStyle := bs_Solid; + + HPen := ExtCreatePen(PS_COSMETIC or PS_ALTERNATE,1, lb, 0, nil); + HOldPen := SelectObject(ACanvas.Handle, HPen); + + MoveToEx(ACanvas.Handle, R.Left, R.Top, nil); + LineTo(ACanvas.Handle, R.Right, R.Top); + + MoveToEx(ACanvas.Handle, R.Right, R.Top, nil); + LineTo(ACanvas.Handle, R.Right, R.Bottom); + + MoveToEx(ACanvas.Handle, R.Right, R.Bottom, nil); + LineTo(ACanvas.Handle, R.Left, R.Bottom); + + MoveToEx(ACanvas.Handle, R.Left, R.Top, nil); + LineTo(ACanvas.Handle, R.Left, R.Bottom); + + DeleteObject(SelectObject(ACanvas.Handle,HOldPen)); +end; + + +{$IFNDEF DELPHI4_LVL} +function Min(a,b: Integer): Integer; +begin + if a < b then + Result := a + else + Result := b; +end; +{$ENDIF} + +{$IFDEF DELPHI4_LVL} +{$IFNDEF TMSDOTNET} +function GetFileVersion(FileName:string): Integer; +var + FileHandle:dword; + l: Integer; + pvs: PVSFixedFileInfo; + lptr: uint; + querybuf: array[0..255] of char; + buf: PChar; +begin + Result := -1; + + StrPCopy(querybuf,FileName); + l := GetFileVersionInfoSize(querybuf,FileHandle); + if (l>0) then + begin + GetMem(buf,l); + GetFileVersionInfo(querybuf,FileHandle,l,buf); + if VerQueryValue(buf,'\',Pointer(pvs),lptr) then + begin + if (pvs^.dwSignature = $FEEF04BD) then + begin + Result := pvs^.dwFileVersionMS; + end; + end; + FreeMem(buf); + end; +end; +{$ENDIF} +{$ENDIF} + + +function DoThemeDrawing: Boolean; +var + VerInfo: TOSVersioninfo; + FIsWinXP,FIsComCtl6: boolean; + i: integer; +begin + {$IFDEF TMSDOTNET} + VerInfo.dwOSVersionInfoSize := Marshal.SizeOf(TypeOf(TOSVersionInfo)); + {$ENDIF} + {$IFNDEF TMSDOTNET} + VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); + {$ENDIF} + + GetVersionEx(verinfo); + + FIsWinXP := (verinfo.dwMajorVersion > 5) OR + ((verinfo.dwMajorVersion = 5) AND (verinfo.dwMinorVersion >= 1)); + + i := GetFileVersion('COMCTL32.DLL'); + i := (i shr 16) and $FF; + + FIsComCtl6 := (i > 5); + + Result := FIsComCtl6 and FIsWinXP; +end; + +{ TCustomHTMLCheckBox } + +constructor TCustomAdvOfficeCheckBox.Create(AOwner: TComponent); +var + VerInfo: TOSVersioninfo; + +begin + inherited Create(AOwner); + Width := 120; + Height := 20; + FUrlColor := clBlue; + FBtnVAlign := tlTop; + FImageCache := THTMLPictureCache.Create; + FCaption := self.ClassName; + FShadowOffset := 1; + FShadowColor := clGray; + + {$IFNDEF TMSDOTNET} + VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); + {$ENDIF} + {$IFDEF TMSDOTNET} + VerInfo.dwOSVersionInfoSize := Marshal.SizeOf(TypeOf(TOSVersionInfo)); + {$ENDIF} + + GetVersionEx(verinfo); + + FIsWinXP := (verinfo.dwMajorVersion > 5) OR + ((verinfo.dwMajorVersion = 5) AND (verinfo.dwMinorVersion >= 1)); + + ControlStyle := ControlStyle - [csClickEvents]; + FReadOnly := False; + + {$IFNDEF TMSDOTNET} + FBkgBmp := TBitmap.Create; + FBkgCache := false; + FTransparentCaching := false; + {$ENDIF} + FDrawBkg := true; +end; + +function TCustomAdvOfficeCheckBox.IsAnchor(x,y:integer):string; +var + r,hr: TRect; + XSize,YSize,HyperLinks,MouseLink: Integer; + s:string; + Anchor, Stripped, FocusAnchor:string; +begin + r := Clientrect; + s := Caption; + Anchor:=''; + + r.left := r.left + BW + 5; + r.top := r.top + 4; + + Result := ''; + + if HTMLDrawEx(Canvas,s,r,FImages,x,y,-1,-1,FShadowOffset,True,False,False,False,False,False,not FEllipsis,1.0,FURLColor, + clNone,clNone,FShadowColor,Anchor,Stripped,FocusAnchor,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0) then + Result := Anchor; +end; + +{$IFNDEF TMSDOTNET} + +procedure TCustomAdvOfficeCheckBox.DrawParentImage(Control: TControl; Dest: TCanvas); +var + SaveIndex: Integer; + DC: HDC; + Position: TPoint; +begin + with Control do + begin + if Parent = nil then + Exit; + + DC := Dest.Handle; + SaveIndex := SaveDC(DC); + GetViewportOrgEx(DC, Position); + SetViewportOrgEx(DC, Position.X - Left, Position.Y - Top, nil); + IntersectClipRect(DC, 0, 0, Parent.ClientWidth, Parent.ClientHeight); + + Parent.Perform(WM_ERASEBKGND, Integer(DC), Integer(0)); + Parent.Perform(WM_PAINT, Integer(DC), Integer(0)); + RestoreDC(DC, SaveIndex); + end; +end; + +procedure TCustomAdvOfficeCheckBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +begin + inherited; + FBkgCache := false; + Repaint; +end; +{$ENDIF} + +procedure TCustomAdvOfficeCheckBox.DrawCheck; +var + bmp: TBitmap; + BL,BT:Integer; +begin + BT := 4; + //ExtraBW := 4; + bmp := TBitmap.Create; + if state = cbChecked then + begin + if Down then + bmp.LoadFromResourceName(hinstance,'TMSOFCCD') + else + if FHot then + bmp.LoadFromResourceName(hinstance,'TMSOFCCH') + else + bmp.LoadFromResourceName(hinstance,'TMSOFCC'); + + end + else + begin + if Down then + bmp.LoadFromResourceName(hinstance,'TMSOFCUD') + else + if FHot then + bmp.LoadFromResourceName(hinstance,'TMSOFCUH') + else + bmp.LoadFromResourceName(hinstance,'TMSOFCU'); + end; + + bmp.Transparent := true; + bmp.TransparentMode := tmAuto; + + case fBtnVAlign of + tlTop: BT := 4; + tlCenter: BT := (ClientRect.Bottom - ClientRect.Top) div 2 - (bmp.Height div 2); + tlBottom: BT := ClientRect.Bottom - bmp.Height; + end; + + if fAlignment = taRightJustify then + BL := ClientRect.Right - bmp.Width - 1 + else + BL := 0; + Canvas.Draw(BL,BT,bmp); + bmp.free; +end; + +procedure TCustomAdvOfficeCheckBox.Paint; +var + R, hr: TRect; + a,s,fa,text: string; + xsize,ysize: Integer; + ExtraBW,HyperLinks,MouseLink: Integer; + +begin + Canvas.Font := Font; + + if FTransparentCaching then + begin + if FBkgCache then + begin + Canvas.Draw(0,0,FBkgBmp) + end + else + begin + FBkgBmp.Width := self.Width; + FBkgBmp.Height := self.Height; + DrawParentImage(Self, FBkgBmp.Canvas); + Canvas.Draw(0,0,FBkgBmp); + FBkgCache := true; + end; + end + else + begin + if FDrawBkg then + DrawParentImage(Self, Canvas); + end; + + with Canvas do + begin + Text := Caption; + + DrawCheck; + + ExtraBW := 4; + + R := GetClientRect; + + if FAlignment = taRightJustify then + begin + r.Left := 0; + r.Right := r.Right - BW - ExtraBW; + end + else + r.left := r.left + BW + ExtraBW; + + r.top := r.top + 4; + + if not Enabled then + begin + OffsetRect(r,1,1); + Canvas.Font.Color := clWhite; + HTMLDrawEx(Canvas,Text,R,FImages,0,0,-1,-1,FShadowOffset,False,False,False,False,False,False,not FEllipsis,1.0,clWhite, + clNone,clNone,FShadowColor,a,s,fa,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0); + + Canvas.Font.Color := clGray; + Offsetrect(r,-1,-1); + + HTMLDrawEx(Canvas,Text,R,FImages,0,0,-1,-1,FShadowOffset,False,False,False,False,False,False,not FEllipsis,1.0,clGray, + clNone,clNone,FShadowColor,a,s,fa,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0); + end + else + HTMLDrawEx(Canvas,Text,R,FImages,0,0,-1,-1,FShadowOffset,False,False,False,False,False,False,not FEllipsis,1.0,FURLColor, + clNone,clNone,FShadowColor,a,s,fa,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0); + + if FFocused then + begin + r.right := r.left + xsize + 3; + r.bottom := r.top + ysize ; + //WinProcs.DrawFocusRect(Canvas.Handle,R); + PaintFocusRect(Canvas,R,clBlack); + end; + end; +end; + +procedure TCustomAdvOfficeCheckBox.SetDown(Value:Boolean); +begin + if FDown <> Value then + begin + FDown := Value; + end; +end; + +procedure TCustomAdvOfficeCheckBox.SetState(Value:TCheckBoxState); +var + r: TRect; +begin + if FState <> Value then + begin + FState := Value; + + if HandleAllocated and HasParent then + begin + r := GetClientRect; + case Alignment of + taLeftJustify: r.Right := 20; + taRightJustify: r.Left := r.Right - 20; + end; + {$IFNDEF TMSDOTNET} + InvalidateRect(self.Handle,@r,True); + {$ENDIF} + {$IFDEF TMSDOTNET} + InvalidateRect(self.Handle,r,True); + {$ENDIF} + end; + end; +end; + +function TCustomAdvOfficeCheckBox.GetChecked: Boolean; +begin + Result := (State = cbChecked); +end; + +procedure TCustomAdvOfficeCheckBox.SetChecked(Value:Boolean); +begin + if Value then + State := cbChecked + else + State := cbUnchecked; + + Invalidate; +end; + +procedure TCustomAdvOfficeCheckBox.DoEnter; +{$IFNDEF DELPHI9_LVL} +var + R: TRect; +{$ENDIF} +begin + inherited DoEnter; + FFocused := True; + {$IFDEF DELPHI9_LVL} + Repaint; + {$ELSE} + R := ClientRect; + R.Right := 16; + InvalidateRect(self.Handle, @R, true); + {$ENDIF} +end; + + +procedure TCustomAdvOfficeCheckBox.DoExit; +var + db: boolean; +begin + inherited DoExit; + FFocused := False; + db := FDrawBkg; + FDrawBkg := true; + Repaint; + FDrawBkg := db; +end; + +procedure TCustomAdvOfficeCheckBox.MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer); +var + Anchor:string; + R: TRect; +begin + Anchor := ''; + FGotClick := true; + + if FFocused then + begin + Anchor := IsAnchor(X,Y); + + if Anchor <> '' then + begin + if (Pos('://',Anchor) > 0) or (Pos('mailto:',anchor) > 0) then + {$IFNDEF TMSDOTNET} + Shellexecute(0,'open',pchar(anchor),nil,nil,SW_NORMAL) + {$ENDIF} + {$IFDEF TMSDOTNET} + Shellexecute(0,'open',anchor,'','',SW_NORMAL) + {$ENDIF} + else + begin + if Assigned(FAnchorClick) then + FAnchorClick(self,anchor); + end; + end; + end + else + begin + if (self.CanFocus and not (csDesigning in ComponentState)) then + begin + SetFocus; + FFocused := True; + end; + end; + + if Anchor = '' then + begin + inherited MouseDown(Button, Shift, X, Y); + MouseCapture := True; + Down := True; + end; + + R := ClientRect; + R.Right := 16; + InvalidateRect(Self.Handle,@R, true); +end; + +procedure TCustomAdvOfficeCheckBox.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + R: TRect; +begin + MouseCapture := False; + + Down := False; + + if (X >= 0) and (X<=Width) and (Y>=0) and (Y<=Height) and FFocused and FGotClick then + begin + ClicksDisabled := True; + Toggle; + ClicksDisabled := False; + Click; + end; + + inherited MouseUp(Button, Shift, X, Y); + + R := ClientRect; + R.Right := 16; + InvalidateRect(Self.Handle,@R, true); + + FGotClick := false; +end; + +procedure TCustomAdvOfficeCheckBox.MouseMove(Shift: TShiftState;X, Y: Integer); +var + Anchor:string; +begin + if MouseCapture then + Down := (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height); + + if fFocused then + Anchor := IsAnchor(x,y) + else + Anchor := ''; + + if Anchor <> '' then + begin + if (self.Cursor = crDefault) or (FAnchor <> Anchor) then + begin + FAnchor := Anchor; + self.Cursor := crHandPoint; + if Assigned(FAnchorEnter) then + FAnchorEnter(self,Anchor); + end; + end + else + begin + if self.Cursor = crHandPoint then + begin + self.Cursor := FOldCursor; + if Assigned(FAnchorExit) then + FAnchorExit(self,Anchor); + end; + end; + + inherited MouseMove(Shift,X,Y); +end; + +procedure TCustomAdvOfficeCheckBox.KeyDown(var Key:Word;Shift:TShiftSTate); +begin + if (Key=vk_return) and (fReturnIsTab) then + begin + Key := vk_tab; + PostMessage(self.Handle,wm_keydown,VK_TAB,0); + end; + + if Key = vk_Space then + Down := True; + + inherited KeyDown(Key,Shift); +end; + +procedure TCustomAdvOfficeCheckBox.KeyUp(var Key:Word;Shift:TShiftSTate); +begin + if Key = vk_Space then + begin + Down := False; + Toggle; + Click; + end; +end; + + +procedure TCustomAdvOfficeCheckBox.SetImages(const Value: TImageList); +begin + FImages := Value; + Invalidate; +end; + +procedure TCustomAdvOfficeCheckBox.SetURLColor(const Value: TColor); +begin + if FURLColor <> Value then + begin + FURLColor := Value; + Invalidate; + end; +end; + +procedure TCustomAdvOfficeCheckBox.Notification(AComponent: TComponent; + AOperation: TOperation); +begin + inherited; + + if (AOperation = opRemove) and (AComponent = FImages) then + FImages:=nil; + + if (AOperation = opRemove) and (AComponent = FContainer) then + FContainer := nil; +end; + +procedure TCustomAdvOfficeCheckBox.CMEnabledChanged(var Message: TMessage); +begin + inherited; + Invalidate; +end; + +procedure TCustomAdvOfficeCheckBox.SetButtonVertAlign(const Value: TTextLayout); +begin + if Value <> FBtnVAlign then + begin + FBtnVAlign := Value; + Invalidate; + end; +end; + +procedure TCustomAdvOfficeCheckBox.SetAlignment(const Value: TLeftRight); +begin + if FAlignment <> Value then + begin + FAlignment := Value; + Invalidate; + end; +end; + +destructor TCustomAdvOfficeCheckBox.Destroy; +begin + {$IFNDEF TMSDOTNET} + FBkgBmp.Free; + {$ENDIF} + FImageCache.Free; + inherited; +end; + +procedure TCustomAdvOfficeCheckBox.SetEllipsis(const Value: Boolean); +begin + if FEllipsis <> Value then + begin + FEllipsis := Value; + Invalidate + end; +end; + +procedure TCustomAdvOfficeCheckBox.SetCaption(Value: string); +begin + {$IFNDEF TMSDOTNET} + SetWindowText(Handle,pchar(Value)); + {$ENDIF} + {$IFDEF TMSDOTNET} + SetWindowText(Handle,Value); + {$ENDIF} + FCaption := Value; + Invalidate; +end; + + +procedure TCustomAdvOfficeCheckBox.Toggle; +begin + if not FReadOnly then + Checked := not Checked; +end; + +procedure TCustomAdvOfficeCheckBox.WMEraseBkGnd(var Message: TMessage); +begin + Message.Result := 1 +end; + +procedure TCustomAdvOfficeCheckBox.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + begin + if IsAccel(CharCode, FCaption) and CanFocus then + begin + Toggle; + if Assigned(OnClick) then + OnClick(Self); + if TabStop then + if (self.CanFocus and not (csDesigning in ComponentState)) then + SetFocus; + Result := 1; + end + else + inherited; + end; +end; + +procedure TCustomAdvOfficeCheckBox.SetContainer(const Value: TPictureContainer); +begin + FContainer := Value; + Invalidate; +end; + +procedure TCustomAdvOfficeCheckBox.SetShadowColor(const Value: TColor); +begin + if FShadowColor <> Value then + begin + FShadowColor := Value; + Invalidate; + end; +end; + +procedure TCustomAdvOfficeCheckBox.SetShadowOffset(const Value: Integer); +begin + if FShadowOffset <> Value then + begin + FShadowOffset := Value; + Invalidate; + end; +end; + +procedure TCustomAdvOfficeCheckBox.CMMouseEnter(var Message: TMessage); +begin + FHot := True; + DrawCheck; + inherited; +end; + +procedure TCustomAdvOfficeCheckBox.CMMouseLeave(var Message: TMessage); +begin + FHot := False; + DrawCheck; + inherited; +end; + +procedure TCustomAdvOfficeCheckBox.Loaded; +begin + inherited; + FOldCursor := Cursor; +end; + +function TCustomAdvOfficeCheckBox.GetVersion: string; +var + vn: Integer; +begin + vn := GetVersionNr; + Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn))); +end; + +function TCustomAdvOfficeCheckBox.GetVersionNr: Integer; +begin + Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER)); +end; + +procedure TCustomAdvOfficeCheckBox.SetVersion(const Value: string); +begin + +end; + +{ THTMLRadioButton } + +constructor TAdvOfficeRadioButton.Create(AOwner: TComponent); +var + VerInfo: TOSVersionInfo; + +begin + inherited Create(AOwner); + Width := 135; + Height := 20; + FURLColor := clBlue; + FBtnVAlign := tlTop; + FImageCache := THTMLPictureCache.Create; + FCaption := self.ClassName; + FShadowOffset := 1; + FShadowColor := clGray; + {$IFNDEF TMSDOTNET} + VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); + {$ENDIF} + {$IFDEF TMSDOTNET} + VerInfo.dwOSVersionInfoSize := Marshal.SizeOf(TypeOf(TOSVersionInfo)); + {$ENDIF} + GetVersionEx(verinfo); + + FIsWinXP := (verinfo.dwMajorVersion > 5) OR + ((verinfo.dwMajorVersion = 5) AND (verinfo.dwMinorVersion >= 1)); + + {$IFNDEF TMSDOTNET} + FBkgBmp := TBitmap.Create; + FBkgCache := false; + FTransparentCaching := false; + {$ENDIF} + FDrawBkg := true; +end; + +function TAdvOfficeRadioButton.IsAnchor(x,y:integer):string; +var + r,hr: TRect; + XSize,YSize,HyperLinks,MouseLink: Integer; + s: string; + Anchor,Stripped,FocusAnchor: string; +begin + r := Clientrect; + s := Caption; + Anchor := ''; + + r.left := r.left + BW + 5; + r.top := r.top + 4; + + Result := ''; + + if HTMLDrawEx(Canvas,s,r,FImages,x,y,-1,-1,FShadowOffset,True,False,False,False,False,False,not FEllipsis,1.0,FURLColor, + clNone,clNone,FShadowColor,Anchor,Stripped,FocusAnchor,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0) then + Result := Anchor; +end; + +procedure TAdvOfficeRadioButton.DrawParentImage(Control: TControl; Dest: TCanvas); +var + SaveIndex: Integer; + DC: HDC; + Position: TPoint; +begin + with Control do + begin + if Parent = nil then + Exit; + DC := Dest.Handle; + SaveIndex := SaveDC(DC); + GetViewportOrgEx(DC, Position); + SetViewportOrgEx(DC, Position.X - Left, Position.Y - Top, nil); + IntersectClipRect(DC, 0, 0, Parent.ClientWidth, Parent.ClientHeight); + Parent.Perform(WM_ERASEBKGND, Integer(DC), Integer(0)); + Parent.Perform(WM_PAINT, Integer(DC), Integer(0)); + RestoreDC(DC, SaveIndex); + end; +end; + + +procedure TAdvOfficeRadioButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +begin + inherited; + begin + FBkgCache := false; + Repaint; + end; +end; + +procedure TAdvOfficeRadioButton.DrawRadio; +var + bmp: TBitmap; + BT, BL: integer; +begin + BT := 4; + bmp := TBitmap.Create; + if (Checked) then + begin + if Down then + bmp.LoadFromResourceName(hinstance,'TMSOFRCD') + else + if FHot then + bmp.LoadFromResourceName(hinstance,'TMSOFRCH') + else + bmp.LoadFromResourceName(hinstance,'TMSOFRC'); + + end + else + begin + if Down then + bmp.LoadFromResourceName(hinstance,'TMSOFRUD') + else + if FHot then + bmp.LoadFromResourceName(hinstance,'TMSOFRUH') + else + bmp.LoadFromResourceName(hinstance,'TMSOFRU'); + end; + + bmp.Transparent:=true; + bmp.TransparentMode :=tmAuto; + + case FBtnVAlign of + tlTop: BT := 4; + tlCenter: BT := (ClientRect.Bottom-ClientRect.Top) div 2 - (bmp.Height div 2); + tlBottom: BT := ClientRect.Bottom - bmp.Height - 2; + end; + + if fAlignment = taRightJustify then + BL := ClientRect.Right - bmp.Width - 1 + else + BL := 0; + Canvas.Draw(BL,BT,bmp); + bmp.Free; +end; + +procedure TAdvOfficeRadioButton.Paint; +var + BR:Integer; + R,hr: TRect; + a,s,fa,text: string; + XSize,YSize,HyperLinks,MouseLink: Integer; + +begin + Canvas.Font := Font; + Text := Caption; + + if FTransparentCaching then + begin + if FBkgCache then + begin + Self.Canvas.Draw(0,0,FBkgBmp) + end + else + begin + FBkgBmp.Width := self.Width; + FBkgBmp.Height := self.Height; + //FBkgBmp.PixelFormat := pf32bit; + DrawParentImage(Self, FBkgBmp.Canvas); + Self.Canvas.Draw(0,0,FBkgBmp); + FBkgCache := true; + end; + end + else + begin + if DrawBkg then + DrawParentImage(Self, self.Canvas); + end; + + with Canvas do + begin + BR := 13; + DrawRadio; + + r := GetClientRect; + if FAlignment = taRightJustify then + begin + r.Left := 0; + r.Right := r.Right - BR - 5; + end + else + r.Left := r.Left + BR + 5; + + r.Top := r.Top + 4; + + if not Enabled then + begin + OffsetRect(R,1,1); + Canvas.Font.Color := clWhite; + HTMLDrawEx(Canvas,Text,R,FImages,0,0,-1,-1,FShadowOffset,False,False,False,False,False,False,not FEllipsis,1.0,clGray, + clNone,clNone,FShadowColor,a,s,fa,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0); + Canvas.Font.Color := clGray; + Offsetrect(R,-1,-1); + HTMLDrawEx(Canvas,Text,R,FImages,0,0,-1,-1,FShadowOffset,False,False,False,False,False,False,not FEllipsis,1.0,clWhite, + clNone,clNone,FShadowColor,a,s,fa,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0); + end + else + begin + Canvas.Font.Color := Font.Color; + HTMLDrawEx(Canvas,Text,R,FImages,0,0,-1,-1,FShadowOffset,False,False,False,False,False,False,not FEllipsis,1.0,FURLColor, + clNone,clNone,FShadowColor,a,s,fa,XSize,YSize,HyperLinks,MouseLink,hr,FImageCache,FContainer,0); + end; + + if FFocused then + begin + r.Right := r.Left + xsize + 3; + r.Bottom := r.Top + ysize {+ 1}; + PaintFocusRect(Canvas,R,clBlack); + end; + + end; +end; + +procedure TAdvOfficeRadioButton.SetURLColor(const Value: TColor); +begin + FURLColor := Value; + Invalidate; +end; + + +procedure TAdvOfficeRadioButton.SetDown(Value:Boolean); +begin + if FDown<>Value then + begin + FDown := Value; + end; +end; + + +procedure TAdvOfficeRadioButton.TurnSiblingsOff; +var + i:Integer; + Sibling: TAdvOfficeRadioButton; + +begin + if (Parent <> nil) then + for i:=0 to Parent.ControlCount-1 do + if Parent.Controls[i] is TAdvOfficeRadioButton then + begin + Sibling := TAdvOfficeRadioButton(Parent.Controls[i]); + if (Sibling <> Self) and + (Sibling.GroupIndex = GroupIndex) then + Sibling.SetChecked(False); + end; +end; + +procedure TAdvOfficeRadioButton.SetChecked(Value: Boolean); +var + r: TRect; +begin + if FChecked <> Value then + begin + TabStop := Value; + FChecked := Value; + if Value then + begin + TurnSiblingsOff; + //if not FClicksDisabled then + //DoClick; + end; + + if HandleAllocated and HasParent then + begin + R := ClientRect; + R.Right := 16; + InvalidateRect(self.Handle, @r, true); + end; + + // Invalidate; + end; +end; + + +procedure TAdvOfficeRadioButton.DoClick; +begin + if Assigned(OnClick) then + OnClick(Self); +end; + +procedure TAdvOfficeRadioButton.DoEnter; +{$IFNDEF DELPHI9_LVL} +var + R: TRect; +{$ENDIF} +begin + inherited DoEnter; + FFocused := True; + Checked := true; + {$IFDEF DELPHI9_LVL} + Repaint; + {$ELSE} + R := ClientRect; + R.Right := 16; + InvalidateRect(self.Handle, @R, true); + {$ENDIF} +end; + +procedure TAdvOfficeRadioButton.DoExit; +var + db: boolean; +begin + inherited DoExit; + FFocused := False; + db := FDrawBkg; + FDrawBkg := true; + Repaint; + FDrawBkg := db; +end; + +procedure TAdvOfficeRadioButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + Anchor:string; + R: TRect; +begin + Anchor := ''; + FGotClick := true; + + if FFocused then + begin + Anchor := IsAnchor(X,Y); + if Anchor <> '' then + begin + if (Pos('://',Anchor)>0) or (Pos('mailto:',Anchor)>0) then + {$IFNDEF TMSDOTNET} + ShellExecute(0,'open',PChar(Anchor),nil,nil,SW_NORMAL) + {$ENDIF} + {$IFDEF TMSDOTNET} + ShellExecute(0,'open',Anchor,'','',SW_NORMAL) + {$ENDIF} + else + begin + if Assigned(FAnchorClick) then + FAnchorClick(self,anchor); + end; + end; + end + else + begin + if (self.CanFocus and not (csDesigning in ComponentState)) then + begin + SetFocus; + FFocused := True; + end; + end; + + if Anchor = '' then + begin + inherited MouseDown(Button, Shift, X, Y); + MouseCapture := True; + Down := True; + end; + + R := ClientRect; + R.Right := 16; + InvalidateRect(self.Handle, @r, true); +end; + +procedure TAdvOfficeRadioButton.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + R: TRect; +begin + MouseCapture := False; + Down := False; + + if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) and not Checked and FGotClick then + begin + Checked := true; + end; + + inherited MouseUp(Button, Shift, X, Y); + + DoClick; + + R := ClientRect; + R.Right := 16; + InvalidateRect(self.Handle, @r, true); + + FGotClick := false; +end; + +procedure TAdvOfficeRadioButton.MouseMove(Shift: TShiftState;X, Y: Integer); +var + Anchor:string; +begin + if MouseCapture then + Down := (X>=0) and (X<=Width) and (Y>=0) and (Y<=Height); + + if FFocused then + Anchor := IsAnchor(x,y) + else + Anchor := ''; + + if Anchor <> '' then + begin + if (self.Cursor = crDefault) or (fAnchor <> Anchor) then + begin + FAnchor := Anchor; + self.Cursor := crHandPoint; + if Assigned(FAnchorEnter) then + FAnchorEnter(self,anchor); + end; + end + else + begin + if self.Cursor = crHandPoint then + begin + self.Cursor := FOldCursor; + if Assigned(FAnchorExit) then + FAnchorExit(self,anchor); + end; + end; + + inherited MouseMove(Shift,X,Y); +end; + +procedure TAdvOfficeRadioButton.KeyDown(var Key:Word;Shift:TShiftSTate); +begin + if (Key = vk_return) and (FReturnIsTab) then + begin + Key := vk_tab; + PostMessage(self.Handle,wm_keydown,VK_TAB,0); + end; + + if Key = VK_SPACE then + Down := True; + + inherited KeyDown(Key,Shift); +end; + +procedure TAdvOfficeRadioButton.KeyUp(var Key:Word;Shift:TShiftSTate); +begin + if Key = VK_SPACE then + begin + Down := False; + if not Checked then Checked := True; + end; +end; + +procedure TAdvOfficeRadioButton.SetImages(const Value: TImageList); +begin + FImages := Value; + Invalidate; +end; + +procedure TAdvOfficeRadioButton.Notification(AComponent: TComponent; + AOperation: TOperation); +begin + inherited; + if (AOperation = opRemove) and (AComponent = FImages) then + FImages := nil; + + if (AOperation = opRemove) and (AComponent = FContainer) then + FContainer := nil; +end; + +procedure TAdvOfficeRadioButton.CMEnabledChanged(var Message: TMessage); +begin + inherited; + Invalidate; +end; + +procedure TAdvOfficeRadioButton.SetButtonVertAlign(const Value: TTextLayout); +begin + if Value <> FBtnVAlign then + begin + FBtnVAlign := Value; + Invalidate; + end; +end; + +procedure TAdvOfficeRadioButton.SetAlignment(const Value: TLeftRight); +begin + if FAlignment <> Value then + begin + FAlignment := Value; + Invalidate; + end; +end; + +destructor TAdvOfficeRadioButton.Destroy; +begin + {$IFNDEF TMSDOTNET} + FBkgBmp.Free; + {$ENDIF} + FImageCache.Free; + inherited; +end; + +procedure TAdvOfficeRadioButton.SetEllipsis(const Value: Boolean); +begin + if FEllipsis <> Value then + begin + FEllipsis := Value; + Invalidate; + end; +end; + +procedure TAdvOfficeRadioButton.SetCaption(const Value: string); +begin + inherited Caption := Value; + FCaption := Value; + Invalidate; +end; + +procedure TAdvOfficeRadioButton.Click; +begin +// inherited; +end; + +procedure TAdvOfficeRadioButton.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsAccel(CharCode, FCaption) and CanFocus then + begin + Checked := True; + if TabStop then + if (self.CanFocus and not (csDesigning in ComponentState)) then + SetFocus; + Result := 1; + end else + inherited; + +end; + +procedure TAdvOfficeRadioButton.SetContainer(const Value: TPictureContainer); +begin + FContainer := Value; + Invalidate; +end; + +procedure TAdvOfficeRadioButton.SetShadowColor(const Value: TColor); +begin + if FShadowColor <> Value then + begin + FShadowColor := Value; + Invalidate; + end; +end; + +procedure TAdvOfficeRadioButton.SetShadowOffset(const Value: Integer); +begin + if FShadowOffset <> Value then + begin + FShadowOffset := Value; + Invalidate; + end; +end; + +procedure TAdvOfficeRadioButton.CMMouseEnter(var Message: TMessage); +begin + FHot := True; + DrawRadio; + inherited; +end; + +procedure TAdvOfficeRadioButton.CMMouseLeave(var Message: TMessage); +begin + FHot := False; + DrawRadio; + inherited; +end; + + +procedure TAdvOfficeRadioButton.WMEraseBkGnd(var Message: TMessage); +begin + Message.Result := 1 +end; + +procedure TAdvOfficeRadioButton.WMLButtonDown(var Message:TWMLButtonDown); +begin + FClicksDisabled := True; + if (self.CanFocus and not (csDesigning in ComponentState)) then + SetFocus; + FClicksDisabled := False; + inherited; +end; + +procedure TAdvOfficeRadioButton.Loaded; +begin + inherited; + FOldCursor := Cursor; +end; + +function TAdvOfficeRadioButton.GetVersion: string; +var + vn: Integer; +begin + vn := GetVersionNr; + Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn))); +end; + +function TAdvOfficeRadioButton.GetVersionNr: Integer; +begin + Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER)); +end; + +procedure TAdvOfficeRadioButton.SetVersion(const Value: string); +begin + +end; + + +{ TAdvGroupButton } + +type + TAdvGroupButton = class(TAdvOfficeRadioButton) + private + FInClick: Boolean; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + protected + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char); override; + public + constructor InternalCreate(RadioGroup: TCustomAdvOfficeRadioGroup); + destructor Destroy; override; + end; + +constructor TAdvGroupButton.InternalCreate(RadioGroup: TCustomAdvOfficeRadioGroup); +begin + inherited Create(RadioGroup); + RadioGroup.FButtons.Add(Self); + Visible := False; + Enabled := RadioGroup.Enabled; + ParentShowHint := False; + OnClick := RadioGroup.ButtonClick; + Parent := RadioGroup; +end; + +destructor TAdvGroupButton.Destroy; +begin + TCustomAdvOfficeRadioGroup(Owner).FButtons.Remove(Self); + inherited Destroy; +end; + +procedure TAdvGroupButton.CNCommand(var Message: TWMCommand); +begin + if not FInClick then + begin + FInClick := True; + try + if ((Message.NotifyCode = BN_CLICKED) or + (Message.NotifyCode = BN_DOUBLECLICKED)) and + TCustomAdvOfficeRadioGroup(Parent).CanModify then + inherited; + except + Application.HandleException(Self); + end; + + FInClick := False; + end; +end; + +procedure TAdvGroupButton.KeyPress(var Key: Char); +begin + inherited KeyPress(Key); + TCustomAdvOfficeRadioGroup(Parent).PushKey(Key); + if (Key = #8) or (Key = ' ') then + begin + if not TCustomAdvOfficeRadioGroup(Parent).CanModify then Key := #0; + end; +end; + +procedure TAdvGroupButton.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + TCustomAdvOfficeRadioGroup(Parent).PushKeyDown(Key, Shift); +end; + +{ TCustomAdvOfficeRadioGroup } + +constructor TCustomAdvOfficeRadioGroup.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := [csSetCaption, csDoubleClicks]; + FButtons := TList.Create; + FItems := TStringList.Create; + TStringList(FItems).OnChange := ItemsChange; + FItemIndex := -1; + FColumns := 1; + FAlignment := taLeftJustify; + FBtnVAlign := tlTop; + ShadowOffset := 1; + ShadowColor := clSilver; + FIsReadOnly := false; +end; + +destructor TCustomAdvOfficeRadioGroup.Destroy; +begin + SetButtonCount(0); + TStringList(FItems).OnChange := nil; + FItems.Free; + FButtons.Free; + inherited Destroy; +end; + +procedure TCustomAdvOfficeRadioGroup.PushKey(var Key: Char); +begin + KeyPress(Key); +end; + +procedure TCustomAdvOfficeRadioGroup.PushKeyDown(var Key: Word; Shift: TShiftState); +begin + KeyDown(Key,Shift); +end; + +procedure TCustomAdvOfficeRadioGroup.FlipChildren(AllLevels: Boolean); +begin + { The radio buttons are flipped using BiDiMode } +end; + + +procedure TCustomAdvOfficeRadioGroup.ArrangeButtons; +var + ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer; + DC: HDC; + SaveFont: HFont; + Metrics: TTextMetric; + DeferHandle: THandle; + ALeft: Integer; + RadioEnable: Boolean; + +begin + + if (csLoading in ComponentState) then + Exit; + + if not HandleAllocated then + Exit; + + + if (FButtons.Count <> 0) and not FReading then + begin + DC := GetDC(0); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns; + ButtonWidth := (Width - 10) div FColumns; + I := Height - Metrics.tmHeight - 5; + ButtonHeight := I div ButtonsPerCol; + TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2; + + DeferHandle := BeginDeferWindowPos(FButtons.Count); + try + for I := 0 to FButtons.Count - 1 do + with TAdvGroupButton(FButtons[I]) do + begin + {$IFDEF DELPHI4_LVL} + BiDiMode := Self.BiDiMode; + {$ENDIF} + + DrawBkg := false; + Alignment := Self.Alignment; + ButtonVertAlign := Self.ButtonVertAlign; + Images := Self.Images; + PictureContainer := Self.PictureContainer; + Ellipsis := Self.Ellipsis; + ShadowOffset := Self.ShadowOffset; + ShadowColor := Self.ShadowColor; + + RadioEnable := Self.Enabled and Enabled and not FIsReadOnly; + if Assigned(FOnIsEnabled) then + FOnIsEnabled(Self,I,RadioEnable); + + Enabled := RadioEnable; + + ALeft := (I div ButtonsPerCol) * ButtonWidth + 8; + {$IFDEF DELPHI4_LVL} + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - ButtonWidth; + {$ENDIF} + + DeferHandle := DeferWindowPos(DeferHandle, Handle, 0, + ALeft, + (I mod ButtonsPerCol) * ButtonHeight + TopMargin, + ButtonWidth, ButtonHeight, + SWP_NOZORDER or SWP_NOACTIVATE); + + // Left := ALeft; + // Top := (I mod ButtonsPerCol) * ButtonHeight + TopMargin; + Visible := True; + + end; + finally + EndDeferWindowPos(DeferHandle); + end; + end; +end; + +procedure TCustomAdvOfficeRadioGroup.ButtonClick(Sender: TObject); +begin + if not FUpdating then + begin + FItemIndex := FButtons.IndexOf(Sender); + Changed; + Click; + end; +end; + +procedure TCustomAdvOfficeRadioGroup.ItemsChange(Sender: TObject); +begin + if not FReading then + begin + if FItemIndex >= FItems.Count then + FItemIndex := FItems.Count - 1; + UpdateButtons; + end; +end; + +procedure TCustomAdvOfficeRadioGroup.Loaded; +begin + inherited Loaded; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.ReadState(Reader: TReader); +begin + FReading := True; + inherited ReadState(Reader); + FReading := False; + UpdateButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.SetButtonCount(Value: Integer); +begin + while FButtons.Count < Value do TAdvGroupButton.InternalCreate(Self); + while FButtons.Count > Value do TAdvGroupButton(FButtons.Last).Free; +end; + +procedure TCustomAdvOfficeRadioGroup.SetColumns(Value: Integer); +begin + if Value < 1 then Value := 1; + if Value > 16 then Value := 16; + if FColumns <> Value then + begin + FColumns := Value; + ArrangeButtons; + Invalidate; + end; +end; + +procedure TCustomAdvOfficeRadioGroup.SetItemIndex(Value: Integer); +begin + if FReading then FItemIndex := Value else + begin + if Value < -1 then Value := -1; + if Value >= FButtons.Count then Value := FButtons.Count - 1; + if FItemIndex <> Value then + begin + if FItemIndex >= 0 then + TAdvGroupButton(FButtons[FItemIndex]).Checked := False; + FItemIndex := Value; + if FItemIndex >= 0 then + TAdvGroupButton(FButtons[FItemIndex]).Checked := True; + end; + end; +end; + +procedure TCustomAdvOfficeRadioGroup.SetItems(Value: TStrings); +begin + FItems.Assign(Value); +end; + +procedure TCustomAdvOfficeRadioGroup.UpdateButtons; +var + I: Integer; +begin + SetButtonCount(FItems.Count); + for I := 0 to FButtons.Count - 1 do + TAdvGroupButton(FButtons[I]).Caption := FItems[I]; + if FItemIndex >= 0 then + begin + FUpdating := True; + TAdvGroupButton(FButtons[FItemIndex]).Checked := True; + FUpdating := False; + end; + ArrangeButtons; + Invalidate; +end; + +procedure TCustomAdvOfficeRadioGroup.CMEnabledChanged(var Message: TMessage); +var + I: Integer; +begin + inherited; + for I := 0 to FButtons.Count - 1 do + TAdvGroupButton(FButtons[I]).Enabled := Enabled; +end; + +procedure TCustomAdvOfficeRadioGroup.CMFontChanged(var Message: TMessage); +begin + inherited; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.WMSize(var Message: TWMSize); +begin + inherited; + ArrangeButtons; +end; + +function TCustomAdvOfficeRadioGroup.CanModify: Boolean; +begin + Result := True; +end; + +procedure TCustomAdvOfficeRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin +end; + +procedure TCustomAdvOfficeRadioGroup.SetAlignment(const Value: TAlignment); +begin + FAlignment := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.SetButtonVertAlign( + const Value: TTextLayout); +begin + fBtnVAlign := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.SetContainer( + const Value: TPictureContainer); +begin + FContainer := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.SetImages(const Value: TImageList); +begin + inherited Images := Value; + FImages := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.Notification(AComponent: TComponent; + AOperation: TOperation); +begin + inherited; + + if (AOperation = opRemove) and (AComponent = FImages) then + FImages:=nil; + + if (AOperation = opRemove) and (AComponent = FContainer) then + FContainer := nil; +end; + +procedure TCustomAdvOfficeRadioGroup.SetEllipsis(const Value: Boolean); +begin + FEllipsis := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.SetShadowColor(const Value: TColor); +begin + FShadowColor := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeRadioGroup.SetShadowOffset(const Value: Integer); +begin + FShadowOffset := Value; + ArrangeButtons; +end; + +function TCustomAdvOfficeRadioGroup.GetVersion: string; +var + vn: Integer; +begin + vn := GetVersionNr; + Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn))); +end; + +function TCustomAdvOfficeRadioGroup.GetVersionNr: Integer; +begin + Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER)); +end; + +procedure TCustomAdvOfficeRadioGroup.SetVersion(const Value: string); +begin + +end; + + +{ TGroupCheck } + +type + TGroupCheck = class(TAdvOfficeCheckBox) + private + FInClick: Boolean; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + protected + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char); override; + public + constructor InternalCreate(CheckGroup: TCustomAdvOfficeCheckGroup); + destructor Destroy; override; + end; + +constructor TGroupCheck.InternalCreate(CheckGroup: TCustomAdvOfficeCheckGroup); +begin + inherited Create(CheckGroup); + CheckGroup.FButtons.Add(Self); + Visible := False; + Enabled := CheckGroup.Enabled; + ParentShowHint := False; + OnClick := CheckGroup.ButtonClick; + Parent := CheckGroup; +end; + +destructor TGroupCheck.Destroy; +begin + TCustomAdvOfficeCheckGroup(Owner).FButtons.Remove(Self); + inherited Destroy; +end; + +procedure TGroupCheck.CNCommand(var Message: TWMCommand); +begin + if not FInClick then + begin + FInClick := True; + try + if ((Message.NotifyCode = BN_CLICKED) or + (Message.NotifyCode = BN_DOUBLECLICKED)) and + TCustomAdvOfficeCheckGroup(Parent).CanModify then + inherited; + except + Application.HandleException(Self); + end; + FInClick := False; + end; +end; + +procedure TGroupCheck.KeyPress(var Key: Char); +begin + inherited KeyPress(Key); + TCustomAdvOfficeCheckGroup(Parent).PushKey(Key); + if (Key = #8) or (Key = ' ') then + begin + if not TCustomAdvOfficeCheckGroup(Parent).CanModify then Key := #0; + end; +end; + +procedure TGroupCheck.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + TCustomAdvOfficeCheckGroup(Parent).PushKeyDown(Key, Shift); +end; + + +{ TCustomAdvOfficeCheckGroup } + +constructor TCustomAdvOfficeCheckGroup.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := [csSetCaption, csDoubleClicks]; + FButtons := TList.Create; + FItems := TStringList.Create; + TStringList(FItems).OnChange := ItemsChange; + FColumns := 1; + FAlignment := taLeftJustify; + FBtnVAlign := tlTop; + ShadowOffset := 1; + ShadowColor := clSilver; + FValue := 0; +end; + +destructor TCustomAdvOfficeCheckGroup.Destroy; +begin + SetButtonCount(0); + TStringList(FItems).OnChange := nil; + FItems.Free; + FButtons.Free; + inherited Destroy; +end; + +procedure TCustomAdvOfficeCheckGroup.PushKey(var Key: Char); +begin + KeyPress(Key); +end; + +procedure TCustomAdvOfficeCheckGroup.PushKeyDown(var Key: Word; Shift: TShiftState); +begin + KeyDown(Key,Shift); +end; + +{$IFDEF DELPHI4_LVL} +procedure TCustomAdvOfficeCheckGroup.FlipChildren(AllLevels: Boolean); +begin + { The radio buttons are flipped using BiDiMode } +end; +{$ENDIF} + +procedure TCustomAdvOfficeCheckGroup.ArrangeButtons; +var + ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer; + DC: HDC; + SaveFont: HFont; + Metrics: TTextMetric; + DeferHandle: THandle; + ALeft: Integer; + RadioEnable: Boolean; + +begin + if (FButtons.Count <> 0) and not FReading then + begin + DC := GetDC(0); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns; + ButtonWidth := (Width - 10) div FColumns; + I := Height - Metrics.tmHeight - 5; + ButtonHeight := I div ButtonsPerCol; + TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2; + DeferHandle := BeginDeferWindowPos(FButtons.Count); + try + for I := 0 to FButtons.Count - 1 do + with TGroupCheck(FButtons[I]) do + begin + {$IFDEF DELPHI4_LVL} + BiDiMode := Self.BiDiMode; + {$ENDIF} + + DrawBkg := false; + Alignment := Self.Alignment; + ButtonVertAlign := Self.ButtonVertAlign; + Images := Self.Images; + PictureContainer := Self.PictureContainer; + Ellipsis := Self.Ellipsis; + ShadowOffset := Self.ShadowOffset; + ShadowColor := Self.ShadowColor; + + RadioEnable := self.Enabled; + if Assigned(FOnIsEnabled) then + FOnIsEnabled(Self,I,RadioEnable); + + Enabled := RadioEnable; + + ALeft := (I div ButtonsPerCol) * ButtonWidth + 8; + {$IFDEF DELPHI4_LVL} + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - ButtonWidth; + {$ENDIF} + DeferHandle := DeferWindowPos(DeferHandle, Handle, 0, + ALeft, + (I mod ButtonsPerCol) * ButtonHeight + TopMargin, + ButtonWidth, ButtonHeight, + SWP_NOZORDER or SWP_NOACTIVATE); + Visible := True; + + end; + finally + EndDeferWindowPos(DeferHandle); + end; + end; +end; + +procedure TCustomAdvOfficeCheckGroup.ButtonClick(Sender: TObject); +begin + if not FUpdating then + begin + Changed; + Click; + end; + UpdateValue; +end; + +procedure TCustomAdvOfficeCheckGroup.ItemsChange(Sender: TObject); +begin + if not FReading then + begin + UpdateButtons; + end; +end; + +procedure TCustomAdvOfficeCheckGroup.Loaded; +begin + inherited Loaded; + ArrangeButtons; + Value := Value; +end; + +procedure TCustomAdvOfficeCheckGroup.ReadState(Reader: TReader); +begin + FReading := True; + inherited ReadState(Reader); + FReading := False; + UpdateButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.SetButtonCount(Value: Integer); +begin + while FButtons.Count < Value do TGroupCheck.InternalCreate(Self); + while FButtons.Count > Value do TGroupCheck(FButtons.Last).Free; +end; + +procedure TCustomAdvOfficeCheckGroup.SetColumns(Value: Integer); +begin + if Value < 1 then Value := 1; + if Value > 16 then Value := 16; + if FColumns <> Value then + begin + FColumns := Value; + ArrangeButtons; + Invalidate; + end; +end; + +procedure TCustomAdvOfficeCheckGroup.SetItems(Value: TStrings); +begin + FItems.Assign(Value); +end; + +procedure TCustomAdvOfficeCheckGroup.UpdateButtons; +var + I: Integer; +begin + SetButtonCount(FItems.Count); + for I := 0 to FButtons.Count - 1 do + TGroupCheck(FButtons[I]).Caption := FItems[I]; + + ArrangeButtons; + Invalidate; +end; + +procedure TCustomAdvOfficeCheckGroup.CMEnabledChanged(var Message: TMessage); +var + I: Integer; +begin + inherited; + for I := 0 to FButtons.Count - 1 do + TGroupCheck(FButtons[I]).Enabled := Enabled; +end; + +procedure TCustomAdvOfficeCheckGroup.CMFontChanged(var Message: TMessage); +begin + inherited; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.WMSize(var Message: TWMSize); +begin + inherited; + ArrangeButtons; +end; + +function TCustomAdvOfficeCheckGroup.CanModify: Boolean; +begin + Result := True; +end; + +procedure TCustomAdvOfficeCheckGroup.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin +end; + +procedure TCustomAdvOfficeCheckGroup.SetAlignment(const Value: TAlignment); +begin + FAlignment := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.SetButtonVertAlign( + const Value: TTextLayout); +begin + fBtnVAlign := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.SetContainer( + const Value: TPictureContainer); +begin + FContainer := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.SetImages(const Value: TImageList); +begin + inherited Images := Value; + FImages := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.Notification(AComponent: TComponent; + AOperation: TOperation); +begin + inherited; + + if (AOperation = opRemove) and (AComponent = FImages) then + FImages:=nil; + + if (AOperation = opRemove) and (AComponent = FContainer) then + FContainer := nil; +end; + +procedure TCustomAdvOfficeCheckGroup.SetEllipsis(const Value: Boolean); +begin + FEllipsis := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.SetShadowColor(const Value: TColor); +begin + FShadowColor := Value; + ArrangeButtons; +end; + +procedure TCustomAdvOfficeCheckGroup.SetShadowOffset(const Value: Integer); +begin + FShadowOffset := Value; + ArrangeButtons; +end; + + +function TCustomAdvOfficeCheckGroup.GetChecked(Index: Integer): Boolean; +begin + if (Index < FButtons.Count) and (Index >= 0) then + Result := TGroupCheck(FButtons[Index]).Checked + else + raise Exception.Create('Invalid checkbox index'); +end; + +procedure TCustomAdvOfficeCheckGroup.SetChecked(Index: Integer; + const Value: Boolean); +begin + if (Index < FButtons.Count) and (Index >= 0) then + TGroupCheck(FButtons[Index]).Checked := Value; +end; + +function TCustomAdvOfficeCheckGroup.GetReadOnly(Index: Integer): Boolean; +begin + if (Index < FButtons.Count) and (Index >= 0) then + Result := not TGroupCheck(FButtons[Index]).Enabled + else + raise Exception.Create('Invalid checkbox index'); +end; + +procedure TCustomAdvOfficeCheckGroup.SetReadOnly(Index: Integer; + const Value: Boolean); +begin + if (Index < FButtons.Count) and (Index >= 0) then + TGroupCheck(FButtons[Index]).Enabled := not Value; +end; + +procedure TCustomAdvOfficeCheckGroup.UpdateValue; +var + i, j: Integer; + BitMask: DWord; +begin + FValue := Value; + j := Min(FButtons.Count, sizeof(DWord) * 8); + BitMask := 1; + FValue := 0; + for i := 0 to j - 1 do + begin + if TGroupCheck(FButtons[i]).Checked then + begin + FValue := FValue or BitMask; + end; + BitMask := BitMask * 2; + end; +end; + +function TCustomAdvOfficeCheckGroup.GetValue: DWord; +begin + Result := FValue; +end; + +procedure TCustomAdvOfficeCheckGroup.SetValue(const Value: DWord); +var + i, j: Integer; + BitMask: Integer; +begin + //if (FValue <> Value) then + begin + FValue := Value; + j := Min(FButtons.Count, sizeof(DWord) * 8); + BitMask := 1; + for i := 0 to j - 1 do + begin + TGroupCheck(FButtons[i]).Checked := ((FValue And BitMask) > 0); + BitMask := BitMask * 2; + end; + end; +end; + +function TCustomAdvOfficeCheckGroup.GetVersion: string; +var + vn: Integer; +begin + vn := GetVersionNr; + Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn))); +end; + +function TCustomAdvOfficeCheckGroup.GetVersionNr: Integer; +begin + Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER)); +end; + +procedure TCustomAdvOfficeCheckGroup.SetVersion(const Value: string); +begin + +end; + +{$IFDEF FREEWARE} +{$I TRIAL.INC} +{$ENDIF} + + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvOfficeButtons.res b/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvOfficeButtons.res new file mode 100644 index 0000000..8f0cdb9 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Source/AdvOfficeButtons.res differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialog.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialog.pas new file mode 100644 index 0000000..d62754f --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialog.pas @@ -0,0 +1,4423 @@ +{***************************************************************************} +{ TTaskDialog component } +{ for Delphi & C++Builder } +{ } +{ written by TMS Software } +{ copyright © 2006 - 2008 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit TaskDialog; + +{$R TASKDIALOG.RES} + +{$I TMSDEFS.INC} + +interface + +uses + Classes, Windows, Messages, Forms, Dialogs, SysUtils, StdCtrls, Graphics, Consts, Math, + ExtCtrls, Controls, ComCtrls, PictureContainer, ComObj, ShellAPI, CommCtrl, ClipBrd; + +const +{$IFNDEF DELPHI6_LVL} + sLineBreak = #13#10; +{$ENDIF} + + MAJ_VER = 1; // Major version nr. + MIN_VER = 5; // Minor version nr. + REL_VER = 0; // Release nr. + BLD_VER = 2; // Build nr. + + // version history + // 1.0.0.0 : First release + // 1.0.1.0 : Added support for Information icon + // : Fixed issue with radiobutton initialization + // 1.0.2.0 : Various cosmetic fixes for emulated dialog + // : Design time preview + // 1.0.3.0 : Improved wordwrapped content display + // 1.0.4.0 : Added support to display shield icon on non Vista operating systems + // 1.0.5.0 : Fixed issue with tiError icon for non Vista operating systems + // 1.0.5.1 : Fixed issue with tiBlank icon for non Vista operating systems + // 1.0.5.2 : Removed Close button from dialog caption for non Vista operating systems + // 1.0.5.3 : Fixed issue with blank FooterIcon + // : Fixed issue with content height + // 1.0.5.4 : Improved : content sizing for non Vista operating systems dialogs + // 1.0.5.5 : Fixed issue with progress bar for non Vista operating systems dialogs + // 1.0.5.6 : Fixed issue with Expanded Text size calculation for non Vista operating systems dialogs + // 1.0.5.7 : Fixed issue with default button for non Vista operating systems dialogs + // 1.0.5.8 : Fixed issue with Expanded Text size calculation for non Vista operating systems dialogs + // : Fixed issue with FooterIcon drawing + // 1.0.6.0 : New : property DialogPosition added , only applicable for non Vista OS + // : Fixed : issue with ESC key handling + // 1.1.0.0 : Improved : Reflect properties change at run time + // : Fixed issues with Footer and its FooterIcon size + // : Added ShortCut support in CommandLinks + // 1.2.0.0 : New : support added for Hyperlinks in expanded text + // : New : option to show no default radiobutton added + // : New : capability to update instruction, content, expanded text, footer while dialog is displayed + // : New : option to allow cancelling the dialog with ESC added + // : Improved : text wrapping for verify text + // : New : TAdvTaskDialogEx component created using TAdvGlowButton on non Vista emulation + // : New : property ApplicationIsParent added + // : New : support for custom icons + // 1.2.1.0 : New : support for Information & Shield footer icon + // : Improved : border drawing on Vista in XP compatibility mode + // : New : added support for \n linebreaks in Vista emulation mode + // 1.2.1.1 : Fixed : issue with DefaultRadioButton initialization + // 1.2.1.2 : Fixed : issue with \n linebreaks with doHyperlinks style + // 1.2.2.0 : Improved : keyboard handling for CommandLinks dialog on non Vista emulation + // : Improved : DefaultButton handling for CommandLinks dialog on non Vista emulation + // 1.2.2.1 : Fixed : issue with noCommandLinksIcon on non Vista emulation + // 1.2.2.2 : Fixed : hot painting issue on taskdialog button on non Vista emulation + // 1.2.3.0 : Improved : allow using \n line separators in footer text on non Vista emulation + // : Fixed : issue with doAllowDialogCancel on non Vista emulation + // : Fixed : issue with doAllowMinimize on non Vista emulation + // 1.2.4.0 : Improved : removed limitation on text length of Content, Title, ... in Vista native mode + // : Improved : handling of linefeed character on non Vista emulation + // : Improved : handling of anchors in Vista native mode + // : Improved : handling of ESC with common buttons + // 1.2.4.1 : Improved : prevent that Alt-F4 can close the dialog + // 1.2.5.0 : New : support for hotkeys on expand/contract text on non-Vista emulation + // 1.2.5.1 : Fixed : issue with identical accelerator key for expand/collaps + // 1.2.6.0 : Improved : taskdialog does not size beyond screen width + // : Improved : DefaultButton can be set to -1 to have no default button + // 1.2.7.0 : New: NonNativeDialog property added + // : New: NonNativeMinFormWidth public property added + // 1.2.8.0 : Improved : display of disabled task button + // 1.2.8.1 : Fixed : display of long text in non native taskdialog + // 1.2.8.2 : Fixed : issue with DefaultButton = IdYes, IdNo + // 1.5.0.0 : New : replacement functions for ShowMessage , MessageDlg + // : New : TAdvInputTaskDialog + // : New : ElevateButton method added + // : Improved : message label set transparent + // : Improved : Ctrl-C puts taskdialog text on clipboard + // 1.5.0.1 : Fixed : Delphi 5 issue with TAdvInputTaskDialog + // 1.5.0.2 : Fixed : issue with use of TAdvTaskDialog on topmost forms + +type + {$IFNDEF DELPHI6_LVL} + PBoolean = ^Boolean; + {$ENDIF} + + TTaskDialogResult = (trNone, trOk, trCancel); + + TNonNativeDialog = (nndAuto, nndAlways); + + TTaskDialogOption = (doHyperlinks, doCommandLinks, doCommandLinksNoIcon, doExpandedDefault, + doExpandedFooter, doAllowMinimize, doVerifyChecked, doProgressBar, doProgressBarMarquee, + doTimer, doNoDefaultRadioButton, doAllowDialogCancel); + + TTaskDialogOptions = set of TTaskDialogOption; + + TTaskDialogIcon = (tiBlank, tiWarning, tiQuestion, tiError, tiInformation,tiNotUsed,tiShield); + //(mtWarning, mtError, mtInformation, mtConfirmation, mtCustom); + TTaskDialogFooterIcon = (tfiBlank, tfiWarning, tfiQuestion, tfiError, tfiInformation, + tfiShield); + + TTaskDialogProgressState = (psNormal, psError, psPaused); + + TTaskDialogPosition = (dpScreenCenter, dpOwnerFormCenter); + + TCommonButton = (cbOK, cbYes, cbNo, cbCancel, cbRetry, cbClose); + + TTaskDialogButtonClickEvent = procedure(Sender: TObject; ButtonID: integer) of object; + TTaskDialogHyperlinkClickEvent = procedure(Sender: TObject; HRef: string) of object; + TTaskDialogVerifyClickEvent = procedure(Sender: TObject; Checked: boolean) of object; + TTaskDialogCloseEvent = procedure(Sender: TObject; var CanClose: boolean) of object; + + TTaskDialogProgressEvent = procedure(Sender: TObject; var Pos: integer; var State: TTaskDialogProgressState) of object; + + TCommonButtons = set of TCommonButton; + + TAdvMessageForm = class; + + TInputType = (itEdit, itMemo, itComboEdit, itComboList, itDate, itCustom, itNone); + + TInputGetTextEvent = procedure(Sender: TObject; var Text: string) of object; + TInputSetTextEvent = procedure(Sender: TObject; Text: string) of object; + + TCustomAdvTaskDialog = class(TComponent) + private + FTitle: string; + FContent: string; + FFooter: string; + FInstruction: string; + FCommonButtons: TCommonButtons; + FExpandedText: string; + FCollapsControlText: string; + FExpandControlText: string; + FButtonResult: integer; + FVerifyResult: boolean; + FVerifyText: string; + FCustomButtons: TStringList; + FCustomIcon: TIcon; + FOptions: TTaskDialogOptions; + FRadioButtons: TStringList; + FhWnd: THandle; + FOnCreated: TNotifyEvent; + FOnTimer: TNotifyEvent; + FProgressBarMin: integer; + FProgressBarMax: integer; + FOnDialogHyperlinkClick: TTaskDialogHyperlinkClickEvent; + FOnDialogClick: TTaskDialogButtonClickEvent; + FOnDialogRadioClick: TTaskDialogButtonClickEvent; + FOnDialogVerifyClick: TTaskDialogVerifyClickEvent; + FOnDialogProgress: TTaskDialogProgressEvent; + FOnDialogClose: TTaskDialogCloseEvent; + FOnDialogInputGetText: TInputGetTextEvent; + FOnDialogInputSetText: TInputSetTextEvent; + FIcon: TTaskDialogIcon; + FFooterIcon: TTaskDialogFooterIcon; + FDefaultButton: integer; + FDefaultRadioButton: integer; + FDialogForm: TAdvMessageForm; + FDlgPosition: TTaskDialogPosition; + FApplicationIsParent: Boolean; + FModalParent: THandle; + FMinFormWidth: Integer; + FNonNativeDialog: TNonNativeDialog; + FInputType: TInputType; + FInputText: string; + FInputItems: TStrings; + FInputControl: TWinControl; + function GetVersion: string; + procedure SetVersion(const Value: string); + function GetVersionNr: Integer; + procedure SetCustomButtons(const Value: TStringList); + procedure SetRadioButtons(const Value: TStringList); + procedure SetContent(const Value: string); + procedure SetInstruction(const Value: string); + procedure SetFooter(const Value: string); + procedure SetExpandedText(const Value: string); + procedure SetCustomIcon(const Value: TIcon); + procedure SetInputItems(const Value: TStrings); + protected + function CreateButton(AOwner: TComponent): TWinControl; virtual; + function CreateRadioButton(AOwner: TComponent): TWinControl; virtual; + procedure InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); virtual; + procedure SetRadioButtonState(Btn: TWinControl; Checked: boolean); virtual; + procedure SetRadioButtonCaption(Btn: TWinControl; Value: string); virtual; + procedure SetButtonCaption(aButton: TWinControl; Value: TCaption); virtual; + procedure SetButtonCancel(aButton: TWinControl; Value: Boolean); virtual; + procedure SetButtonDefault(aButton: TWinControl; Value: Boolean); virtual; + procedure SetButtonModalResult(aButton: TWinControl; Value: Integer); virtual; + function GetButtonModalResult(aButton: TWinControl): Integer; virtual; + property CustomButtons: TStringList read FCustomButtons write SetCustomButtons; + property CustomIcon: TIcon read FCustomIcon write SetCustomIcon; + property RadioButtons: TStringList read FRadioButtons write SetRadioButtons; + property CommonButtons: TCommonButtons read FCommonButtons write FCommonButtons; + property DefaultButton: integer read FDefaultButton write FDefaultButton; + property DefaultRadioButton: integer read FDefaultRadioButton write FDefaultRadioButton; + property DialogPosition: TTaskDialogPosition read FDlgPosition write FDlgPosition default dpScreenCenter; + property ExpandedText: string read FExpandedText write SetExpandedText; + property Footer: string read FFooter write SetFooter; + property FooterIcon: TTaskDialogFooterIcon read FFooterIcon write FFooterIcon default tfiBlank; + property Icon: TTaskDialogIcon read FIcon write FIcon default tiBlank; + property InputText: string read FInputText write FInputText; + property InputType: TInputType read FInputType write FInputType; + property InputItems: TStrings read FInputItems write SetInputItems; + property InputControl: TWinControl read FInputControl write FInputControl; + property Title: string read FTitle write FTitle; + property Instruction: string read FInstruction write SetInstruction; + property Content: string read FContent write SetContent; + property ExpandControlText: string read FExpandControlText write FExpandControlText; + property CollapsControlText: string read FCollapsControlText write FCollapsControlText; + property Options: TTaskDialogOptions read FOptions write FOptions; + property ApplicationIsParent: boolean read FApplicationIsParent write FApplicationIsParent default true; + property VerificationText: string read FVerifyText write FVerifyText; + property NonNativeDialog: TNonNativeDialog read FNonNativeDialog write FNonNativeDialog default nndAuto; + property NonNativeMinFormWidth: integer read FMinFormWidth write FMinFormWidth default 350; + + property ProgressBarMin: integer read FProgressBarMin write FProgressBarMin default 0; + property ProgressBarMax: integer read FProgressBarMax write FProgressBarMax default 100; + property Version: string read GetVersion write SetVersion; + + property OnDialogCreated: TNotifyEvent read FOnCreated write FOnCreated; + property OnDialogClose: TTaskDialogCloseEvent read FOnDialogClose write FOnDialogClose; + property OnDialogButtonClick: TTaskDialogButtonClickEvent read FOnDialogClick write FOnDialogClick; + property OnDialogInputSetText: TInputSetTextEvent read FOnDialogInputSetText write FOnDialogInputSetText; + property OnDialogInputGetText: TInputGetTextEvent read FOnDialogInputGetText write FOnDialogInputGetText; + property OnDialogRadioClick: TTaskDialogButtonClickEvent read FOnDialogRadioClick write FOnDialogRadioClick; + property OnDialogHyperlinkClick: TTaskDialogHyperlinkClickEvent read FOnDialogHyperlinkClick write FOnDialogHyperLinkClick; + property OnDialogTimer: TNotifyEvent read FOnTimer write FOnTimer; + property OnDialogVerifyClick: TTaskDialogVerifyClickEvent read FOnDialogVerifyClick write FOnDialogVerifyClick; + property OnDialogProgress: TTaskDialogProgressEvent read FOnDialogProgress write FOnDialogProgress; + public + property hWnd: THandle read FhWnd write FhWnd; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function Execute: integer; virtual; + procedure Clear; + procedure EnableButton(ButtonID: integer; Enabled: boolean); + procedure ElevateButton(ButtonID: integer; Enabled: boolean); + procedure ClickButton(ButtonID: integer); + property RadioButtonResult: integer read FButtonResult write FButtonResult; + property VerifyResult: boolean read FVerifyResult write FVerifyResult; + property ModalParent: THandle read FModalParent write FModalParent; + end; + + TAdvTaskDialog = class(TCustomAdvTaskDialog) + published + property CustomButtons; + property CustomIcon; + property RadioButtons; + property CommonButtons; + property DefaultButton; + property DefaultRadioButton; + property DialogPosition; + property ExpandedText; + property Footer; + property FooterIcon; + property Icon; + property Title; + property Instruction; + property Content; + property ExpandControlText; + property CollapsControlText; + property Options; + property ApplicationIsParent; + property VerificationText; + property NonNativeDialog; + property NonNativeMinFormWidth; + + property ProgressBarMin; + property ProgressBarMax; + property Version; + + property OnDialogCreated; + property OnDialogClose; + property OnDialogButtonClick; + property OnDialogRadioClick; + property OnDialogHyperlinkClick; + property OnDialogTimer; + property OnDialogVerifyClick; + property OnDialogProgress; + end; + + TAdvInputTaskDialog = class(TCustomAdvTaskDialog) + public + constructor Create(AOwner: TComponent); override; + function Execute: integer; override; + published + property ApplicationIsParent; + property CustomButtons; + property CustomIcon; + property CommonButtons; + property DefaultButton; + property DialogPosition; + property ExpandedText; + property Footer; + property FooterIcon; + property Icon; + property InputControl; + property InputType; + property InputText; + property InputItems; + property Instruction; + property Title; + property Content; + property ExpandControlText; + property CollapsControlText; + property VerificationText; + property OnDialogCreated; + property OnDialogClose; + property OnDialogButtonClick; + property OnDialogVerifyClick; + property OnDialogInputSetText; + property OnDialogInputGetText; + end; + + TTaskDialogButton = class(TCustomControl) + private + FOnMouseLeave: TNotifyEvent; + FOnMouseEnter: TNotifyEvent; + FGlyph: TBitmap; + FGlyphDisabled: TBitmap; + FGlyphDown: TBitmap; + FGlyphHot: TBitmap; + FMouseInControl: Boolean; + FMouseDown: Boolean; + FBorderColorDown: TColor; + FBorderColorHot: TColor; + FBorderColor: TColor; + FModalResult: TModalResult; + FHeadingFont: TFont; + FAutoFocus: boolean; + procedure OnPictureChanged(Sender: TObject); + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + procedure SetGlyph(const Value: TBitmap); + procedure SetGlyphDisabled(const Value: TBitmap); + procedure SetGlyphDown(const Value: TBitmap); + procedure SetGlyphHot(const Value: TBitmap); + procedure SetHeadingFont(const Value: TFont); + protected + procedure Paint; override; + procedure KeyPress(var Key: char); 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; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Click; override; + procedure DoEnter; override; + procedure DoExit; override; + property AutoFocus: boolean read FAutoFocus write FAutoFocus; + published + property Anchors; + property BorderColor: TColor read FBorderColor write FBorderColor; + property BorderColorHot: TColor read FBorderColorHot write FBorderColorHot; + property BorderColorDown: TColor read FBorderColorDown write FBorderColorDown; + property Constraints; + property Enabled; + property HeadingFont: TFont read FHeadingFont write SetHeadingFont; + property ModalResult: TModalResult read FModalResult write FModalResult default 0; + property Picture: TBitmap read FGlyph write SetGlyph; + property PictureHot: TBitmap read FGlyphHot write SetGlyphHot; + property PictureDown: TBitmap read FGlyphDown write SetGlyphDown; + property PictureDisabled: TBitmap read FGlyphDisabled write SetGlyphDisabled; + property Visible; + property OnClick; + property OnDblClick; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; + property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; + end; + + TAdvMessageForm = class(TForm) + private + Message: TLabel; + FHorzMargin: Integer; + FVertMargin: Integer; + FHorzSpacing: Integer; + FVertSpacing: Integer; + FExpandButton: TTaskDialogButton; + FExpanded: Boolean; + //FExpandLabel: TLabel; + FExpandControlText: String; + FCollapsControlText: String; + FcmBtnList: TList; + FcsBtnList: TList; + FTaskDialog: TCustomAdvTaskDialog; + FFooterIcon: TImage; + FFooterIconID: PChar; + FRadioList: TList; + FVerificationCheck: TCheckBox; + FProgressBar: TProgressBar; + FIcon: TImage; + FFooterXSize: Integer; + FFooterYSize: Integer; + FContentXSize: Integer; + FContentYSize: Integer; + FExpTextXSize: Integer; + FExpTextYSize: Integer; + FExpTextTop: Integer; + FAnchor: String; + FTimer: TTimer; + FWhiteWindowHeight: Integer; + FHorzParaMargin: Integer; + FMinFormWidth: Integer; + FInputEdit: TEdit; + FInputCombo: TComboBox; + FInputDate: TDateTimePicker; + FInputMemo: TMemo; + FOldParent: TWinControl; + procedure WMActivate(var M: TWMActivate); message WM_ACTIVATE; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure OnTimer(Sender: TObject); + procedure OnExpandButtonClick(Sender: TObject); + procedure OnVerifyClick(Sender: TObject); + procedure OnRadioClick(Sender: TObject); + procedure OnButtonClick(Sender: TObject); + procedure SetExpandButton(const Value: TTaskDialogButton); + procedure GetTextSize(Canvas: TCanvas; Text: string;var W, H: Integer); + //procedure GetMultiLineTextSize(Canvas: TCanvas; Text: string; HeadingFont, ParaFont: TFont; var W, H: Integer); + //procedure HelpButtonClick(Sender: TObject); + protected + procedure SetExpanded(Value: Boolean); + procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure WriteToClipBoard(Text: String); + function GetFormText: String; + procedure Paint; override; + procedure KeyDown(var Key:Word;Shift:TShiftSTate); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure DoClose(var Action: TCloseAction); override; + + function GetButton(ButtonID: Integer; var TaskButton: TTaskDialogButton): TButton; + procedure EnableButton(ButtonID: integer; Enabled: boolean); + procedure ClickButton(ButtonID: integer); + function IsAnchor(x, y: integer): string; + function GetFooterRect: TRect; + function GetContentRect: TRect; + function GetExpTextRect: TRect; + procedure DrawExpandedText; + procedure DrawContent; + procedure DrawFooter; + property Expanded: Boolean read FExpanded default true; + property ExpandButton: TTaskDialogButton read FExpandButton write SetExpandButton; + procedure DoShow; override; + public + constructor CreateNew(AOwner: TComponent; Dummy: Integer); {$IFNDEF BCB} reintroduce; {$ENDIF} + destructor Destroy; override; + procedure BuildTaskDialog(TaskDialog: TCustomAdvTaskDialog); + procedure SetPositions; + procedure UpdateDialog; + property MinFormWidth: Integer Read FMinFormWidth Write FMinFormWidth; + end; + + function AdvMessageDlgPos(TaskDialog: TCustomAdvTaskDialog; X, Y: Integer): Integer; + + +function AdvShowMessage(const Instruction: string): boolean; overload; +function AdvShowMessage(const Title, Instruction: string): boolean; overload; +function AdvShowmessage(const Title, Instruction: string; tiIcon: tTaskDialogIcon): boolean; overload; +function AdvShowMessage(const Title, Instruction, content, verify: string; + tiIcon: tTaskDialogIcon): boolean; overload; + +function AdvMessageBox(hWnd: HWND; lpInstruction, lpTitle: PChar; flags: UINT): Integer; + + +function AdvShowMessageFmt(const Instruction: string; Parameters: array of const): boolean; + +function AdvMessageDlg(const Instruction: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; overload; + +function AdvMessageDlg(const Instruction: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; overload; + + +function AdvInputQueryDlg(ACaption, APrompt: string; var Value: string): boolean; + +var + DRAWBORDER: Boolean = True; + ButtonNames: array[TCommonButton] of string = ('OK', 'Yes', 'No', 'Cancel', 'Retry', 'Abort'); + +procedure Register; + +implementation + +{$I HTMLENGO.PAS} + +const + TDE_CONTENT = 0; + TDE_EXPANDED_INFORMATION = 1; + TDE_FOOTER = 2; + TDE_MAIN_INSTRUCTION = 3; + + TDF_ENABLE_HYPERLINKS = $0001; + TDF_USE_HICON_MAIN = $0002; + TDF_USE_HICON_FOOTER = $0004; + TDF_ALLOW_DIALOG_CANCELLATION = $0008; + TDF_USE_COMMAND_LINKS = $0010; + TDF_USE_COMMAND_LINKS_NO_ICON = $0020; + TDF_EXPAND_FOOTER_AREA = $0040; + TDF_EXPANDED_BY_DEFAULT = $0080; + TDF_VERIFICATION_FLAG_CHECKED = $0100; + TDF_SHOW_PROGRESS_BAR = $0200; + TDF_SHOW_MARQUEE_PROGRESS_BAR = $0400; + TDF_CALLBACK_TIMER = $0800; + TDF_POSITION_RELATIVE_TO_WINDOW = $1000; + TDF_RTL_LAYOUT = $2000; + TDF_NO_DEFAULT_RADIO_BUTTON = $4000; + TDF_CAN_BE_MINIMIZED = $8000; + + TDM_NAVIGATE_PAGE = WM_USER+101; + TDM_CLICK_BUTTON = WM_USER+102; // wParam = Button ID + TDM_SET_MARQUEE_PROGRESS_BAR = WM_USER+103; // wParam = 0 (nonMarque) wParam != 0 (Marquee) + TDM_SET_PROGRESS_BAR_STATE = WM_USER+104; // wParam = new progress state + TDM_SET_PROGRESS_BAR_RANGE = WM_USER+105; // lParam = MAKELPARAM(nMinRange, nMaxRange) + TDM_SET_PROGRESS_BAR_POS = WM_USER+106; // wParam = new position + TDM_SET_PROGRESS_BAR_MARQUEE = WM_USER+107; // wParam = 0 (stop marquee), wParam != 0 (start marquee), lparam = speed (milliseconds between repaints) + TDM_SET_ELEMENT_TEXT = WM_USER+108; // wParam = element (TASKDIALOG_ELEMENTS), lParam = new element text (LPCWSTR) + TDM_CLICK_RADIO_BUTTON = WM_USER+110; // wParam = Radio Button ID + TDM_ENABLE_BUTTON = WM_USER+111; // lParam = 0 (disable), lParam != 0 (enable), wParam = Button ID + TDM_ENABLE_RADIO_BUTTON = WM_USER+112; // lParam = 0 (disable), lParam != 0 (enable), wParam = Radio Button ID + TDM_CLICK_VERIFICATION = WM_USER+113; // wParam = 0 (unchecked), 1 (checked), lParam = 1 (set key focus) + TDM_UPDATE_ELEMENT_TEXT = WM_USER+114; // wParam = element (TASKDIALOG_ELEMENTS), lParam = new element text (LPCWSTR) + TDM_SET_BUTTON_ELEVATION_REQUIRED_STATE = WM_USER+115; // wParam = Button ID, lParam = 0 (elevation not required), lParam != 0 (elevation required) + TDM_UPDATE_ICON = WM_USER+116; // wParam = icon element (TASKDIALOG_ICON_ELEMENTS), lParam = new icon (hIcon if TDF_USE_HICON_* was set, PCWSTR otherwise) + + TDN_CREATED = 0; + TDN_NAVIGATED = 1; + TDN_BUTTON_CLICKED = 2; // wParam = Button ID + TDN_HYPERLINK_CLICKED = 3; // lParam = (LPCWSTR)pszHREF + TDN_TIMER = 4; // wParam = Milliseconds since dialog created or timer reset + TDN_DESTROYED = 5; + TDN_RADIO_BUTTON_CLICKED = 6; // wParam = Radio Button ID + TDN_DIALOG_CONSTRUCTED = 7; + TDN_VERIFICATION_CLICKED = 8; // wParam = 1 if checkbox checked, 0 if not, lParam is unused and always 0 + TDN_HELP = 9; + TDN_EXPANDO_BUTTON_CLICKED = 10; // wParam = 0 (dialog is now collapsed), wParam != 0 (dialog is now expanded) + + TDCBF_OK_BUTTON = $0001; // selected control return value IDOK + TDCBF_YES_BUTTON = $0002; // selected control return value IDYES + TDCBF_NO_BUTTON = $0004; // selected control return value IDNO + TDCBF_CANCEL_BUTTON = $0008; // selected control return value IDCANCEL + TDCBF_RETRY_BUTTON = $0010; // selected control return value IDRETRY + TDCBF_CLOSE_BUTTON = $0020; // selected control return value IDCLOSE + + PBST_NORMAL = $0001; + PBST_ERROR = $0002; + PBST_PAUSED = $0003; +{ + TD_ICON_BLANK = 100; + TD_ICON_WARNING = 101; + TD_ICON_QUESTION = 102; + TD_ICON_ERROR = 103; + TD_ICON_INFORMATION = 104; + TD_ICON_BLANK_AGAIN = 105; + TD_ICON_SHIELD = 106; +} + // Well, Microsoft did it again, incorrect TD_ICON_xxx values in the SDK + // and changing values just between last beta2 & RTM... Gotta love them. + // These values were obtained emperically by the lack of proper documentation + + TD_ICON_BLANK = 17; + TD_ICON_WARNING = 84; + TD_ICON_QUESTION = 99; + TD_ICON_ERROR = 98; + TD_ICON_INFORMATION = 81; + TD_ICON_BLANK_AGAIN = 0; + TD_ICON_SHIELD = 78; + + +type + TProControl = class(TControl); + + PTASKDIALOG_BUTTON = ^TTASKDIALOG_BUTTON; + TTASKDIALOG_BUTTON = record + nButtonID: integer; + pszButtonText: pwidechar; + end; + + TTaskDialogWideString = array[0..1023] of widechar; + + TTaskDialogButtonArray = array of TTASKDIALOG_BUTTON; + TTaskDialogWideStringArray = array of TTaskDialogWideString; + + PTASKDIALOGCONFIG = ^TTASKDIALOGCONFIG; + TTASKDIALOGCONFIG = record + cbSize: integer; + hwndParent: THandle; + hInstance: THandle; + dwFlags: integer; // TASKDIALOG_FLAGS dwFlags; + dwCommonButtons: integer; // TASKDIALOG_COMMON_BUTTON_FLAGS + pszWindowTitle: pwidechar; + hMainIcon: integer; + pszMainInstruction: pwidechar; + pszContent: pwidechar; + cButtons: integer; + pbuttons: pinteger; // const TASKDIALOG_BUTTON* pButtons; + nDefaultButton: integer; + cRadioButtons: integer; + pRadioButtons: pinteger; //const TASKDIALOG_BUTTON* pRadioButtons; + nDefaultRadioButton: integer; + pszVerificationText: pwidechar; + pszExpandedInformation: pwidechar; + pszExpandedControlText: pwidechar; + pszCollapsedControlText: pwidechar; + case Integer of + 0: (hFooterIcon: HICON); + 1: (pszFooterIcon: pwidechar; + pszFooter: pwidechar; + pfCallback: pinteger; + pData: pointer; + cxWidth: integer // width of the Task Dialog's client area in DLU's. + // If 0, Task Dialog will calculate the ideal width. + ); +{ + hFooterIcon: integer; + pszFooter: pwidechar; + pfCallBack: pinteger; // PFTASKDIALOGCALLBACK pfCallback; + pData: pointer; + cxWidth: integer; +} + end; + +//------------------------------------------------------------------------------ + +procedure RunElevated(HWND: THandle; pszPath, pszParameters, pszDirectory: string); +var + shex : SHELLEXECUTEINFO; +begin + fillchar(shex, sizeof(shex),0); + shex.cbSize := sizeof( SHELLEXECUTEINFO ); + shex.fMask := 0; + shex.wnd := hwnd; + shex.lpVerb := 'runas'; + shex.lpFile := pchar(pszPath); + shex.lpParameters := pchar(pszParameters); + shex.lpDirectory := nil; + shex.nShow := SW_NORMAL; + ShellExecuteEx(@shex); +end; + +//------------------------------------------------------------------------------ + +function IsVista: boolean; +var + hKernel32: HMODULE; +begin + hKernel32 := GetModuleHandle('kernel32'); + if (hKernel32 > 0) then + begin + Result := GetProcAddress(hKernel32, 'GetLocaleInfoEx') <> nil; + end + else + Result := false; +end; + +//------------------------------------------------------------------------------ + +procedure VistaShellOpen(HWND: THandle; Command, Param: string); +begin + if IsVista then + RunElevated(HWND, Command, Param, '') + else + ShellExecute(HWND, 'open', pchar(Param), nil, nil, SW_NORMAL); +end; + +//------------------------------------------------------------------------------ + +function GetFileVersion(const AFileName: string): Cardinal; +var + FileName: string; + InfoSize, Wnd: DWORD; + VerBuf: Pointer; + FI: PVSFixedFileInfo; + VerSize: DWORD; +begin + Result := Cardinal(-1); + // GetFileVersionInfo modifies the filename parameter data while parsing. + // Copy the string const into a local variable to create a writeable copy. + FileName := AFileName; + UniqueString(FileName); + InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd); + if InfoSize <> 0 then + begin + GetMem(VerBuf, InfoSize); + try + if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then + if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then + Result:= FI.dwFileVersionMS; + finally + FreeMem(VerBuf); + end; + end; +end; + + +function TaskDialogCallbackProc(hWnd: THandle; msg, wParam, lparam: integer; refData: pointer): integer; stdcall; +var + td: TAdvTaskDialog; + SPos: integer; + State: TTaskDialogProgressState; + Res: integer; + CanClose: boolean; + Anchor: string; + +begin + td := nil; + if Assigned(refdata) then + td := TAdvTaskDialog(refdata); + + Res := 0; + + if Assigned(td) then + td.hWnd := hWnd; + + case msg of + TDN_CREATED: + begin + if Assigned(td) and Assigned(td.OnDialogCreated) then + begin + td.OnDialogCreated(td); + + if (doProgressBar in td.Options) then + begin + SendMessage(hWnd, TDM_SET_PROGRESS_BAR_RANGE, 0, MakeLParam(td.ProgressBarMin,td.ProgressBarMax)); + end; + end; + end; + TDN_BUTTON_CLICKED: + begin + if Assigned(td) and Assigned(td.OnDialogButtonClick) then + begin + td.OnDialogButtonClick(td, wParam); + end; + + if Assigned(td) and Assigned(td.OnDialogClose) then + begin + CanClose := true; + td.OnDialogClose(td, CanClose); + if not CanClose then + Res := 1; + end; + end; + TDN_RADIO_BUTTON_CLICKED: + begin + if Assigned(td) and Assigned(td.OnDialogRadioClick) then + begin + td.OnDialogRadioClick(td, wParam); + end; + end; + TDN_HYPERLINK_CLICKED: + begin + if Assigned(td) then + begin + Anchor := WideCharToString(PWideChar(lparam)); + + if not Assigned(td.OnDialogHyperlinkClick) then + begin + if (Pos('://', Anchor) > 0) then + VistaShellOpen(0, 'iexplore.exe', Anchor); + end; + + if Assigned(td.OnDialogHyperlinkClick) then + begin + td.OnDialogHyperlinkClick(td, Anchor); + end; + end; + end; + TDN_VERIFICATION_CLICKED: + begin + if Assigned(td) and Assigned(td.OnDialogVerifyClick) then + begin + td.OnDialogVerifyClick(td, bool(wparam)); + end; + end; + TDN_TIMER: + begin + if Assigned(td) and Assigned(td.OnDialogTimer) then + begin + td.OnDialogTimer(td); + end; + + if Assigned(td) and Assigned(td.OnDialogProgress) then + begin + td.OnDialogProgress(td, SPos, State); + SendMessage(hWnd,TDM_SET_PROGRESS_BAR_POS,SPos,0); + case State of + psNormal: SendMessage(hWnd,TDM_SET_PROGRESS_BAR_STATE, PBST_NORMAL, 0); + psError: SendMessage(hWnd,TDM_SET_PROGRESS_BAR_STATE, PBST_ERROR, 0); + psPaused: SendMessage(hWnd,TDM_SET_PROGRESS_BAR_STATE, PBST_PAUSED, 0); + end; + end; + end; + end; + + Result := Res; +end; + +//------------------------------------------------------------------------------ + +function RemoveSpaces(S: String): String; +var + i: Integer; +begin + Result := S; + for i := 1 to Length(s) do + begin + if (s[i] = ' ') then + Result := copy(S, 2, Length(S)-1) + else + Break; + end; + + for i := Length(s) downto 1 do + begin + if (s[i] = ' ') then + Result := copy(S, 1, Length(S)-1) + else + Break; + end; +end; + +//------------------------------------------------------------------------------ + +procedure SplitInToLines(Text: string; sl: TStrings); +var + i, j: Integer; + s, rs: string; +begin + if (Text <> '') and Assigned(sl) then + begin + rs := #13; + if (Pos('\n', Text) > 0) or (pos(rs, Text) > 0) then + begin + Text := RemoveSpaces(Text); + while (Length(Text) > 0) do + begin + i := Pos('\n', Text); + j := 2; + if (i <= 0) then + begin + i := pos(rs, Text); + j := 2; + end; + + if (i <= 0) then + begin + i := Length(Text)+1; + j := 0; + end; + s := copy(Text, 1, i-1); + Delete(Text, 1, i-1+j); + s := RemoveSpaces(s); + sl.Add(s); + Text := RemoveSpaces(Text); + end; + end + else + sl.Add(Text); + end; +end; + +//------------------------------------------------------------------------------ + +procedure GetMultiLineTextSize(Canvas: TCanvas; Text: string; HeadingFont, ParaFont: TFont; DrawTextBiDiModeFlagsReadingOnly: Longint; var W, H: Integer; WithSpace: Boolean = True); +var + R: TRect; + i, tw, th: Integer; + s: string; + OldFont: TFont; + SL: TStringList; +begin + if Assigned(Canvas) then + begin + OldFont := TFont.Create; + OldFont.Assign(Canvas.Font); + if (Pos('\n', Text) > 0) or (pos(#13, Text) > 0) then + begin + tw := 0; + th := 0; + + SL := TStringList.Create; + SplitInToLines(Text, SL); + s := RemoveSpaces(SL[0]); + + if (s <> '') then + begin + Canvas.Font.Assign(HeadingFont); + SetRect(R, 0, 0, 0, 0); + Windows.DrawText( Canvas.handle, PChar(s), -1, R, + DT_CALCRECT or DT_LEFT or DT_SINGLELINE or DrawTextBiDiModeFlagsReadingOnly); + tw := R.Right; + th := R.Bottom; + if WithSpace then + begin + tw := tw + 8; + th := th + 10; + end; + end; + + Canvas.Font.Assign(ParaFont); + for i:= 1 to SL.Count-1 do + begin + s := SL[i]; + if (s <> '') then + begin + SetRect(R, 0, 0, 0, 0); + Windows.DrawText( Canvas.handle, PChar(s), -1, R, + DT_CALCRECT or DT_LEFT or DT_SINGLELINE or DrawTextBiDiModeFlagsReadingOnly); + if WithSpace then + begin + tw := Max(tw, R.Right + 8); + th := th + R.Bottom + 2; + end + else + begin + tw := Max(tw, R.Right); + th := th + R.Bottom; + end; + end; + end; + + W := tw; + H := th; + SL.Free; + end + else + begin + Canvas.Font.Assign(HeadingFont); + SetRect(R, 0, 0, 0, 0); + Windows.DrawText( Canvas.handle, PChar(Text), -1, R, + DT_CALCRECT or DT_LEFT or DT_SINGLELINE or DrawTextBiDiModeFlagsReadingOnly); + W := R.Right; + H := R.Bottom; + end; + + Canvas.Font.Assign(OldFont); + OldFont.Free; + end; +end; + +//------------------------------------------------------------------------------ + +{ TAdvTaskDialog } + +procedure TCustomAdvTaskDialog.Clear; +begin + CommonButtons := []; + RadioButtons.Clear; + CustomButtons.Clear; + Icon := tiBlank; + FooterIcon := tfiBlank; + Instruction := ''; + Title := ''; + Content := ''; + Footer := ''; + VerificationText := ''; + ExpandControlText := ''; + CollapsControlText := ''; + ExpandedText := ''; + DefaultRadioButton := 200; + DefaultButton := 0; + Options := []; + VerifyResult := false; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.ClickButton(ButtonID: integer); +begin + SendMessage(hWnd, TDM_CLICK_BUTTON, ButtonID, 0); + if Assigned(FDialogForm) then + FDialogForm.ClickButton(ButtonID); +end; + +//------------------------------------------------------------------------------ + +constructor TCustomAdvTaskDialog.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FCustomButtons := TStringList.Create; + FRadioButtons := TStringList.Create; + FProgressBarMin := 0; + FProgressBarMax := 100; + FDialogForm := nil; + FApplicationIsParent := true; + FModalParent := 0; + FCustomIcon := TIcon.Create; + FDefaultRadioButton := 200; + FMinFormWidth := 350; + FNonNativeDialog := nndAuto; + FInputType := itNone; + FInputItems := TStringList.Create; +end; + +//------------------------------------------------------------------------------ + +destructor TCustomAdvTaskDialog.Destroy; +begin + FRadioButtons.Free; + FCustomButtons.Free; + FCustomIcon.Free; + FInputItems.Free; + inherited; +end; + +//------------------------------------------------------------------------------ + +function TCustomAdvTaskDialog.CreateButton(AOwner: TComponent): TWinControl; +begin + Result := TButton.Create(AOwner); +end; + +//------------------------------------------------------------------------------ + +function TCustomAdvTaskDialog.CreateRadioButton(AOwner: TComponent): TWinControl; +begin + Result := TRadioButton.Create(AOwner); +end; + +procedure TCustomAdvTaskDialog.SetRadioButtonState(Btn: TWinControl; Checked: boolean); +begin + TRadioButton(Btn).Checked := Checked; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); +begin + with TRadioButton(Btn) do + begin + Name := 'Radio' + inttostr(btnIndex); + Parent := AOwner; + Font.Name := AOwner.Canvas.Font.Name; + Font.Size := 8; + BiDiMode := AOwner.BiDiMode; + OnClick := OnClickEvent; + + { + BoundsRect := TextRect; + Left := FHorzParaMargin + FHorzMargin; //ALeft + FHorzMargin; + Top := Y; + Width := Self.Width - Left - 4; + GetTextSize(Canvas, Caption, k, l); + w := Max(w, Left + k + FHorzMargin + 20); + } + end; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.ElevateButton(ButtonID: integer; + Enabled: boolean); +begin + SendMessage(hWnd, TDM_SET_BUTTON_ELEVATION_REQUIRED_STATE, ButtonID, integer(Enabled)); +end; + +procedure TCustomAdvTaskDialog.EnableButton(ButtonID: integer; Enabled: boolean); +begin + SendMessage(hWnd, TDM_ENABLE_BUTTON, ButtonID, integer(Enabled)); + if Assigned(FDialogForm) then + FDialogForm.EnableButton(ButtonID, Enabled); +end; + +//------------------------------------------------------------------------------ + +function ConvertNL(s: string): string; +begin + if pos('\n',s) > 0 then + begin + Result := StringReplace(s,'\n',#10,[rfReplaceAll]); + end + else + Result := s; + +end; + +//------------------------------------------------------------------------------ + +function TCustomAdvTaskDialog.Execute: integer; +var + verinfo: TOSVersionInfo; + DLLHandle: THandle; + res,radiores: integer; + verify: boolean; + TaskDialogConfig : TTASKDIALOGCONFIG; + TaskDialogIndirectProc : function(AConfig: PTASKDIALOGCONFIG; Res: pinteger; ResRadio: pinteger; VerifyFLag: pboolean): integer cdecl stdcall; +{ + wTitle: TTaskDialogWideString; + wDesc: TTaskDialogWideString; + wContent: TTaskDialogWideString; + wExpanded: TTaskDialogWideString; + wExpandedControl: TTaskDialogWideString; + wCollapsedControl: TTaskDialogWideString; + wFooter: TTaskDialogWideString; + wVerifyText: TTaskDialogWideString; +} + TBA: TTaskDialogButtonArray; + TBWS: TTaskDialogWideStringArray; + i: integer; + + TRA: TTaskDialogButtonArray; + TRWS: TTaskDialogWideStringArray; + ComCtlVersion: integer; + + +begin + Result := -1; + + VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); + GetVersionEx(verinfo); + + ComCtlVersion := GetFileVersion('COMCTL32.DLL'); + ComCtlVersion := (ComCtlVersion shr 16) and $FF; + + if (verinfo.dwMajorVersion >= 6) and (ComCtlVersion > 5) and (FNonNativeDialog = nndAuto) then + begin + // check COMCTL version ... + + DLLHandle := LoadLibrary('comctl32.dll'); + if DLLHandle >= 32 then + begin + @TaskDialogIndirectProc := GetProcAddress(DLLHandle,'TaskDialogIndirect'); + + if Assigned(TaskDialogIndirectProc) then + begin + FillChar(TaskDialogConfig, sizeof(TTASKDIALOGCONFIG),0); + TaskDialogConfig.cbSize := sizeof(TTASKDIALOGCONFIG); + + if ModalParent <> 0 then + begin + TaskDialogConfig.hwndParent := ModalParent + end + else + begin + if Assigned(Self.Owner) and not ApplicationIsParent then + TaskDialogConfig.hwndParent := (Self.Owner as TWinControl).Handle + else + TaskDialogConfig.hwndParent := Application.Handle; + end; + + if FCustomButtons.Count > 0 then + begin + SetLength(TBA, FCustomButtons.Count); + SetLength(TBWS, FCustomButtons.Count); + + for i := 0 to FCustomButtons.Count - 1 do + begin + StringToWideChar(ConvertNL(FCustomButtons.Strings[i]), TBWS[i], sizeof(TBWS[i])); + TBA[i].pszButtonText := TBWS[i]; + TBA[i].nButtonID := i + 100; + end; + + TaskDialogConfig.cButtons := FCustomButtons.Count; + TaskDialogConfig.pbuttons := @TBA[0]; + end; + + if FRadioButtons.Count > 0 then + begin + SetLength(TRA, FRadioButtons.Count); + SetLength(TRWS, FRadioButtons.Count); + + for i := 0 to FRadioButtons.Count - 1 do + begin + StringToWideChar(ConvertNL(FRadioButtons.Strings[i]), TRWS[i], sizeof(TRWS[i])); + TRA[i].pszButtonText := TRWS[i]; + TRA[i].nButtonID := i + 200; + end; + + TaskDialogConfig.cRadioButtons := FRadioButtons.Count; + TaskDialogConfig.pRadioButtons := @TRA[0]; + end; + + if FTitle <> '' then + begin + TaskDialogConfig.pszWindowTitle := PWideChar(WideString(ConvertNL(FTitle))); + end; + + if FInstruction <> '' then + begin + TaskDialogConfig.pszMainInstruction := PWideChar(WideString(ConvertNL(FInstruction))); + end; + + if FContent <> '' then + begin + TaskDialogConfig.pszContent := PWideChar(WideString(ConvertNL(FContent))); + end; + + if FFooter <> '' then + begin + TaskDialogConfig.pszFooter := PWideChar(WideString(ConvertNL(FFooter))); + end; + + if FExpandControlText <> '' then + begin + TaskDialogConfig.pszExpandedControlText := PWideChar(WideString(FExpandControlText)); + end; + + if FCollapsControlText <> '' then + begin + TaskDialogConfig.pszCollapsedControlText := PWideChar(WideString(FCollapsControlText)); + end; + + if FExpandedText <> '' then + begin + TaskDialogConfig.pszExpandedInformation := PWideChar(WideString(FExpandedText)) + end; + + if FVerifyText <> '' then + begin + TaskDialogConfig.pszVerificationText := PWideChar(WideString(FVerifyText)); + end; + + if cbOk in FCommonButtons then + TaskDialogConfig.dwCommonButtons := TaskDialogConfig.dwCommonButtons or TDCBF_OK_BUTTON; + + if cbYes in FCommonButtons then + TaskDialogConfig.dwCommonButtons := TaskDialogConfig.dwCommonButtons or TDCBF_YES_BUTTON; + + if cbNo in FCommonButtons then + TaskDialogConfig.dwCommonButtons := TaskDialogConfig.dwCommonButtons or TDCBF_NO_BUTTON; + + if cbCancel in FCommonButtons then + TaskDialogConfig.dwCommonButtons := TaskDialogConfig.dwCommonButtons or TDCBF_CANCEL_BUTTON; + + if cbClose in FCommonButtons then + TaskDialogConfig.dwCommonButtons := TaskDialogConfig.dwCommonButtons or TDCBF_CLOSE_BUTTON; + + if cbRetry in FCommonButtons then + TaskDialogConfig.dwCommonButtons := TaskDialogConfig.dwCommonButtons or TDCBF_RETRY_BUTTON; + + if doCommandLinks in FOptions then + TaskDialogConfig.dwFlags := TDF_USE_COMMAND_LINKS; + + if doCommandLinksNoIcon in FOptions then + TaskDialogConfig.dwFlags := TDF_USE_COMMAND_LINKS_NO_ICON; + + if doHyperlinks in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_ENABLE_HYPERLINKS; + + if doExpandedDefault in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_EXPANDED_BY_DEFAULT; + + if doExpandedFooter in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_EXPAND_FOOTER_AREA; + + if doAllowMinimize in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_CAN_BE_MINIMIZED; + + if doVerifyChecked in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_VERIFICATION_FLAG_CHECKED; + + if doProgressBar in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_SHOW_PROGRESS_BAR; + + if doProgressBarMarquee in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_SHOW_MARQUEE_PROGRESS_BAR; + + if (doProgressBarMarquee in FOptions) or + (doProgressBar in FOptions) or + (doTimer in FOptions) then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_CALLBACK_TIMER; + + if (DialogPosition = dpOwnerFormCenter) then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_POSITION_RELATIVE_TO_WINDOW; + + if doNoDefaultRadioButton in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_NO_DEFAULT_RADIO_BUTTON; + + if doAllowDialogCancel in FOptions then + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_ALLOW_DIALOG_CANCELLATION; + + TaskDialogConfig.hInstance := 0; + + if not CustomIcon.Empty then + begin + TaskDialogConfig.hMainIcon := CustomIcon.Handle; + TaskDialogConfig.dwFlags := TaskDialogConfig.dwFlags or TDF_USE_HICON_MAIN; + end + else + begin + case Icon of + tiWarning: TaskDialogConfig.hMainIcon := TD_ICON_WARNING; + tiQuestion: TaskDialogConfig.hMainIcon := TD_ICON_QUESTION; + tiError: TaskDialogConfig.hMainIcon := TD_ICON_ERROR; + tiShield: TaskDialogConfig.hMainIcon := TD_ICON_SHIELD; + tiBlank: TaskDialogConfig.hMainIcon := TD_ICON_BLANK; + tiInformation: TaskDialogConfig.hMainIcon := TD_ICON_INFORMATION; + end; + end; + + case FooterIcon of + tfiWarning: TaskDialogConfig.hFooterIcon := TD_ICON_WARNING; + tfiQuestion: TaskDialogConfig.hFooterIcon := TD_ICON_QUESTION; + tfiError: TaskDialogConfig.hFooterIcon := TD_ICON_ERROR; + tfiInformation: TaskDialogConfig.hFooterIcon := THandle(MAKEINTRESOURCEW(Word(-3))); + tfiShield: TaskDialogConfig.hFooterIcon := THandle(MAKEINTRESOURCEW(Word(-4))); + end; + + TaskDialogConfig.pfCallBack := @TaskDialogCallbackProc; + TaskDialogConfig.pData := Self; + + TaskDialogConfig.nDefaultButton := DefaultButton; + TaskDialogConfig.nDefaultRadioButton := DefaultRadioButton; + + + TaskDialogIndirectProc(@TaskDialogConfig, @res, @radiores, @verify); + + RadioButtonResult := radiores; + VerifyResult := verify; + Result := res; + + end; + end; + end + else + Result := AdvMessageDlgPos(Self, -1, -1); +end; + +//------------------------------------------------------------------------------ + +function TCustomAdvTaskDialog.GetVersion: string; +var + vn: Integer; +begin + vn := GetVersionNr; + Result := IntToStr(Hi(Hiword(vn))) + '.' + IntToStr(Lo(Hiword(vn))) + '.' + + IntToStr(Hi(Loword(vn))) + '.' + IntToStr(Lo(Loword(vn))); +end; + +//------------------------------------------------------------------------------ + +function TCustomAdvTaskDialog.GetVersionNr: Integer; +begin + Result := MakeLong(MakeWord(BLD_VER, REL_VER), MakeWord(MIN_VER, MAJ_VER)); +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetContent(const Value: string); +begin + if (FContent <> Value) then + begin + FContent := Value; + SendMessage(hWnd, TDM_UPDATE_ELEMENT_TEXT, TDE_CONTENT, Integer(PWideChar(WideString(FContent)))); + if Assigned(FDialogForm) then + FDialogForm.UpdateDialog; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetCustomButtons(const Value: TStringList); +begin + FCustomButtons.Assign(Value); +end; + +procedure TCustomAdvTaskDialog.SetCustomIcon(const Value: TIcon); +begin + FCustomIcon.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetExpandedText(const Value: string); +begin + if (FExpandedText <> Value) then + begin + FExpandedText := Value; + SendMessage(hWnd, TDM_UPDATE_ELEMENT_TEXT, TDE_EXPANDED_INFORMATION, Integer(PWideChar(WideString(FExpandedText)))); + if Assigned(FDialogForm) then + FDialogForm.UpdateDialog; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetFooter(const Value: string); +begin + if (FFooter <> Value) then + begin + FFooter := Value; + SendMessage(hWnd, TDM_UPDATE_ELEMENT_TEXT, TDE_FOOTER, Integer(PWideChar(WideString(FFooter)))); + if Assigned(FDialogForm) then + FDialogForm.UpdateDialog; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetInputItems(const Value: TStrings); +begin + FInputItems.Assign(Value); +end; + +procedure TCustomAdvTaskDialog.SetInstruction(const Value: string); +begin + if (FInstruction <> Value) then + begin + FInstruction := Value; + SendMessage(hWnd, TDM_UPDATE_ELEMENT_TEXT, TDE_MAIN_INSTRUCTION, Integer(PWideChar(WideString(FInstruction)))); + if Assigned(FDialogForm) then + FDialogForm.UpdateDialog; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetRadioButtonCaption(Btn: TWinControl; + Value: string); +begin + TRadioButton(Btn).Caption := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetRadioButtons(const Value: TStringList); +begin + FRadioButtons.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetVersion(const Value: string); +begin + +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetButtonCancel(aButton: TWinControl; Value: Boolean); +begin + if not Assigned(aButton) or not (aButton is TButton) then + Exit; + + TButton(aButton).Cancel := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetButtonDefault(aButton: TWinControl; Value: Boolean); +begin + if not Assigned(aButton) or not (aButton is TButton) then + Exit; + + TButton(aButton).Default := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetButtonModalResult(aButton: TWinControl; Value: Integer); +begin + if not Assigned(aButton) or not (aButton is TButton) then + Exit; + + TButton(aButton).ModalResult := Value; +end; + +//------------------------------------------------------------------------------ + +function TCustomAdvTaskDialog.GetButtonModalResult( + aButton: TWinControl): Integer; +begin + Result := mrNone; + if not Assigned(aButton) or not (aButton is TButton) then + Exit; + + Result := TButton(aButton).ModalResult; +end; + +//------------------------------------------------------------------------------ + +procedure TCustomAdvTaskDialog.SetButtonCaption(aButton: TWinControl; + Value: TCaption); +begin + if not Assigned(aButton) or not (aButton is TButton) then + Exit; + + TButton(aButton).Caption := Value; +end; + +//------------------------------------------------------------------------------ + +{ TTaskDialogButton } + +constructor TTaskDialogButton.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FGlyph := TBitmap.Create; + FGlyph.OnChange := OnPictureChanged; + + FGlyphHot := TBitmap.Create; + + FGlyphDown := TBitmap.Create; + + FGlyphDisabled := TBitmap.Create; + FGlyphDisabled.OnChange := OnPictureChanged; + + FHeadingFont := TFont.Create; + + SetBounds(0, 0, 23, 22); + ShowHint := False; + FBorderColorDown := clNone; + FBorderColorHot := clNone; + FBorderColor := clNone; +end; + +//------------------------------------------------------------------------------ + +destructor TTaskDialogButton.Destroy; +begin + FGlyph.Free; + FGlyphHot.Free; + FGlyphDown.Free; + FGlyphDisabled.Free; + FHeadingFont.Free; + inherited; +end; + +procedure TTaskDialogButton.DoEnter; +begin + inherited; + Invalidate; +end; + +procedure TTaskDialogButton.DoExit; +begin + inherited; + Invalidate; +end; + +procedure TTaskDialogButton.KeyPress(var Key: char); +begin + inherited; + if (Key = #32) or (Key = #13) then + begin + Click; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.Paint; +var + Pic: TBitmap; + x, y, bw, bh, i: Integer; + R, TR: TRect; + BrClr: TColor; + SL: TStringList; +begin + inherited; + + R := ClientRect; + + BrClr := clNone; + + if FMouseDown then + BrClr := BorderColorDown + else if FMouseInControl then + BrClr := BorderColorHot; + + if not Enabled then + BrClr := clNone; + + if GetFocus = Handle then + BrClr := BorderColorDown; + + Pic := Picture; + if FMouseDown and not FGlyphDown.Empty then + Pic := FGlyphDown + else if FMouseInControl and not FGlyphHot.Empty then + Pic := FGlyphHot; + + if not Enabled and not PictureDisabled.Empty then + Pic := PictureDisabled; + + if Assigned(Pic) and not Pic.Empty then + begin + Pic.Transparent := True; + if (Caption = '') then + begin + x := (Width - Pic.Width) div 2; + y := (Height - Pic.Height) div 2; + end + else + begin + x := 4; + y := (Height - Pic.Height) div 2; + end; + + Canvas.Draw(x, y, Pic); + R.Left := x + Pic.Width + 3; + end + else + R.Left := R.Left + 2; + + if (Caption <> '') then + begin + if (Pos('\n', Caption) > 0) or (pos(#13, Caption) > 0) then + begin + TR := R; + SL := TStringList.Create; + SplitInToLines(Caption, SL); + GetMultiLineTextSize(Canvas, Caption, HeadingFont, Self.Font, DrawTextBiDiModeFlagsReadingOnly, bw, bh); + TR.Top := 2 + (Height - bh) div 2; + + Canvas.Brush.Style := bsClear; + if (SL[0] <> '') then + begin + Canvas.Font.Assign(HeadingFont); + + if not Enabled then + Canvas.Font.Color := clSilver; + + DrawText(Canvas.Handle, PChar(SL[0]),Length(SL[0]), TR, DT_LEFT or DT_TOP or DT_SINGLELINE); + TR.Top := TR.Top + Canvas.TextHeight('gh') + 4; + end; + + Canvas.Font.Assign(Self.Font); + + if not Enabled then + Canvas.Font.Color := clSilver; + + for i:= 1 to SL.Count - 1 do + begin + DrawText(Canvas.Handle, PChar(SL[i]),Length(SL[i]), TR, DT_LEFT or DT_TOP or DT_SINGLELINE); + TR.Top := TR.Top + Canvas.TextHeight('gh') + 2; + end; + SL.Free; + end + else + begin + Canvas.Brush.Style := bsClear; + Canvas.Font.Assign(HeadingFont); + if not Enabled then + Canvas.Font.Color := clSilver; + DrawText(Canvas.Handle,PChar(Caption),Length(Caption), R, DT_LEFT or DT_VCENTER or DT_SINGLELINE); + end; + end; + + if (BrClr <> clNone) then + begin + R := ClientRect; + Canvas.Pen.Color := BrClr; + Canvas.Brush.Style := bsClear; + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 2, 2); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.MouseDown(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + inherited; + + if (ssLeft in Shift) then + begin + FMouseDown := True; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + inherited; + +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.MouseUp(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + inherited; + + FMouseDown := False; + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.SetGlyph(const Value: TBitmap); +begin + FGlyph.Assign(Value); + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.SetGlyphDown(const Value: TBitmap); +begin + FGlyphDown.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.SetGlyphHot(const Value: TBitmap); +begin + FGlyphHot.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.SetGlyphDisabled(const Value: TBitmap); +begin + FGlyphDisabled.Assign(Value); + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.OnPictureChanged(Sender: TObject); +begin + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.CMMouseEnter(var Message: TMessage); +begin + inherited; + FMouseInControl := True; + + if AutoFocus then + SetFocus; + + Invalidate; + if Assigned(FOnMouseEnter) then + FOnMouseEnter(Self); +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.CMMouseLeave(var Message: TMessage); +begin + inherited; + FMouseInControl := False; + Invalidate; + + if Assigned(FOnMouseLeave) then + FOnMouseLeave(Self); +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.SetHeadingFont(const Value: TFont); +begin + FHeadingFont.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +function GetAveCharSize(Canvas: TCanvas): TPoint; +var + I: Integer; + Buffer: array[0..51] of Char; +begin + for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A')); + for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a')); + GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result)); + Result.X := Result.X div 52; +end; + +//------------------------------------------------------------------------------ + +var + ButtonWidths : array[TCommonButton] of integer; // initialized to zero + ButtonCaptions: array[TCommonButton] of Pointer; // = ( + // @SMsgDlgOK, @SMsgDlgYes, @SMsgDlgNo, @SMsgDlgCancel, @SMsgDlgRetry, @SMsgDlgAbort); + // ButtonNames: array[TCommonButton] of string = ('OK', 'Yes', 'No', 'Cancel', 'Retry', 'Abort'); + //tiBlank, tiWarning, tiQuestion, tiError, tiInformation,tiNotUsed,tiShield + IconIDs: array[TTaskDialogIcon] of PChar = (IDI_ASTERISK, IDI_EXCLAMATION, IDI_QUESTION, IDI_ERROR, IDI_INFORMATION, nil, IDI_HAND); + FooterIconIDs: array[TTaskDialogFooterIcon] of PChar = (nil, IDI_EXCLAMATION, IDI_QUESTION, IDI_HAND, IDI_INFORMATION, IDI_WINLOGO); + Captions: array[TTaskDialogIcon] of Pointer; + // = (nil, @SMsgDlgWarning, @SMsgDlgConfirm, @SMsgDlgError, @SMsgDlgInformation); + ModalResults: array[TCommonButton] of Integer = (mrOk, mrYes, mrNo, mrCancel, mrRetry, mrAbort); + //(tiBlank, tiWarning, tiQuestion, tiError, tiShield); + //(mtWarning, mtError, mtInformation, mtConfirmation, mtCustom); + +function CreateAdvMessageDlg(TaskDialog: TCustomAdvTaskDialog): TForm; +begin + Result := nil; + if not Assigned(TaskDialog) then + Exit; + + if TaskDialog.ApplicationIsParent then + Result := TAdvMessageForm.CreateNew(Application,0) + else + Result := TAdvMessageForm.CreateNew((TaskDialog.Owner) as TCustomForm,0); + + with Result do + begin + BiDiMode := Application.BiDiMode; + + if doAllowMinimize in TaskDialog.Options then + begin + BorderStyle := bsSingle; + BorderIcons := [biSystemMenu,biMinimize] + end + else + begin + BorderStyle := bsDialog; + BorderIcons := []; + end; + // FormStyle := fsStayOnTop; + Canvas.Font := Font; + KeyPreview := True; + OnKeyDown := TAdvMessageForm(Result).CustomKeyDown; + end; + TAdvMessageForm(Result).MinFormWidth := TaskDialog.NonNativeMinFormWidth; + TAdvMessageForm(Result).BuildTaskDialog(TaskDialog); +end; + +//------------------------------------------------------------------------------ + +function AdvMessageDlgPos(TaskDialog: TCustomAdvTaskDialog; X, Y: Integer): Integer; +var + DlgForm: TAdvMessageForm; +begin + Result := -1; + if not Assigned(TaskDialog) then + Exit; + + DlgForm := TAdvMessageForm(CreateAdvMessageDlg(TaskDialog)); + + TaskDialog.FDialogForm := DlgForm; + if Assigned(TaskDialog.OnDialogCreated) then + TaskDialog.OnDialogCreated(TaskDialog); + + with DlgForm do + try + Color := clWhite; + //HelpContext := HelpCtx; + //HelpFile := HelpFileName; + if X >= 0 then Left := X; + if Y >= 0 then Top := Y; + {$IFDEF DELPHI5_LVL} + if TaskDialog.DialogPosition = dpOwnerFormCenter then + begin + DefaultMonitor := dmMainForm; + if (Y < 0) and (X < 0) then Position := poOwnerFormCenter; + end + else + begin + if (Y < 0) and (X < 0) then Position := poScreenCenter; + end; + {$ELSE} + {$ENDIF} + Result := ShowModal; + {$IFDEF DELPHI5_LVL} + Close; + {$ENDIF} + finally + TaskDialog.FDialogForm := nil; + Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.GetTextSize(Canvas: TCanvas; Text: string;var W, H: Integer); +var + R: TRect; +begin + if (Text = '') then + begin + W := 0; + H := 0; + Exit; + end; + + if Assigned(Canvas) then + begin + if W = 0 then + SetRect(R, 0, 0, 1000, 100) + else + SetRect(R, 0, 0, W, 100); + + DrawText(Canvas.Handle, PChar(Text), Length(Text)+1, R, + DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or DT_NOPREFIX or + DrawTextBiDiModeFlagsReadingOnly); + + W := R.Right; + H := R.Bottom; + end; +end; + +//------------------------------------------------------------------------------ + +const + mcHorzMargin = 8; + mcVertMargin = 8; + mcHorzSpacing = 10; + mcVertSpacing = 10; + mcButtonWidth = 50; + mcButtonHeight = 14; + mcButtonSpacing = 4; + +function GetExeName: string; +var + s: string; + fe: string; +begin + s := ExtractFileName(Application.EXEName); + fe := ExtractFileExt(s); + if (Length(fe) > 0) then + delete(s, length(s) - Length(fe) + 1, length(fe)); + Result := s; +end; + +procedure TAdvMessageForm.BuildTaskDialog(TaskDialog: TCustomAdvTaskDialog); +var + DialogUnits: TPoint; + ButtonWidth, ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth, + IconTextWidth, IconTextHeight, X, Y, ALeft: Integer; + B, DefaultButton, CancelButton: TCommonButton; + IconID: PChar; + TextRect, FR: TRect; + Msg: string; + DlgType: TTaskDialogIcon; + Buttons: TCommonButtons; + i, bw, bh, h, w, j, FooterIconTextWidth, FooterIconTextHeight: Integer; + CmBtnGroupWidth, CsBtnGroupWidth: Integer; + r, re: trect; + anchor, stripped: string; + HyperLinks,MouseLink, k, l, n: Integer; + Focusanchor: string; + OldFont, hf, pf: TFont; + verifTextWidth: Integer; + v: Boolean; + szContent,szExpandedText,szFooterText: string; + defIdx: integer; + +begin + if not Assigned(TaskDialog) then + Exit; + + FTaskDialog := TaskDialog; + Msg := TaskDialog.Instruction; + DlgType := TaskDialog.Icon; + Buttons := TaskDialog.CommonButtons; + + OldFont := TFont.Create; + OldFont.Assign(Canvas.Font); + + DialogUnits := GetAveCharSize(Canvas); + FHorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4); + FVertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8); + FHorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4); + FVertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8); + + w := 0; + + if TaskDialog.Title <> '' then + Caption := TaskDialog.Title + else + Caption := GetExeName; + + if (Caption <> '') then + begin + w := 1000; + GetTextSize(Canvas, Caption, w, l); + w := w + 50; + end; + + ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4); + ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8); + ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4); + CmBtnGroupWidth := 0; + CsBtnGroupWidth := 0; + ButtonCount := 0; + FHorzParaMargin := FHorzMargin; + Y := FVertMargin; + FcmBtnList.Clear; + + if TaskDialog.DefaultButton <> -1 then + begin + + if TaskDialog.DefaultButton = 0 then + begin + if (cbOk in Buttons) then DefaultButton := cbOk else + if cbYes in Buttons then DefaultButton := cbYes else + DefaultButton := cbRetry; + if cbCancel in Buttons then CancelButton := cbCancel else + if cbNo in Buttons then CancelButton := cbNo else + CancelButton := cbOk; + end + else + begin + case TaskDialog.DefaultButton of + 1: if (cbOk in Buttons) then DefaultButton := cbOK + else + DefaultButton := cbYes; + 2: if (cbCancel in Buttons) then DefaultButton := cbCancel + else + DefaultButton := cbNo; + 6: if (cbYes in Buttons) then DefaultButton := cbYes; + 7: if (cbNo in Buttons) then DefaultButton := cbNo; + end; + end; + end; + + + for B := Low(TCommonButton) to High(TCommonButton) do + begin + if B in Buttons then + begin + if ButtonWidths[B] = 0 then + begin + TextRect := Rect(0,0,0,0); + Windows.DrawText( Canvas.Handle, + PChar(LoadResString(ButtonCaptions[B])), -1, + TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or + DrawTextBiDiModeFlagsReadingOnly); + with TextRect do + ButtonWidths[B] := Right - Left + 16; + end; + + if ButtonWidths[B] > ButtonWidth then + ButtonWidth := ButtonWidths[B]; + + i := FcmBtnList.Add(TaskDialog.CreateButton(Self)); + + with TWinControl(FcmBtnList.Items[i]) do + begin + Name := ButtonNames[B]; + Parent := Self; + TaskDialog.SetButtonCaption(TWinControl(FcmBtnList.Items[i]), LoadResString(ButtonCaptions[B])); + TaskDialog.SetButtonModalResult(TWinControl(FcmBtnList.Items[i]), ModalResults[B]); + //ModalResult := ModalResults[B]; + + if (TaskDialog.GetButtonModalResult(TWinControl(FcmBtnList.Items[i])) = mrCancel) and + (doAllowDialogCancel in TaskDialog.Options) then + TaskDialog.SetButtonCancel(TWinControl(FcmBtnList.Items[i]), True); + //Cancel := true; + + if (TaskDialog.DefaultButton <> -1) then + begin + if (B = DefaultButton) then + begin + //Default := True; + TaskDialog.SetButtonDefault(TWinControl(FcmBtnList.Items[i]), True); + TabOrder := 0; + end; + end; + + if (B = CancelButton) and (doAllowDialogCancel in TaskDialog.Options) then + TaskDialog.SetButtonCancel(TWinControl(FcmBtnList.Items[i]), True); + + Width := Max(60, ButtonWidths[B]); + Height := ButtonHeight; + cmBtnGroupWidth := cmBtnGroupWidth + Width + ButtonSpacing; + //if B = mbHelp then + //OnClick := TMessageForm(Result).HelpButtonClick; + if TaskDialog.DefaultButton = -1 then + TabStop := false; + end; + //Inc(ButtonCount); + end; + end; + + FcsBtnList.Clear; + if not (docommandLinks in TaskDialog.Options) then + begin + for i := 0 to TaskDialog.CustomButtons.Count - 1 do + begin + TextRect := Rect(0,0,0,0); + Windows.DrawText( Canvas.Handle, + PChar(TaskDialog.CustomButtons[i]), -1, + TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or + DrawTextBiDiModeFlagsReadingOnly); + + with TextRect do bw := Right - Left + 16; + if bw > ButtonWidth then + ButtonWidth := bw; + + j := FcsBtnList.Add(TaskDialog.CreateButton(Self)); + with TWinControl(FcsBtnList.Items[j]) do + begin + Name := 'Button'+inttostr(i); + Parent := Self; + TaskDialog.SetButtonCaption(TWinControl(FcsBtnList.Items[j]), TaskDialog.CustomButtons[i]); + //ModalResult := i + 100; //mrAbort; + TaskDialog.SetButtonModalResult(TWinControl(FcsBtnList.Items[j]), i + 100); + v := (TaskDialog.GetButtonModalResult(TWinControl(FcsBtnList.Items[j])) = TaskDialog.DefaultButton); + TaskDialog.SetButtonDefault(TWinControl(FcsBtnList.Items[j]), V); + //Default := (ModalResult = TaskDialog.DefaultButton); + //if V then + // TabOrder := 0; + //if B = DefaultButton then Default := True; + //if B = CancelButton then Cancel := True; + Width := Max(60, bw); + Height := ButtonHeight; + TProControl(FcsBtnList.Items[j]).OnClick := OnButtonClick; + CsBtnGroupWidth := CsBtnGroupWidth + Width + ButtonSpacing; + if TaskDialog.DefaultButton = -1 then + TabStop := false; + end; + end; + end + else + begin + n := 0; + hf := TFont.Create; + pf := TFont.Create; + hf.Assign(Canvas.Font); + hf.Size := 11; + hf.Style := [fsBold]; + pf.Assign(Canvas.Font); + + + for i := 0 to TaskDialog.CustomButtons.Count-1 do + begin + Canvas.Font.Size := 10; + Canvas.Font.Style := []; + bw := 0; + bh := 0; + GetMultiLineTextSize(Canvas, TaskDialog.CustomButtons[i], Hf, Pf, DrawTextBiDiModeFlagsReadingOnly, bw, bh); + + {TextRect := Rect(0,0,0,0); + Windows.DrawText( Canvas.handle, + PChar(TaskDialog.CustomButtons[i]), -1, + TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or + DrawTextBiDiModeFlagsReadingOnly); + with TextRect do bw := (Right - Left) + 8 + 18;} + bw := bw + 26; + if bw > ButtonWidth then + ButtonWidth := bw; + + if bw > n then + n := bw; + + if not (doCommandLinksNoIcon in TaskDialog.Options) then + w := Max(w, n + FHorzMargin*2 + FHorzSpacing + 32) + else + w := Max(w, n + FHorzMargin); + + j := FcsBtnList.Add(TTaskDialogButton.Create(Self)); + with TTaskDialogButton(FcsBtnList.Items[j]) do + begin + Name := 'Button'+inttostr(i); + Parent := Self; + Caption := TaskDialog.CustomButtons[i]; + Font.Assign(pf); + Font.Color := RGB(0, 83, 196); + HeadingFont.Assign(hf); + HeadingFont.Color := RGB(0, 83, 196);//RGB(21, 28, 85); + ModalResult := i + 100; //mrAbort; + //Default := (ModalResult = TaskDialog.DefaultButton); + BorderColorHot := RGB(108, 225, 255); + BorderColorDown := RGB(108, 225, 255); + Width := Max(60, n); + if TaskDialog.DefaultButton <> -1 then + AutoFocus := true; + + Height := Max(bh, Max(ButtonHeight, Canvas.TextHeight('gh') + 20)); + + if not (doCommandLinksNoIcon in TaskDialog.Options) then + begin + Picture.LoadFromResourceName(HInstance, 'TD_ARW'); + Picture.TransparentColor := clFuchsia; + + PictureHot.LoadFromResourceName(HInstance, 'TD_ARWHOT'); + PictureHot.TransparentColor := clFuchsia; + + PictureDown.LoadFromResourceName(HInstance, 'TD_ARWDOWN'); + PictureDown.TransparentColor := clFuchsia; + + PictureDisabled.LoadFromResourceName(HInstance, 'TD_ARWDIS'); + PictureDisabled.TransparentColor := clFuchsia; + end; + + if TaskDialog.DefaultButton = -1 then + TabStop := false + else + TabStop := true; + + OnClick := OnButtonClick; + //CsBtnGroupWidth := CsBtnGroupWidth + Width + ButtonSpacing; + end; + + end; + Canvas.Font.Assign(OldFont); + hf.Free; + pf.Free; + end; + + // if no button then OK button is added + if (FcmBtnList.Count = 0) and (FcsBtnList.Count = 0) then + begin + b := cbOK; + TextRect := Rect(0,0,0,0); + Windows.DrawText( canvas.handle, + PChar(LoadResString(ButtonCaptions[B])), -1, + TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or + DrawTextBiDiModeFlagsReadingOnly); + with TextRect do ButtonWidths[B] := Right - Left + 8; + + //if ButtonWidths[B] > ButtonWidth then + //ButtonWidth := ButtonWidths[B]; + + i := FcmBtnList.Add(TaskDialog.CreateButton(Self)); + with TWinControl(FcmBtnList.Items[i]) do + begin + Name := ButtonNames[B]; + Parent := Self; + TaskDialog.SetButtonCaption(TWinControl(FcmBtnList.Items[i]), LoadResString(ButtonCaptions[B])); + TaskDialog.SetButtonModalResult(TWinControl(FcmBtnList.Items[i]), ModalResults[B]); + //ModalResult := ModalResults[B]; + //Default := True; + TaskDialog.SetButtonDefault(TWinControl(FcmBtnList.Items[i]), True); + //Cancel := True; // handle ESC + + if doAllowDialogCancel in TaskDialog.Options then + TaskDialog.SetButtonCancel(TWinControl(FcmBtnList.Items[i]), True); + + Width := Max(60, ButtonWidths[B]); + Height := ButtonHeight; + cmBtnGroupWidth := cmBtnGroupWidth + Width + ButtonSpacing; + //if B = mbHelp then + //OnClick := TMessageForm(Result).HelpButtonClick; + end; + end; + + // Instruction + Canvas.Font.Size := 11; + Canvas.Font.Style := [fsBold]; + + SetRect(TextRect, 0, 0, Screen.Width div 2, 0); + DrawText(Canvas.Handle, PChar(Msg), Length(Msg) + 1, TextRect, + DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or + DrawTextBiDiModeFlagsReadingOnly); + + Canvas.Font.Assign(OldFont); + + IconID := IconIDs[DlgType]; + + IconTextWidth := TextRect.Right; + IconTextHeight := TextRect.Bottom; + if IconID <> nil then + begin + Inc(IconTextWidth, 32 + FHorzSpacing); + if IconTextHeight < 32 then IconTextHeight := 32; + end; + + {if DlgType <> tiBlank then + Caption := LoadResString(Captions[DlgType]) else + Caption := Application.Title;} + + if ((IconID <> nil) or not (TaskDialog.CustomIcon.Empty)) {and not (doCommandLinksNoIcon in TaskDialog.Options)} then + begin + FIcon := TImage.Create(Self); + with FIcon do + begin + Name := 'Image'; + Parent := Self; + + if not TaskDialog.CustomIcon.Empty then + begin + Picture.Icon.Assign(TaskDialog.CustomIcon); + end + else + begin + + case TaskDialog.Icon of + tiShield: Picture.Bitmap.Handle := LoadBitmap(hInstance, 'TD_SHIELD'); + tiBlank: + begin + Picture.Bitmap.Height := 32; + Picture.Bitmap.Width := 32; + Picture.Bitmap.Canvas.Brush.Color := clWhite; + Picture.Bitmap.Canvas.Pen.Style := psClear; + Picture.Bitmap.Canvas.Rectangle(0,0,31,31); + end; + else + Picture.Icon.Handle := LoadIcon(0, IconID); + end; + end; + + SetBounds(FHorzMargin, Y, 32, 32); + end; + end; + + Message := TLabel.Create(Self); + with Message do + begin + Name := 'Instr'; + Parent := Self; + {$IFDEF DELPHI7_LVL} + WordWrap := True; + {$ENDIF} + Caption := Msg; + Font.Size := 11; + Font.Color := RGB(0, 83, 196); + Font.Style := [fsBold]; + BoundsRect := TextRect; + BiDiMode := Self.BiDiMode; + ShowAccelChar := false; + ALeft := IconTextWidth - TextRect.Right + FHorzMargin; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - Width; + SetBounds(ALeft, Y, + TextRect.Right, TextRect.Bottom); + y := Y + Height + FVertSpacing; + FHorzParaMargin := ALeft; + end; + + if (doTimer in TaskDialog.Options) then + begin + FTimer := TTimer.Create(Self); + FTimer.Interval := 100; + FTimer.OnTimer := OnTimer; + FTimer.Enabled := True; + end; + + if (doProgressBar in TaskDialog.Options) then + begin + FProgressBar := TProgressBar.Create(Self); + with FProgressBar do + begin + Name := 'ProgressBar'; + Parent := Self; + BoundsRect := Rect(FHorzMargin, Y, Width - FHorzMargin, Y + 12); + Min := TaskDialog.ProgressBarMin; + Max := TaskDialog.ProgressBarMax; + Position := 0; + end; + + if not Assigned(FTimer) then + begin + FTimer := TTimer.Create(Self); + FTimer.Interval := 100; + FTimer.OnTimer := OnTimer; + FTimer.Enabled := True; + end; + end; + + if (TaskDialog.RadioButtons.Count > 0) then + begin + if (doNodefaultRadioButton in FTaskDialog.Options) then + FTaskDialog.RadioButtonResult := 0 + else + FTaskDialog.RadioButtonResult := FTaskDialog.DefaultRadioButton; + + for i := 0 to TaskDialog.RadioButtons.Count-1 do + begin + j := FRadioList.Add(FTaskDialog.CreateRadioButton(Self)); + + TaskDialog.InitRadioButton(self, TWinControl(FRadioList.Items[j]), i, OnRadioClick); + + with TWinControl(FRadioList.Items[j]) do + begin + (* + Name := 'Radio' + inttostr(i); + Parent := Self; + Font.Name := Canvas.Font.Name; + Font.Size := 8; + {$IFDEF DELPHI7_LVL} + //WordWrap := False; + {$ENDIF} + OnClick := OnRadioClick; + BiDiMode := Self.BiDiMode; + *) + + BoundsRect := TextRect; + Left := FHorzParaMargin + FHorzMargin; //ALeft + FHorzMargin; + Top := Y; + Width := Self.Width - Left - 4; + GetTextSize(Canvas, Caption, k, l); + w := Max(w, Left + k + FHorzMargin + 20); + end; + + TaskDialog.SetRadioButtonCaption(FRadioList.Items[j],TaskDialog.RadioButtons[i]); + + if doNoDefaultRadioButton in TaskDialog.Options then + TaskDialog.SetRadioButtonState(FRadioList.Items[j], False) + else + begin + if (TaskDialog.DefaultRadioButton > 0) then + TaskDialog.SetRadioButtonState(FRadioList.Items[j], (j + 200 = TaskDialog.DefaultRadioButton)) + else + begin + TaskDialog.SetRadioButtonState(FRadioList.Items[j], (i = 0)); + end; + end; + + (* + with TRadioButton(FRadioList.Items[j]) do + begin + if doNoDefaultRadioButton in TaskDialog.Options then + Checked := False + else + begin + if (TaskDialog.DefaultRadioButton > 0) then + Checked := (j + 200 = TaskDialog.DefaultRadioButton) + else + begin + Checked := (i = 0); + end; + end; + end; + *) + end; + end; + + if (TaskDialog.ExpandedText <> '') then + begin + (*FExpandLabel := TLabel.Create(Self); + with FExpandLabel do + begin + Name := 'Expand'; + Parent := Self; + {$IFDEF DELPHI7_LVL} + WordWrap := True; + {$ENDIF} + ShowAccelChar := false; + BiDiMode := Self.BiDiMode; + FExpandLabel.Caption := TaskDialog.ExpandedText; + Left := ALeft; + Top := Y; + end; *) + + FExpTextXSize := 0; + FExpTextYSize := 0; + r := Rect(FHorzMargin, Y, 300, Y + 26); + + + if (doHyperlinks in FTaskDialog.Options) then + begin + szExpandedText := StringReplace(FTaskDialog.ExpandedText,'\n','
',[rfReplaceAll]); + szExpandedText := StringReplace(szExpandedText,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szExpandedText, r, nil, x, y, -1, -1, 1, true, false, false, true, true, false, true, + 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, FExpTextXSize, FExpTextYSize, hyperlinks, + mouselink, re, nil, nil, 0); + end + else + begin + szExpandedText := StringReplace(FTaskDialog.ExpandedText,'\n',#13,[rfReplaceAll]); + + FExpTextXSize := r.Right - r.Left; + //szContent := StringReplace(FTaskDialog.Content,'\n',#13,[rfReplaceAll]); + //GetTextSize(Canvas, szContent, FExpTextXSize, FExpTextYSize); + + GetTextSize(Canvas, szExpandedText, FExpTextXSize, FExpTextYSize); + end; + + FExpandButton := TTaskDialogButton.Create(Self); + with FExpandButton do + begin + Name := 'ExpandButton'; + Parent := Self; + Caption := ''; + ModalResult := mrNone; + Width := 19; + Height := 19; + OnClick := OnExpandButtonClick; + Picture.LoadFromResourceName(HInstance, 'TD_COLP'); + Picture.TransparentColor := clFuchsia; + + PictureHot.LoadFromResourceName(HInstance, 'TD_COLPHOT'); + PictureHot.TransparentColor := clFuchsia; + + PictureDown.LoadFromResourceName(HInstance, 'TD_COLPDOWN'); + PictureDown.TransparentColor := clFuchsia; + end; + end; + + verifTextWidth := 0; + if (TaskDialog.VerificationText <> '') then + begin + k := 0; + FVerificationCheck := TCheckBox.Create(Self); + with FVerificationCheck do + begin + Name := 'Verification'; + Parent := Self; + {$IFDEF DELPHI7_LVL} + WordWrap := False; + {$ENDIF} + BoundsRect := TextRect; + BiDiMode := Self.BiDiMode; + Caption := TaskDialog.VerificationText; + Left := FHorzMargin; + Top := Y; + Color := RGB(240, 240, 240); + OnClick := OnVerifyClick; + Checked := (doVerifyChecked in TaskDialog.Options); + GetTextSize(Canvas, Caption, k, l); + verifTextWidth := k + FVertSpacing *2; + w := Max(w, Left + k); + end; + end; + + FFooterXSize := 0; + FFooterYSize := 0; + if (TaskDialog.Footer <> '') then + begin + r := Rect(FHorzMargin, Y, 300, Y + 26); + + szFooterText := StringReplace(FTaskDialog.Footer,'\n','
',[rfReplaceAll]); + szFooterText := StringReplace(szFooterText,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szFooterText, r, nil, x, y, -1, -1, 1, true, false, false, true, true, false, true, + 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, FFooterXSize, FFooterYSize, hyperlinks, + mouselink, re, nil, nil, 0); + + IconID := FooterIconIDs[TaskDialog.FooterIcon]; + FooterIconTextWidth := TextRect.Right; + FooterIconTextHeight := TextRect.Bottom; + if IconID <> nil then + begin + Inc(FooterIconTextWidth, 24 + FHorzSpacing); + if FooterIconTextHeight < 24 then FooterIconTextHeight := 24; + end; + + if IconID <> nil then + begin + FFooterIcon := TImage.Create(Self); + FFooterIconID := IconID; + + with FFooterIcon do + begin + Name := 'FooterImage'; + Parent := Self; + Visible := False; + SetBounds(FHorzMargin, Y, 16, 16); + end; + end; + end; + + ButtonGroupWidth := CmBtnGroupWidth + CsBtnGroupWidth + verifTextWidth; + if (TaskDialog.ExpandedText <> '') and Assigned(FExpandButton) then + begin + k := 0; + l := 0; + GetTextSize(Canvas, FTaskDialog.CollapsControlText, k, l); + GetTextSize(Canvas, FTaskDialog.ExpandControlText, n, l); + k := Max(k, n); + ButtonGroupWidth := ButtonGroupWidth + FExpandButton.Width + FHorzSpacing + k + FHorzSpacing; + end; + + if TaskDialog.Content = '' then + Y := Y - 20; + + case TaskDialog.InputType of + itEdit: + begin + FInputEdit := TEdit.Create(self); + FInputEdit.Parent := Self; + FInputEdit.TabStop := true; + FInputEdit.Text := TaskDialog.InputText; + + ALeft := IconTextWidth - TextRect.Right + FHorzMargin; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - Width; + + FInputEdit.SetBounds(ALeft, Y + 20, ClientWidth - ALeft, 20); + end; + itComboEdit, itComboList: + begin + FInputCombo := TComboBox.Create(self); + FInputCombo.Parent := Self; + FInputCombo.TabStop := true; + FInputCombo.Text := TaskDialog.InputText; + FInputCombo.Items.Assign(TaskDialog.InputItems); + + if TaskDialog.InputType = itComboList then + begin + FInputCombo.Style := csDropDownList; + FInputCombo.ItemIndex := FInputCombo.Items.IndexOf(TaskDialog.InputText); + end; + + ALeft := IconTextWidth - TextRect.Right + FHorzMargin; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - Width; + + FInputCombo.SetBounds(ALeft, Y + 20, ClientWidth - ALeft, 20); + end; + itDate: + begin + FInputDate := TDateTimePicker.Create(self); + FInputDate.Parent := Self; + FInputDate.TabStop := true; + ALeft := IconTextWidth - TextRect.Right + FHorzMargin; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - Width; + + FInputDate.Top := Y + 20; + FInputDate.Left := ALeft; + end; + itMemo: + begin + FInputMemo := TMemo.Create(self); + FInputMemo.Parent := Self; + FInputMemo.TabStop := true; + FInputMemo.WantReturns := false; + FInputMemo.Lines.Text := TaskDialog.InputText; + ALeft := IconTextWidth - TextRect.Right + FHorzMargin; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - Width; + FInputMemo.SetBounds(ALeft, Y + 20, ClientWidth - ALeft, 60); + end; + itCustom: + begin + if Assigned(TaskDialog.InputControl) then + begin + FOldParent := TaskDialog.InputControl.Parent; + TaskDialog.InputControl.Parent := self; + TaskDialog.InputControl.Visible := true; + if Assigned(TaskDialog.OnDialogInputSetText) then + TaskDialog.OnDialogInputSetText(TaskDialog, TaskDialog.InputText) + else + SetWindowText(TaskDialog.InputControl.Handle, Pchar(TaskDialog.InputText)); + + ALeft := IconTextWidth - TextRect.Right + FHorzMargin; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - Width; + TaskDialog.InputControl.SetBounds(ALeft, Y + 20, ClientWidth - ALeft, 20); + end; + end; + end; + + //-- setting Form Width + k := Max(FFooterXSize, Max(IconTextWidth, ButtonGroupWidth)) + FHorzMargin * 2; + k := Max(FExpTextXSize + FHorzMargin * 2, k); + w := Max(w, k); + w := Max(w, FMinFormWidth); + + if w > (Screen.Width - 2 * GetSystemMetrics(SM_CYEDGE)) then + w := Screen.Width - 2 * GetSystemMetrics(SM_CYEDGE); +// if w > 800 then +// w := 800; + + ClientWidth := w; + + if (doProgressBar in TaskDialog.Options) then + begin + FProgressBar.Width := ClientWidth - FHorzMargin*2; + end; + + SetPositions; + + if (TaskDialog.ExpandedText <> '') then + begin + SetExpanded((doExpandedDefault in TaskDialog.Options)); + end; + + Left := (Screen.Width div 2) - (Width div 2); + Top := (Screen.Height div 2) - (Height div 2); + OldFont.Free; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.UpdateDialog; +var + DialogUnits: TPoint; + ButtonSpacing, ButtonGroupWidth, IconTextWidth, X, Y: Integer; + IconID: PChar; + TextRect: TRect; + Msg: string; + DlgType: TTaskDialogIcon; + Buttons: TCommonButtons; + i, w: Integer; + CmBtnGroupWidth, CsBtnGroupWidth: Integer; + r, re: trect; + anchor, stripped: string; + HyperLinks,MouseLink, k, l, n: Integer; + Focusanchor,szFooterText: string; + OldFont: TFont; +begin + if not Assigned(FTaskDialog) then + Exit; + + Msg := FTaskDialog.Instruction; + DlgType := FTaskDialog.Icon; + Buttons := FTaskDialog.CommonButtons; + + OldFont := TFont.Create; + OldFont.Assign(Canvas.Font); + + DialogUnits := GetAveCharSize(Canvas); + w := 0; + + if FTaskDialog.Title <> '' then + Caption := FTaskDialog.Title + else + Caption := GetExeName; + + + if (Caption <> '') then + begin + w := 1000; + GetTextSize(Canvas, Caption, w, l); + w := w + 50; + end; + + ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4); + CmBtnGroupWidth := 0; + CsBtnGroupWidth := 0; + Y := FVertMargin; + //ALeft := 0; + + for i := 0 to FcmBtnList.Count-1 do + begin + CmBtnGroupWidth := CmBtnGroupWidth + TButton(FcmBtnList.Items[i]).Width + ButtonSpacing; + end; + + if not (docommandLinks in FTaskDialog.Options) then + begin + for i := 0 to FcsBtnList.Count-1 do + begin + CsBtnGroupWidth := CsBtnGroupWidth + TButton(FcsBtnList.Items[i]).Width + ButtonSpacing; + end; + end + else + begin + + end; + + // Instruction + Canvas.Font.Size := 11; + Canvas.Font.Style := [fsBold]; + + SetRect(TextRect, 0, 0, Screen.Width div 2, 0); + DrawText(Canvas.Handle, PChar(Msg), Length(Msg) + 1, TextRect, + DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or + DrawTextBiDiModeFlagsReadingOnly); + + Canvas.Font.Assign(OldFont); + + + IconID := IconIDs[DlgType]; + IconTextWidth := TextRect.Right; + if (IconId <> nil) then + begin + Inc(IconTextWidth, 32 + FHorzSpacing); + end; + + if Assigned(Message) then + begin + Message.Caption := Msg; + //ALeft := IconTextWidth - TextRect.Right + FHorzMargin; + //if UseRightToLeftAlignment then + //ALeft := Self.ClientWidth - ALeft - Width; + y := Y + Height + FVertSpacing; + end; + + if (FTaskDialog.RadioButtons.Count > 0) then + begin + FTaskDialog.RadioButtonResult := FTaskDialog.DefaultRadioButton; + + for i := 0 to FRadioList.Count - 1 do + begin + with TRadioButton(FRadioList.Items[i]) do + begin + BoundsRect := TextRect; + Left := FHorzParaMargin + FHorzMargin; + Top := Y; + Width := Self.Width - Left - 4; + GetTextSize(Canvas, Caption, k, l); + w := Max(w, Left + k + FHorzMargin + 20); + end; + end; + end; + + {if (FTaskDialog.ExpandedText <> '') and Assigned(FExpandLabel) then + begin + with FExpandLabel do + begin + Left := ALeft; + Top := Y; + FExpandLabel.Caption := FTaskDialog.ExpandedText; + end; + end; } + + if (FTaskDialog.VerificationText <> '') and Assigned(FVerificationCheck) then + begin + k := 0; + with FVerificationCheck do + begin + BoundsRect := TextRect; + Caption := FTaskDialog.VerificationText; + Left := FHorzMargin; + Top := Y; + GetTextSize(Canvas, Caption, k, l); + w := Max(w, Left + k); + end; + end; + + FFooterXSize := 0; + FFooterYSize := 0; + if (FTaskDialog.Footer <> '') then + begin + r := Rect(FHorzMargin, Y, 300, Y + 26); + x := 0; + szFooterText := StringReplace(FTaskDialog.Footer,'\n','
',[rfReplaceAll]); + szFooterText := StringReplace(szFooterText,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szFooterText, r, nil, x, y, -1, -1, 1, true, false, false, true, true, false, true, + 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, FFooterXSize, FFooterYSize, hyperlinks, + mouselink, re, nil, nil, 0); + + if Assigned(FFooterIcon) then + begin + FFooterIcon.SetBounds(FHorzMargin, Y, 16, 16); + end; + end; + + ButtonGroupWidth := CmBtnGroupWidth + CsBtnGroupWidth; + if (FTaskDialog.ExpandedText <> '') and Assigned(FExpandButton) then + begin + k := 0; + l := 0; + GetTextSize(Canvas, FTaskDialog.CollapsControlText, k, l); + GetTextSize(Canvas, FTaskDialog.ExpandControlText, n, l); + k := Max(k, n); + ButtonGroupWidth := ButtonGroupWidth + FExpandButton.Width + FHorzSpacing + k + FHorzSpacing; + end; + + + //-- setting Form Width + k := Max(FFooterXSize, Max(IconTextWidth, ButtonGroupWidth)) + FHorzMargin * 2; + w := Max(w, k); + w := Max(w, FMinFormWidth); + + + ClientWidth := w; + + if (doProgressBar in FTaskDialog.Options) and Assigned(FProgressBar) then + begin + FProgressBar.Width := ClientWidth - FHorzMargin*2; + end; + + SetPositions; + + OldFont.Free; + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.SetPositions; +var + DialogUnits: TPoint; + HorzMargin, VertMargin, VertSpacing, ButtonSpacing, ButtonGroupWidth, X, Y: Integer; + i, h: Integer; + CmBtnGroupWidth, CsBtnGroupWidth, BtnH: Integer; + X1, y1: Integer; + r, re, rc: trect; + anchor, stripped: string; + HyperLinks,MouseLink: Integer; + Focusanchor: string; + ExpTextTop, verifTextWidth, k, l: Integer; + szContent: string; + szExpandedText,szFooterText: string; + //lbl:TLabel; + //ExH: integer; +begin + if not Assigned(FTaskDialog) then + Exit; + + DialogUnits := GetAveCharSize(Canvas); + HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4); + VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8); + VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8); + ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4); + CmBtnGroupWidth := 0; + CsBtnGroupWidth := 0; + Y := VertMargin; + + {$IFDEF DELPHI7_LVL} + Message.Transparent := true; + {$ENDIF} + + // Instruction Label + if (Message.Caption <> '') then + y := Y + Message.Height + VertSpacing + else + Message.Visible := False; + + if (FTaskDialog.Content <> '') then + begin + //FContent.Width := ClientWidth - FContent.Left - HorzMargin; + //FContent.Top := Y; + //Y := Y + FContent.Height + VertSpacing; + X1 := 0; + Y1 := 0; + r := GetContentRect; + r := Rect(r.Left, Y, R.Right, Y + 26); + + if (doHyperlinks in FTaskDialog.Options) then + begin + szContent := StringReplace(FTaskDialog.Content,'\n','
',[rfReplaceAll]); + szContent := StringReplace(szContent,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szContent, r, nil, x1, y1, -1, -1, 1, true, true, false, true, true, false, true, + 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, FContentXSize, FContentYSize, hyperlinks, + mouselink, re, nil, nil, 0); + end + else + begin + szContent := StringReplace(FTaskDialog.Content,'\n',#13,[rfReplaceAll]); + { + if (Message.Caption <> '') then + FContentXSize := Message.Width + else + FContentXSize := 360; + + if FContentXSize < 360 then + FContentXSize := 360; + } + FContentXSize := r.Right - r.Left; + GetTextSize(Canvas, szContent, FContentXSize, FContentYSize); + end; + + rc := GetContentRect; + if (fContentXSize > rc.Right - rc.Left) then + ClientWidth := ClientWidth + (fContentXSize - (rc.Right - rc.Left)); + + y1 := FContentYSize; + if (Message.Caption = '') and Assigned(FIcon) then + begin + y1 := Max(FIcon.Height, Y1); + end; + + Y := Y + Y1 + VertSpacing; + + case FTaskDialog.InputType of + itEdit: FInputEdit.Top := Y - 10; + itComboEdit,itComboList: FInputCombo.Top := Y - 10; + itDate: FInputDate.Top := Y - 10; + itMemo: FInputMemo.Top := Y - 10; + itCustom: if Assigned(FTaskDialog.InputControl) then + FTaskDialog.InputControl.Top := Y - 10; + end; + + end + else + begin + if (FTaskDialog.RadioButtons.Count = 0) and not (doCommandLinks in FTaskDialog.Options) then + Y := Y + VertSpacing; + + if (Message.Caption = '') and Assigned(FIcon) then + Y := Y + VertSpacing + VertMargin; + end; + + if (FTaskDialog.InputType in [itEdit, itComboEdit, itComboList, itDate, itCustom]) then + begin + Y := Y + 30; + end; + + if (FTaskDialog.InputType in [itMemo]) then + begin + Y := Y + 70; + end; + + + if (doProgressBar in FTaskDialog.Options) then + begin + if Assigned(FIcon) then + begin + Y := Max(Y, FIcon.Top + FIcon.Height+3); + end; + FProgressBar.Top := Y; + Y := Y + FProgressBar.Height + VertSpacing; + end; + + if (FTaskDialog.RadioButtons.Count > 0) then + begin + for i:= 0 to FRadioList.Count-1 do + begin + TRadioButton(FRadioList.Items[i]).Top := Y; + TRadioButton(FRadioList.Items[i]).Width := ClientWidth - TRadioButton(FRadioList.Items[i]).Left - HorzMargin; + Y := Y + TRadioButton(FRadioList.Items[i]).Height + 4; + end; + Y := Y + VertSpacing - 4; + end; + + FExpTextXSize := 0; + FExpTextYSize := 0; + ExpTextTop := 0; + if (FTaskDialog.ExpandedText <> '') then + begin + if FExpanded then + begin + (*lbl := TLabel.Create(self); + {$IFDEF DELPHI7_LVL} + lbl.WordWrap := true; + {$ENDIF} + lbl.Width := ClientWidth - FExpandLabel.Left - HorzMargin; + lbl.Caption := FTaskDialog.FExpandedText; + ExH := lbl.Height; + lbl.Free; + + FExpandLabel.Top := Y; + FExpandLabel.Width := ClientWidth - FExpandLabel.Left - HorzMargin; + FExpandLabel.Height := ExH; + + Y := Y + FExpandLabel.Height + VertSpacing; + FExpandLabel.Visible := True; + *) + + + X1 := 0; + Y1 := 0; + r := GetExpTextRect; + r := Rect(r.Left, Y, R.Right, Y + 26); + + if (doHyperlinks in FTaskDialog.Options) then + begin + szExpandedText := StringReplace(FTaskDialog.ExpandedText,'\n','
',[rfReplaceAll]); + szExpandedText := StringReplace(szExpandedText,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szExpandedText, r, nil, x1, y1, -1, -1, 1, true, true, false, true, true, false, true, + 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, FExpTextXSize, FExpTextYSize, hyperlinks, + mouselink, re, nil, nil, 0); + end + else + begin + szExpandedText := StringReplace(FTaskDialog.ExpandedText,'\n',#13,[rfReplaceAll]); + + FExpTextXSize := r.Right - r.Left; + GetTextSize(Canvas, szExpandedText, FExpTextXSize, FExpTextYSize); + end; + + ExpTextTop := Y; + FExpTextTop := ExpTextTop; + Y := Y + FExpTextYSize + VertSpacing; + end + else + begin + //FExpandLabel.Visible := False; + end; + end; + + if not (docommandLinks in FTaskDialog.Options) then + begin + for i:= 0 to FcsBtnList.Count-1 do + begin + CsBtnGroupWidth := CsBtnGroupWidth + TButton(FcsBtnList.Items[i]).Width{ + ButtonSpacing}; + end; + + if (FcsBtnList.Count > 0) then + CsBtnGroupWidth := CsBtnGroupWidth + (FcsBtnList.Count-1) * ButtonSpacing; + end + else + begin + for i:= 0 to FcsBtnList.Count-1 do + begin + if Assigned(FIcon) then + TTaskDialogButton(FcsBtnList.Items[i]).Left := FHorzParaMargin; // FIcon.Left + FIcon.Width + FHorzSpacing; + TTaskDialogButton(FcsBtnList.Items[i]).Top := Y; + TTaskDialogButton(FcsBtnList.Items[i]).Width := ClientWidth - TTaskDialogButton(FcsBtnList.Items[i]).Left - HorzMargin; + Y := Y + TTaskDialogButton(FcsBtnList.Items[i]).Height + 2; + end; + FWhiteWindowHeight := Y; + Y := Y + VertSpacing; + end; + + for i := 0 to FcmBtnList.Count-1 do + begin + CmBtnGroupWidth := CmBtnGroupWidth + TButton(FcmBtnList.Items[i]).Width{ + ButtonSpacing}; + end; + CmBtnGroupWidth := CmBtnGroupWidth + (FcmBtnList.Count-1) * ButtonSpacing; + + verifTextWidth := 0; + if (FTaskDialog.VerificationText <> '') then + begin + GetTextSize(Canvas, FTaskDialog.VerificationText, k, l); + verifTextWidth := k + FVertSpacing * 2; + end; + + ButtonGroupWidth := CsBtnGroupWidth + CmBtnGroupWidth; + + X := (ClientWidth - ButtonGroupWidth - FHorzSpacing - 4); //(ClientWidth - ButtonGroupWidth) div 2; + h := Y; + BtnH := 0; + + if (FTaskDialog.ExpandedText <> '') then + begin + X := (ClientWidth - ButtonGroupWidth - FHorzSpacing - 4); + { + k := 0; + l := 0; + GetTextSize(Canvas, FTaskDialog.CollapsControlText, k, l); + GetTextSize(Canvas, FTaskDialog.ExpandControlText, n, l); + k := Max(k, n); + ButtonGroupWidth := ButtonGroupWidth + FExpandButton.Width + ButtonSpacing + k + FHorzSpacing; + } + end; + + if (FTaskDialog.ExpandedText <> '') then + begin + with FExpandButton do + begin + Top := Y; + Left := FVertMargin; //X; + //Inc(X, FExpandButton.Width + ButtonSpacing); + if (FExpandButton.Height > BtnH) then + BtnH := FExpandButton.Height; + end; + end; + + if (FTaskDialog.VerificationText <> '') and Assigned(FVerificationCheck) then + begin + FVerificationCheck.Width := verifTextWidth - FVertSpacing; //ClientWidth - FVerificationCheck.Left - HorzMargin; + FVerificationCheck.Top := Y + BtnH; + FVerificationCheck.Left := FVertMargin + 3; + //X := FVerificationCheck.Left + FVerificationCheck.Width + FVertMargin; + end; + + if not (docommandLinks in FTaskDialog.Options) then + begin + for i:= 0 to FcsBtnList.Count-1 do + begin + with TButton(FcsBtnList.Items[i]) do + begin + Top := Y; + Left := X; + Inc(X, TButton(FcsBtnList.Items[i]).Width + ButtonSpacing); + //if (i = 0) then + //h := h + TButton(FcsBtnList.Items[i]).Height; + if (TButton(FcsBtnList.Items[i]).Height > BtnH) then + BtnH := TButton(FcsBtnList.Items[i]).Height; + end; + end; + if (FcsBtnList.Count > 0) then + FWhiteWindowHeight := TButton(FcsBtnList.items[0]).Top{ - (FVertSpacing div 2)}; + end; + + for i := 0 to FcmBtnList.Count-1 do + begin + with TButton(FcmBtnList.Items[i]) do + begin + Top := Y; + Left := X; + Inc(X, TButton(FcmBtnList.Items[i]).Width + ButtonSpacing); + //if (i = 0) then + //h := h + TButton(FcmBtnList.Items[i]).Height; + if (TButton(FcmBtnList.Items[i]).Height > BtnH) then + BtnH := TButton(FcmBtnList.Items[i]).Height; + end; + + if (FcmBtnList.Count > 0) then + FWhiteWindowHeight := TButton(FcmBtnList.items[0]).Top{ - (FVertSpacing div 2)}; + end; + + if (FTaskDialog.VerificationText <> '') and Assigned(FVerificationCheck) then + begin + h := h + Max(BtnH, FVerificationCheck.Height + VertSpacing); + y := y + Max(BtnH + FVertSpacing, FVerificationCheck.Height + VertSpacing); + end + else + begin + h := h + BtnH; + if (BtnH > 0) then + y := y + BtnH + FVertSpacing; + end; + + if (FTaskDialog.Footer <> '') then + begin + X1 := 0; + Y1 := 0; + if Assigned(FFooterIcon) then + r := Rect(HorzMargin + 20, Y, Width - HorzMargin, Y + 100) + else + r := Rect(HorzMargin, Y, Width - HorzMargin, Y + 100); + + szFooterText := StringReplace(FTaskDialog.Footer,'\n','
',[rfReplaceAll]); + szFooterText := StringReplace(szFooterText,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szFooterText, r, nil, x1, y1, -1, -1, 1, true, false, false, true, true, false, true, + 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, FFooterXSize, FFooterYSize, hyperlinks, + mouselink, re, nil, nil, 0); + + y1 := FFooterYSize; + if Assigned(FFooterIcon) then + begin + FFooterIcon.Top := Y; + y1 := Max(Y1, 20); + end; + h := h + Y1 + VertSpacing; + end; + + h := h + VertMargin; + ClientHeight := h; + if (FcmBtnList.Count = 0) and ((docommandLinks in FTaskDialog.Options) or (not (docommandLinks in FTaskDialog.Options) and (FcsBtnList.Count = 0))) then + FWhiteWindowHeight := Height; + + if (ExpTextTop > 0) and (doExpandedFooter in FTaskDialog.Options) then + FWhiteWindowHeight := ExpTextTop; +end; + +//------------------------------------------------------------------------------ + +constructor TAdvMessageForm.CreateNew(AOwner: TComponent; Dummy: Integer); +var + NonClientMetrics: TNonClientMetrics; +begin + inherited CreateNew(AOwner); + NonClientMetrics.cbSize := sizeof(NonClientMetrics); + if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then + Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont); + + FExpandButton := nil; + FExpanded := true; + //FExpandLabel := nil; + FExpandControlText := ''; + FCollapsControlText := ''; + FcmBtnList := TList.Create; + FcsBtnList := TList.Create; + FRadioList := TList.Create; + FFooterXSize := 0; + FFooterYSize := 0; + FWhiteWindowHeight := Height; + FHorzParaMargin := 0; + FMinFormWidth := 350; +end; + +//------------------------------------------------------------------------------ + +{procedure TAdvMessageForm.HelpButtonClick(Sender: TObject); +begin + Application.HelpContext(HelpContext); +end;} + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if ((ssAlt in Shift) and (Key = VK_F4)) then + Key := 0; + + if (Shift = [ssCtrl]) and (Key = Word('C')) then + begin + Beep; + WriteToClipBoard(GetFormText); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.WMActivate(var M: TWMActivate); +begin + SetWindowPos ( Handle, HWND_TOPMOST, 0,0,0,0, SWP_NOMOVE or SWP_NOSIZE ); +end; + +procedure TAdvMessageForm.WriteToClipBoard(Text: String); +var + Data: THandle; + DataPtr: Pointer; +begin + if OpenClipBoard(0) then + begin + try + Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, Length(Text) + 1); + try + DataPtr := GlobalLock(Data); + try + Move(PChar(Text)^, DataPtr^, Length(Text) + 1); + EmptyClipBoard; + SetClipboardData(CF_TEXT, Data); + finally + GlobalUnlock(Data); + end; + except + GlobalFree(Data); + raise; + end; + finally + CloseClipBoard; + end; + end + else + raise Exception.CreateRes(@SCannotOpenClipboard); +end; + +//------------------------------------------------------------------------------ + +function TAdvMessageForm.GetFormText: String; +var + DividerLine, ButtonCaptions: string; + I: integer; +begin + DividerLine := StringOfChar('-', 27) + sLineBreak; + for I := 0 to ComponentCount - 1 do + if Components[I] is TButton then + ButtonCaptions := ButtonCaptions + TButton(Components[I]).Caption + + StringOfChar(' ', 3); + ButtonCaptions := StringReplace(ButtonCaptions,'&','', [rfReplaceAll]); + Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, sLineBreak, + DividerLine, Message.Caption, sLineBreak, DividerLine, ButtonCaptions, + sLineBreak, DividerLine]); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.SetExpandButton(const Value: TTaskDialogButton); +begin + if Assigned(FExpandButton) then + FExpandButton.OnClick := nil; + + FExpandButton := Value; + + if Assigned(FExpandButton) then + FExpandButton.OnClick := OnExpandButtonClick; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.OnExpandButtonClick(Sender: TObject); +begin + if Assigned(FExpandButton) then + begin + SetExpanded(not Expanded); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.SetExpanded(Value: Boolean); +begin + if FExpanded then + begin + if not Value then + begin + FExpandButton.Picture.LoadFromResourceName(HInstance, 'TD_EXP'); + FExpandButton.Picture.TransparentColor := clFuchsia; + FExpandButton.PictureHot.LoadFromResourceName(HInstance, 'TD_EXPHOT'); + FExpandButton.PictureHot.TransparentColor := clFuchsia; + FExpandButton.PictureDown.LoadFromResourceName(HInstance, 'TD_EXPDOWN'); + FExpandButton.PictureDown.TransparentColor := clFuchsia; + end; + end + else + begin + if Value then + begin + FExpandButton.Picture.LoadFromResourceName(HInstance, 'TD_COLP'); + FExpandButton.Picture.TransparentColor := clFuchsia; + FExpandButton.PictureHot.LoadFromResourceName(HInstance, 'TD_COLPHOT'); + FExpandButton.PictureHot.TransparentColor := clFuchsia; + FExpandButton.PictureDown.LoadFromResourceName(HInstance, 'TD_COLPDOWN'); + FExpandButton.PictureDown.TransparentColor := clFuchsia; + end; + end; + FExpanded := Value; + SetPositions; + Invalidate; +end; + +//------------------------------------------------------------------------------ + +destructor TAdvMessageForm.Destroy; +begin + FcmBtnList.Free; + FcsBtnList.Free; + FRadioList.Free; + if Assigned(FTimer) then + FTimer.Free; + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.DrawExpandedText; +var + r, re: trect; + anchor, stripped: string; + HyperLinks,MouseLink: Integer; + Focusanchor: string; + xsize, ysize: Integer; + szExpandedText: string; +begin + if not Assigned(FTaskDialog) or (not FExpanded) then + Exit; + + R := GetExpTextRect; + if (FTaskDialog.ExpandedText <> '') then + begin + + if (doHyperlinks in FTaskDialog.Options) then + begin + szExpandedText := StringReplace(FTaskDialog.ExpandedText,'\n','
',[rfReplaceAll]); + szExpandedText := StringReplace(szExpandedText,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szExpandedText, R, nil, 0, 0, -1, -1, 1, false, false, false, false, False, false, + true, 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, xsize, ysize, + hyperlinks, mouselink, re, nil , nil, 0); + end + else + begin + szExpandedText := StringReplace(FTaskDialog.ExpandedText,'\n',#13,[rfReplaceAll]); + + DrawText(Canvas.Handle,PChar(szExpandedText),Length(szExpandedText), R, DT_EXPANDTABS or DT_LEFT or DT_VCENTER or DT_WORDBREAK or DT_NOPREFIX); + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.DrawContent; +var + r, re: trect; + anchor, stripped: string; + HyperLinks,MouseLink: Integer; + Focusanchor: string; + xsize, ysize: Integer; + szContent: string; +begin + if not Assigned(FTaskDialog) then + Exit; + + R := GetContentRect; + if (FTaskDialog.Content <> '') then + begin + + if (doHyperlinks in FTaskDialog.Options) then + begin + szContent := StringReplace(FTaskDialog.Content,'\n','
',[rfReplaceAll]); + szContent := StringReplace(szContent,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szContent, R, nil, 0, 0, -1, -1, 1, false, false, false, false, False, false, + true, 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, xsize, ysize, + hyperlinks, mouselink, re, nil , nil, 0); + end + else + begin + szContent := StringReplace(FTaskDialog.Content,'\n',#13,[rfReplaceAll]); + DrawText(Canvas.Handle,PChar(szContent),Length(szContent), R, DT_EXPANDTABS or DT_LEFT or DT_VCENTER or DT_WORDBREAK or DT_NOPREFIX); + end; + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvMessageForm.GetContentRect: TRect; +var + X, Y: Integer; +begin + Result := Rect(-1, -1, -1, -1); + if Assigned(FTaskDialog) and (FTaskDialog.Content <> '') then + begin + X := FHorzMargin; + if Assigned(FIcon) then + X := FIcon.Left + FIcon.Width + FHorzSpacing; + if (Message.Caption <> '') then + Y := Message.Top + Message.Height + FVertSpacing + else + Y := FVertMargin; + Result := Rect(X, Y, ClientWidth - FHorzMargin, Y + FContentYSize); + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvMessageForm.GetExpTextRect: TRect; +var + X, Y: Integer; +begin + Result := Rect(-1, -1, -1, -1); + if Assigned(FTaskDialog) and FExpanded then + begin + X := FHorzMargin; + if Assigned(FIcon) then + X := FIcon.Left + FIcon.Width + FHorzSpacing; + {if (Message.Caption <> '') then + Y := Message.Top + Message.Height + FVertSpacing + else + Y := FVertMargin; + + if (FTaskDialog.Content <> '') then + y := Y + FContentYSize + FVertSpacing; + + if (doProgressBar in FTaskDialog.Options) then + begin + if Assigned(FIcon) then + begin + Y := Max(Y, FIcon.Top + FIcon.Height+3); + end; + + if Assigned(FProgressBar) then + Y := Y + FProgressBar.Height + FVertSpacing; + end; + + if (FTaskDialog.RadioButtons.Count > 0) then + begin + if (FRadioList.Count > 0) then + Y := Y + TRadioButton(FRadioList.Items[FRadioList.Count-1]).Height + FVertSpacing; + end;} + Y := FExpTextTop; + + Result := Rect(X, Y, ClientWidth - FHorzMargin, Y + FExpTextYSize); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.DrawFooter; +var + r, re: trect; + anchor, stripped: string; + HyperLinks,MouseLink: Integer; + Focusanchor: string; + xsize, ysize, i: Integer; + bmp: TBitmap; + shieldbmp: TBitmap; + IconH: THandle; + szFooterText: string; + +begin + if not Assigned(FTaskDialog) then + Exit; + + if (FTaskDialog.Footer <> '') then + begin + R := GetFooterRect; + + i := R.Top - FVertSpacing; + Canvas.Pen.Color := RGB(223, 223, 223); + Canvas.MoveTo(2, i); + Canvas.LineTo(ClientWidth -3, i); + Canvas.Pen.Color := clWhite; + Canvas.MoveTo(2, i+1); + Canvas.LineTo(ClientWidth -3, i+1); + + if Assigned(FFooterIcon) then + begin + + IconH := LoadImage(0,FFooterIconID,IMAGE_ICON,16,16, LR_SHARED); + + bmp := TBitmap.Create; + bmp.Width := 16; + bmp.Height := 16; + bmp.Transparent := True; + bmp.Canvas.Brush.Color := RGB(240, 240, 240); + bmp.Canvas.Rectangle(0,0,16,16); + //DrawIcon(bmp.Canvas.Handle,0, 0, IconH); + //Canvas.StretchDraw(Rect(R.Left, R.Top-2, R.Left+16, R.Top+14), bmp); + + if FTaskDialog.FooterIcon = tfiShield then + begin + shieldbmp := TBitmap.Create; + shieldbmp.Handle := LoadBitmap(hInstance, 'TD_SHIELD'); + bmp.Canvas.StretchDraw(Rect(0,0,16,16),shieldbmp); + shieldbmp.Free; + end + else + begin + DrawIconEx(bmp.Canvas.Handle, 0, 0, IconH, 16, 16, 0, bmp.Canvas.Brush.Handle, DI_NORMAL); //Replaced DrawIcon + end; + Canvas.Draw(R.Left, R.Top, bmp); + bmp.Free; + + R.Left := R.Left + 20; + end; + szFooterText := StringReplace(FTaskDialog.Footer,'\n','
',[rfReplaceAll]); + szFooterText := StringReplace(szFooterText,#10,'
',[rfReplaceAll]); + + HTMLDrawEx(Canvas, szFooterText, R, nil, 0, 0, -1, -1, 1, false, false, false, false, False, false, + true, 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, xsize, ysize, + hyperlinks, mouselink, re, nil , nil, 0); + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvMessageForm.GetFooterRect: TRect; +begin + Result := Rect(-1, -1, -1, -1); + if Assigned(FTaskDialog) and (FTaskDialog.Footer <> '') then + begin + Result := Rect(FHorzMargin, ClientHeight - FFooterYSize-10, ClientWidth - FHorzMargin, ClientHeight); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.Paint; +var + i: Integer; + R: TRect; + s: string; + VerInfo: TOSVersionInfo; + +begin + inherited; + i := FWhiteWindowHeight; + + {if (FcmBtnList.Count > 0) then + i := TButton(FcmBtnList.Items[0]).Top + else if (FcsBtnList.Count > 0) then + i := TButton(FcsBtnList.Items[0]).Top;} + + VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); + GetVersionEx(verinfo); + + if (i > 0) then + begin + R := ClientRect; + R.Top := i - (FVertSpacing div 2) ; + Canvas.Brush.Color := RGB(240, 240, 240); + Canvas.FillRect(R); + Canvas.Pen.Color := RGB(223, 223, 223); + Canvas.MoveTo(R.Left, R.Top); + Canvas.LineTo(R.Right, R.Top); + R := ClientRect; + Canvas.Brush.Style := bsClear; + + if (verinfo.dwMajorVersion >= 6) then + Canvas.Pen.Style := psClear + else + Canvas.Pen.Style := psSolid; + + if DRAWBORDER and not IsVista then // only draw on non Vista + begin + Canvas.Pen.Color := clGray; + Canvas.Rectangle(R.Left+1, R.Top+1, R.Right-1, R.Bottom-1); + end; + Canvas.Pen.Style := psSolid; + end; + + DrawContent; + DrawExpandedText; + if Assigned(FTaskDialog) and (FTaskDialog.ExpandedText <> '') and Assigned(FExpandButton) then + begin + if not FExpanded then + s := FTaskDialog.CollapsControlText + else + s := FTaskDialog.ExpandControlText; + + Canvas.Brush.Style := bsClear; + R := Rect(FExpandButton.Left + FExpandButton.Width + FHorzSpacing - 5, FExpandButton.Top, ClientRect.Right, FExpandButton.Top + FExpandButton.Height); + DrawText(Canvas.Handle,PChar(s),Length(s), R, DT_SINGLELINE or DT_LEFT or DT_VCENTER); + end; + DrawFooter; +end; + +//------------------------------------------------------------------------------ + +function TAdvMessageForm.IsAnchor(x, y: integer): string; +var + r: trect; + xsize, ysize: integer; + anchor, stripped: string; + + HyperLinks,MouseLink: Integer; + Focusanchor: string; + re: TRect; + AText: String; +begin + Result := ''; + if not Assigned(FTaskDialog) then + Exit; + + AText := ''; + R := GetFooterRect; + if PtInRect(R, Point(X, Y)) then + begin + if Assigned(FFooterIcon) then + begin + R.Left := R.Left + 20; + end; + AText := FTaskDialog.Footer; + end + else + begin + R := GetContentRect; + if PtInRect(R, Point(X, y)) then + AText := FTaskDialog.Content + else + begin + R := GetExpTextRect; + if PtInRect(R, Point(X, y)) then + AText := FTaskDialog.ExpandedText; + end; + end; + + AText := StringReplace(AText,'\n','
',[rfReplaceAll,rfIgnoreCase]); + AText := StringReplace(AText,#10,'
',[rfReplaceAll,rfIgnoreCase]); + + Anchor := ''; + if (AText <> '') then + begin + if HTMLDrawEx(Canvas, AText, r, nil, x, y, -1, -1, 1, true, false, false, true, true, false, true, + 1.0, clBlue, clNone, clNone, clGray, anchor, stripped, focusanchor, xsize, ysize, hyperlinks, + mouselink, re, nil, nil, 0) then + Result := anchor; + end; +end; + +procedure TAdvMessageForm.KeyDown(var Key: Word; Shift: TShiftSTate); +var + s: string; +begin + inherited; + if (Key = ord('C')) and (ssCtrl in Shift) then + begin + // got ctrl-c + s := FTaskDialog.FTitle + #13#10; + s := s + FTaskDialog.FInstruction + #13#10; + s := s + FTaskDialog.FContent; + clipboard.Open; + clipboard.AsText := s; + clipboard.Close; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.MouseDown(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var + Anchor: string; +begin + inherited; + Anchor := IsAnchor(X, Y); + if Anchor <> '' then + begin + if not Assigned(FTaskDialog.OnDialogHyperlinkClick) then + begin + if (Pos('://', anchor) > 0) then + VistaShellOpen(0, 'iexplore.exe', Anchor); + end; + + if Assigned(FTaskDialog.OnDialogHyperlinkClick) then + FTaskDialog.OnDialogHyperlinkClick(FTaskDialog, Anchor); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.MouseMove(Shift: TShiftState; X, Y: Integer); +var + anchor: string; +begin + anchor := IsAnchor(x, y); + if (Anchor <> '') then + begin + if (self.Cursor = crDefault) or (fAnchor <> Anchor) then + begin + fAnchor := Anchor; + self.Cursor := crHandPoint; + //if fAnchorHint then + //Application.CancelHint; + //if Assigned(fAnchorEnter) then fAnchorEnter(self, anchor); + end; + end + else + begin + if (self.Cursor = crHandPoint) then + begin + self.Cursor := crDefault; + //if assigned(fAnchorExit) then fAnchorExit(self, anchor); + end; + end; + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.OnTimer(Sender: TObject); +var + State: TTaskDialogProgressState; + Pos: Integer; +begin + if Assigned(FTaskDialog) then + begin + if Assigned(FTaskDialog.OnDialogTimer) then + FTaskDialog.OnDialogTimer(FTaskDialog); + + if Assigned(FTaskDialog.OnDialogProgress) then + begin + Pos := FProgressBar.Position; + FTaskDialog.OnDialogProgress(FTaskDialog, Pos, State); + FProgressBar.Position := Pos; + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.ClickButton(ButtonID: integer); +var + Btn: TButton; + TaskBtn: TTaskDialogButton; +begin + TaskBtn := nil; + Btn := GetButton(ButtonID, TaskBtn); + if Assigned(Btn) then + Btn.Click + else if Assigned(TaskBtn) then + TaskBtn.Click; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.EnableButton(ButtonID: integer; + Enabled: boolean); +var + Btn: TButton; + TaskBtn: TTaskDialogButton; +begin + TaskBtn := nil; + Btn := GetButton(ButtonID, TaskBtn); + if Assigned(Btn) then + Btn.Enabled := Enabled + else if Assigned(TaskBtn) then + TaskBtn.Enabled := Enabled; +end; + +//------------------------------------------------------------------------------ + +function TAdvMessageForm.GetButton(ButtonID: Integer; var TaskButton: TTaskDialogButton): TButton; +var + i, j: Integer; +begin + j := 0; + Result := nil; + for i := 0 to FcmBtnList.Count-1 do + begin + Inc(j); + if (j >= ButtonID) then + begin + TButton(FcmBtnList.Items[i]).Enabled := Enabled; + Result := TButton(FcmBtnList.Items[i]); + break; + end; + end; + + if not Assigned(Result) then + begin + j := 99; + for i := 0 to FcsBtnList.Count-1 do + begin + Inc(j); + if (j >= ButtonID) then + begin + if (doCommandLinks in FTaskDialog.Options) then + begin + TTaskDialogButton(FcsBtnList.Items[i]).Enabled := Enabled; + TaskButton := TTaskDialogButton(FcsBtnList.Items[i]); + end + else + begin + TButton(FcsBtnList.Items[i]).Enabled := Enabled; + Result := TButton(FcsBtnList.Items[i]); + end; + break; + end; + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TTaskDialogButton.Click; +var + Form: TCustomForm; +begin + Form := GetParentForm(Self); + if Form <> nil then + Form.ModalResult := ModalResult; + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.OnVerifyClick(Sender: TObject); +begin + if not Assigned(FTaskDialog) or not Assigned(FVerificationCheck) then + Exit; + + FTaskDialog.VerifyResult := FVerificationCheck.Checked; + + if Assigned(FVerificationCheck) and Assigned(FTaskDialog.OnDialogVerifyClick) then + FTAskDialog.OnDialogVerifyClick(FTaskDialog, FVerificationCheck.Checked); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.OnRadioClick(Sender: TObject); +begin + if not Assigned(FTaskDialog) or not Assigned(FRadioList) then + Exit; + + FTaskDialog.RadioButtonResult := FRadioList.IndexOf(Sender) + 200; + if Assigned(FTaskDialog) and Assigned(FTaskDialog.OnDialogRadioClick) then + FTAskDialog.OnDialogRadioClick(FTaskDialog, FTaskDialog.RadioButtonResult); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.DoClose(var Action: TCloseAction); +var + CanClose: Boolean; + s: string; + a: array[0..255] of char; + +begin + CanClose := True; + + if Assigned(FTaskDialog) and Assigned(FTaskDialog.OnDialogClose) then + begin + FTaskDialog.OnDialogClose(FTaskDialog, CanClose); + end; + + case FTaskDialog.InputType of + itEdit: FTaskDialog.InputText := FInputEdit.Text; + itComboEdit, itComboList: FTaskDialog.InputText := FInputCombo.Text; + itDate: FTaskDialog.InputText := DateToStr(FInputDate.Date); + itMemo: FTaskDialog.InputText := FInputMemo.Lines.Text; + itCustom: + begin + if Assigned(FTaskDialog.InputControl) then + begin + GetWindowText(FTaskDialog.InputControl.Handle, a, sizeof(a)); + s := strpas(a); + if Assigned(FTaskDialog.OnDialogInputGetText) then + begin + s := ''; + FTaskDialog.OnDialogInputGetText(Self, s); + end; + FTaskDialog.InputText := s; + FTaskDialog.InputControl.Visible := false; + FTaskDialog.InputControl.Parent := FOldParent; + end; + end; + end; + + if not CanClose then + Action := caNone; + inherited; +end; + +procedure TAdvMessageForm.DoShow; +var + defBtn: integer; +begin + inherited; + + defBtn := -1; + if FTaskDialog.DefaultButton <> -1 then + begin + if (FTaskDialog.DefaultButton - 100 >= 0) and (FTaskDialog.DefaultButton - 100 < FTaskDialog.CustomButtons.Count) then + defBtn := FTaskDialog.DefaultButton - 100; + end; + + if defBtn <> -1 then + begin + if (docommandLinks in FTaskDialog.Options) then + TTaskDialogButton(FcsBtnList[defBtn]).SetFocus + else + TCustomControl(FcsBtnList[defBtn]).SetFocus; + end; + + case FTaskDialog.InputType of + itEdit: FInputEdit.SetFocus; + itComboEdit, itComboList: FInputCombo.SetFocus; + itDate: FInputDate.SetFocus; + itMemo: FInputMemo.SetFocus; + itCustom: FTaskDialog.InputControl.SetFocus; + end; + +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.OnButtonClick(Sender: TObject); +begin + if not Assigned(FTaskDialog) or not Assigned(FcsBtnList) then + Exit; + + if Assigned(FTaskDialog) and Assigned(FTaskDialog.onDialogButtonClick) then + FTaskDialog.OnDialogButtonClick(FTaskDialog, FcsBtnList.IndexOf(Sender) + 100); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvMessageForm.CMDialogChar(var Message: TCMDialogChar); +var + I: Integer; +begin + if Assigned(FTaskDialog) and (docommandLinks in FTaskDialog.Options) then + begin + for I := 0 to FcsBtnList.Count-1 do + begin + if (TControl(FcsBtnList[I]) is TTaskDialogButton) and IsAccel(Message.CharCode, TTaskDialogButton(FcsBtnList[I]).Caption) and CanFocus then + begin + TTaskDialogButton(FcsBtnList[I]).Click; + Message.Result := 1; + Exit; + end; + end; + end; + + if (FTaskDialog.ExpandControlText <> '') and Expanded then + begin + if IsAccel(Message.CharCode, FTaskDialog.FExpandControlText) then + begin + OnExpandButtonClick(Self); + end; + end + else + if (FTaskDialog.CollapsControlText <> '') and not Expanded then + if IsAccel(Message.CharCode, FTaskDialog.FCollapsControlText) then + begin + OnExpandButtonClick(Self); + end; + + inherited; + + if Assigned(FTaskDialog) and (doAllowDialogCancel in FTaskDialog.Options) and (Message.CharCode = VK_ESCAPE) then + begin + Self.Close; + end; +end; + + +function CoreShowmessage( + const Title, // dialog window title + Instruction, // the part of the message shown in blue + content, // additional message if desired + verify: string; // ex Do Not Show this Again + tiIcon: tTaskDialogIcon): boolean; +var + td: TCustomAdvTaskDialog; +begin + td := TCustomAdvTaskDialog.Create(application); + td.Title := Title; + td.Instruction := instruction; + td.Content := Content; + td.VerificationText := verify; + td.icon := tiIcon; + td.execute; + result := (verify <> '') and td.VerifyResult; + td.free; +end {CoreShowmessage}; + +//===================================================================== +// This returns false unless verify is not blank AND the verify checkbox +// was not checked. +//--------------------------------------------------------------------- +function AdvShowMessage( + const Title, // dialog window title + Instruction, // the part of the message shown in blue + content, // additional message if desired + verify: string; // ex Do Not Show this Again + tiIcon: tTaskDialogIcon): boolean; overload; +begin + result := coreShowmessage(title, instruction,content,verify,tiIcon); +end { tmsShowMessage }; + +function AdvShowmessage(const Instruction: string):boolean; overload; +begin // Only instruction . tiInformation + result := CoreShowMessage('',Instruction,'','',tiInformation); +end; + +function AdvShowmessage(const Title, Instruction: string):boolean; overload; +begin // title, instruction tiInformation + result := CoreShowMessage(Title,Instruction,'','',tiInformation); +end; + +function AdvShowmessage(const Title, Instruction: string;tiIcon: TTaskDialogIcon): boolean; overload; +begin + result := CoreShowMessage(Title,Instruction,'','',tiIcon); +end; + +function AdvShowMessageFmt(const Instruction: string; Parameters: array of const): boolean; +begin + Result := AdvShowmessage(Format(Instruction,Parameters)); +end; + +function AdvMessageBox(hWnd: HWND; lpInstruction, lpTitle: PChar; flags: UINT): Integer; +const + MB_CANCELTRYCONTINUE = $00000006; // missing from windows unit so probably never be used +var + td: TCustomAdvTaskDialog; + res: integer; + def: integer; + num: integer; + task: tCommonButton; + txt: string; +begin + td := TCustomAdvTaskDialog.Create(application); + td.Title := lptitle; + td.instruction := lpInstruction; + + // extract the icon from flags + case MB_ICONMASK and flags of + MB_ICONEXCLAMATION: td.Icon := tiWarning; // Exclamation mark= MB_ICONWARNING + MB_ICONINFORMATION: td.Icon := tiInformation; // Circled I = MB_ICONASTERISK + MB_ICONQUESTION: td.Icon := tiQuestion; // Question (api says don't use any more + MB_ICONSTOP: td.Icon := tiError; //Stop sign = MB_ICONERROR & MB_ICONHAND + end; + + // extract the buttons from flags + // MessageBox() Flags from Windows help file + // MB_ABORTRETRYIGNORE + // The message box contains three push buttons: Abort, Retry, and Ignore. + // MB_CANCELTRYCONTINUE + // Microsoft Windows 2000/XP: The message box contains three push buttons: Cancel, Try Again, Continue. Use this message box type instead of MB_ABORTRETRYIGNORE. + // MB_HELP + // Windows 95/98/Me, Windows NT 4.0 and later: Adds a Help button to the message box. When the user clicks the Help button or presses F1, the system sends a WM_HELP message to the owner. + // MB_OK + // The message box contains one push button: OK. This is the default. + // MB_OKCANCEL + // The message box contains two push buttons: OK and Cancel. + // MB_RETRYCANCEL + // The message box contains two push buttons: Retry and Cancel. + // MB_YESNO + // The message box contains two push buttons: Yes and No. + // MB_YESNOCANCEL + // The message box contains three push buttons: Yes, No, and Cancel. + td.Commonbuttons := []; + txt := ''; + case MB_TYPEMASK and flags of + MB_ABORTRETRYIGNORE: txt := 'Abort'#10'Retry'#10'Ignore'; + MB_CANCELTRYCONTINUE: txt := 'Cancel'#10'Try Again'#10'Continue'; + MB_OK: td.Commonbuttons := [cbOK]; + MB_RETRYCANCEL: txt := 'Retry'#10'Cancel'; + MB_OKCANCEL: td.CommonButtons := [cbOK,cbCancel]; + MB_YESNOCANCEL: td.Commonbuttons := [cbYes, cbNO, cbCancel]; + MB_YESNO: td.CommonButtons := [cbYes, cbNO]; + end; + if MB_HELP and flags <> 0 then + begin + if length(txt) > 0 then + txt := txt + #10; + txt := txt+'Help'; + end; + if txt <> '' then + td.CustomButtons.text := txt; + + // deal with mbDefbutton1, 2, 3 & 4 + def := 0; + if mb_DefButton1 and flags <> 0 then + def := 1; + if mb_DefButton2 and flags <> 0 then + def := 2; + if mb_DefButton3 and flags <> 0 then + def := 3; + if mb_DefButton4 and flags <> 0 then + def := 4; + if def > 0 then + begin // have to set default button + num := td.CustomButtons.count; + if num <= def then + td.DefaultButton := 99 + def + else begin + // I think this compiles on supported delphi compilers + for task := cbOK to cbClose do + begin + if task in td.CommonButtons then + begin + inc(num); + if num = def then + begin + case task of + cbOK: td.Defaultbutton := idOK; + cbYes: td.Defaultbutton := idYES; + cbNo: td.Defaultbutton := idNO; + cbCancel: td.Defaultbutton := idCANCEL; + cbRetry: td.Defaultbutton := idRETRY; + cbClose: td.Defaultbutton := idCLOSE; + end; + break; + end; + end; + end; + end; + end; + + // Deal with mbAppModal, mbSystemModal and mbtaskModal + // not sure what to do with these (I personally haven't used them. + result := 0; + res := td.Execute; + case res of + 1: result := IDOK; + 2: result := IDCANCEL; + 3: result := IDABORT; + 4: result := IDRETRY; + 5: result := IDIGNORE; + 6: result := IDYES; + 7: result := IDNO; + else + begin + case MB_TYPEMASK and flags of + MB_ABORTRETRYIGNORE: + case res of + 100: result := IDABORT; + 101: result := IDRETRY; + 102: result := IDIGNORE; + end; + MB_CANCELTRYCONTINUE: + case res of + 100: result := IDCANCEL; + {$IFDEF DELPHI9_LVL} + 101: result := IDTRYAGAIN; + 102: result := IDCONTINUE; + {$ENDIF} + end; + MB_RETRYCANCEL: + case res of + 100: result := IDRETRY; + 101: result := IDCANCEL; + end; + end; + end; + end; + td.Free; +end; + +function AdvMessageDlg(const Instruction: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; overload; +begin + // passes mbHelp as the default button since we can't deal with help anyway + Result := AdvMessageDlg(Instruction,Dlgtype,Buttons,HelpCtx,mbHelp); +end; + +function AdvMessageDlg(const Instruction: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; overload; +var + td: TCustomAdvTaskDialog; + ray: array[0..3] of integer; + res: integer; +begin + td := TCustomAdvTaskDialog.Create(Application); + td.Instruction := instruction; + + case DlgType of + mtWarning: + begin + td.Icon := tiWarning; + td.Title := 'Warning'; + end; + mtError: + begin + td.Icon := tiError; + td.Title := 'Error'; + end; + mtInformation: + begin + td.Icon := tiInformation; + td.Title := 'Information'; + end; + mtConfirmation: + begin + td.Icon := tiShield; + td.Title := 'Confirm'; + end; + end; + + fillchar(ray,sizeof(ray),0); + td.CommonButtons := []; + +// TMsgDlgBtn = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore, +// mbAll, mbNoToAll, mbYesToAll, mbHelp); + + if (mbYes in Buttons) then + td.CommonButtons := td.CommonButtons + [cbYes]; + + if (mbNo in Buttons) then + td.CommonButtons := td.CommonButtons + [cbNo]; + + if (mbOK in Buttons) then + td.CommonButtons := td.CommonButtons + [cbOK]; + + if (mbCancel in Buttons) then + td.CommonButtons := td.CommonButtons + [cbCancel]; + + if (mbAbort in Buttons) then + td.CommonButtons := td.CommonButtons + [cbClose]; + + if (mbRetry in Buttons) then + td.CommonButtons := td.CommonButtons + [cbRetry]; + + + if (mbIgnore in Buttons) then + begin + td.CustomButtons.Add('Ignore'); + ray[0] := mrIgnore; + end; + + if (mbAll in Buttons) then + begin + ray[td.custombuttons.Count] := mrALL; + td.CustomButtons.Add('All'); + end; + + if (mbNoToAll in buttons) then + begin + ray[td.custombuttons.Count] := mrNoToAll; + td.CustomButtons.add('No to All'); + end; + + if (mbYesToAll in buttons) then + begin + ray[td.custombuttons.Count] := mrYesToAll; + td.Custombuttons.Add('Yes to All'); + end; + + result := 0; + res := td.Execute; + case res of + 1: Result := mrOk; + 2: Result := mrCancel; + 3: Result := mrAbort; + 4: Result := mrRetry; + 6: Result := mrYes; + 7: Result := mrNo; + else + if (res > 99) and (res < 100+high(ray)) then + result := ray[res-100]; + end; +end; + +function AdvInputQueryDlg(ACaption, APrompt: string; var Value: string):boolean; +var + AID: TAdvInputTaskDialog; +begin + AID := TAdvInputTaskDialog.Create(Application); + AID.Instruction := APrompt; + AID.Title := ACaption; + AID.InputText := Value; + AID.InputType := itEdit; + AID.CommonButtons := [cbOK, cbCancel]; + Result := AID.Execute = mrOK; + Value := AID.InputText; +end; + +//------------------------------------------------------------------------------ + +procedure Register; +begin + RegisterComponents('TMS',[TAdvTaskDialog, TAdvInputTaskDialog]); +end; + +//------------------------------------------------------------------------------ + + +{ TAdvInputTaskDialog } + +constructor TAdvInputTaskDialog.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FInputType := itEdit; + Options := Options + [doAllowDialogCancel]; +end; + +function TAdvInputTaskDialog.Execute: integer; +begin + Result := AdvMessageDlgPos(Self, -1, -1); +end; + + +initialization + //cbOK, cbYes, cbNo, cbCancel, cbRetry, cbClose); + ButtonCaptions[cbOK] := @SMsgDlgOK; + ButtonCaptions[cbYes] := @SMsgDlgYes; + ButtonCaptions[cbNo] := @SMsgDlgNo; + ButtonCaptions[cbCancel] := @SMsgDlgCancel; + ButtonCaptions[cbRetry] := @SMsgDlgRetry; + ButtonCaptions[cbClose] := @SMsgDlgAbort; + + Captions[tiBlank] := nil; + Captions[tiWarning] := @SMsgDlgWarning; + Captions[tiQuestion] := @SMsgDlgConfirm; + Captions[tiError] := @SMsgDlgError; + Captions[tiShield] := @SMsgDlgInformation; + + +{$IFDEF FREEWARE} + if (FindWindow('TApplication', nil) = 0) OR + (FindWindow('TAppBuilder', nil) = 0) then + begin + MessageBox(0,'Application uses trial version of TMS components','Info',MB_OK); + end +{$ENDIF} + + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialog.res b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialog.res new file mode 100644 index 0000000..5028366 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialog.res differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogDE.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogDE.pas new file mode 100644 index 0000000..0434010 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogDE.pas @@ -0,0 +1,84 @@ +{***************************************************************************} +{ TTaskDialog component } +{ for Delphi & C++Builder } +{ version 1.2 } +{ } +{ written by TMS Software } +{ copyright © 2006 - 2007 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit TaskDialogDE; + +interface + +{$I TMSDEFS.INC} + +uses + Classes, Graphics, Comctrls, Windows, Forms, TypInfo, Dialogs, ExtCtrls, + Controls, ExtDlgs, TaskDialog +{$IFDEF DELPHI6_LVL} + {$IFNDEF TMSDOTNET} + , DesignIntf, DesignEditors, ContNrs + {$ENDIF} + {$IFDEF TMSDOTNET} + , Borland.Vcl.design.DesignIntf, Borland.Vcl.design.DesignEditors, ContNrs + {$ENDIF} +{$ELSE} + , DsgnIntf +{$ENDIF} + ; + +type + + TTaskDialogEditor = class(TDefaultEditor) + public + function GetVerb(Index: Integer):string; override; + function GetVerbCount: Integer; override; + procedure ExecuteVerb(Index: Integer); override; + end; + +implementation + +{ TTaskDialogEditor } + +procedure TTaskDialogEditor.ExecuteVerb(Index: Integer); +var + AppIsParent: boolean; +begin + inherited; + case Index of + 0: + begin + AppIsParent := TAdvTaskDialog(Component).ApplicationIsParent; + TAdvTaskDialog(Component).ApplicationIsParent := true; + TAdvTaskDialog(Component).Execute; + TAdvTaskDialog(Component).ApplicationIsParent := AppIsParent; + end; + end; +end; + +function TTaskDialogEditor.GetVerb(Index: Integer): string; +begin + case Index of + 0: Result := 'Preview'; + end; +end; + +function TTaskDialogEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + + + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogEx.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogEx.pas new file mode 100644 index 0000000..c1a40fe --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogEx.pas @@ -0,0 +1,300 @@ +{***************************************************************************} +{ TTaskDialogEx component } +{ for Delphi & C++Builder } +{ } +{ written by TMS Software } +{ copyright © 2007 - 2008 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit TaskDialogEx; + +{$I TMSDEFS.INC} + +interface + +uses + Classes, Windows, Messages, Forms, Dialogs, SysUtils, StdCtrls, Graphics, Consts, Math, + ExtCtrls, Controls, TaskDialog, AdvGlowButton, AdvOfficeButtons; + +type + TButtonCreatedEvent = procedure(Sender: TObject; Button: TAdvGlowButton) of object; + + TAdvTaskDialogEx = class(TAdvTaskDialog) + private + FOnButtonCreated: TButtonCreatedEvent; + FAppearance: TGlowButtonAppearance; + protected + function CreateRadioButton(AOwner: TComponent): TWinControl; override; + procedure SetRadioButtonState(Btn: TWinControl; Checked: boolean); override; + procedure SetRadioButtonCaption(Btn: TWinControl; Value: string); override; + function CreateButton(AOwner: TComponent): TWinControl; override; + procedure InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); override; + procedure SetButtonCaption(aButton: TWinControl; Value: TCaption); override; + procedure SetButtonCancel(aButton: TWinControl; Value: Boolean); override; + procedure SetButtonDefault(aButton: TWinControl; Value: Boolean); override; + procedure SetButtonModalResult(aButton: TWinControl; Value: Integer); override; + function GetButtonModalResult(aButton: TWinControl): Integer; override; + public + property Appearance: TGlowButtonAppearance read FAppearance write FAppearance; + property OnButtonCreated:TButtonCreatedEvent read FOnButtonCreated write FOnButtonCreated; + end; + + TAdvInputTaskDialogEx = class(TAdvInputTaskDialog) + private + FOnButtonCreated: TButtonCreatedEvent; + FAppearance: TGlowButtonAppearance; + protected + function CreateRadioButton(AOwner: TComponent): TWinControl; override; + procedure SetRadioButtonState(Btn: TWinControl; Checked: boolean); override; + procedure SetRadioButtonCaption(Btn: TWinControl; Value: string); override; + function CreateButton(AOwner: TComponent): TWinControl; override; + procedure InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); override; + procedure SetButtonCaption(aButton: TWinControl; Value: TCaption); override; + procedure SetButtonCancel(aButton: TWinControl; Value: Boolean); override; + procedure SetButtonDefault(aButton: TWinControl; Value: Boolean); override; + procedure SetButtonModalResult(aButton: TWinControl; Value: Integer); override; + function GetButtonModalResult(aButton: TWinControl): Integer; override; + public + property Appearance: TGlowButtonAppearance read FAppearance write FAppearance; + property OnButtonCreated:TButtonCreatedEvent read FOnButtonCreated write FOnButtonCreated; + end; + + +procedure Register; + +implementation + +//------------------------------------------------------------------------------ + +procedure Register; +begin + RegisterComponents('TMS',[TAdvTaskDialogEx]); +end; + +//------------------------------------------------------------------------------ + +{ TAdvTaskDialogEx } + +function TAdvTaskDialogEx.CreateButton(AOwner: TComponent): TWinControl; +begin + Result := TAdvGlowButton.Create(AOwner); + if Assigned(FAppearance) then + (Result as TAdvGlowButton).Appearance := FAppearance; + (Result as TAdvGlowButton).TabStop := true; + if Assigned(FOnButtonCreated) then + FOnButtonCreated(Self,(Result as TAdvGlowButton)); +end; + +//------------------------------------------------------------------------------ + +function TAdvTaskDialogEx.CreateRadioButton(AOwner: TComponent): TWinControl; +begin + Result := TAdvOfficeRadioButton.Create(AOwner); +end; + +//------------------------------------------------------------------------------ + +function TAdvTaskDialogEx.GetButtonModalResult( + aButton: TWinControl): Integer; +begin + Result := mrNone; + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + Result := TAdvGlowButton(aButton).ModalResult; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvTaskDialogEx.SetButtonCancel(aButton: TWinControl; + Value: Boolean); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).Cancel := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvTaskDialogEx.SetButtonCaption(aButton: TWinControl; + Value: TCaption); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).Caption := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvTaskDialogEx.SetButtonDefault(aButton: TWinControl; + Value: Boolean); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).Default := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvTaskDialogEx.SetButtonModalResult(aButton: TWinControl; + Value: Integer); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).ModalResult := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvTaskDialogEx.SetRadioButtonCaption(Btn: TWinControl; + Value: string); +begin + TAdvOfficeRadioButton(Btn).Caption := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvTaskDialogEx.SetRadioButtonState(Btn: TWinControl; + Checked: boolean); +begin + TAdvOfficeRadioButton(Btn).Checked := Checked; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvTaskDialogEx.InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); +begin + with TRadioButton(Btn) do + begin + Name := 'Radio' + inttostr(btnIndex); + Parent := AOwner; + Font.Name := AOwner.Canvas.Font.Name; + Font.Size := 8; + BiDiMode := AOwner.BiDiMode; + OnClick := OnClickEvent; + + { + BoundsRect := TextRect; + Left := FHorzParaMargin + FHorzMargin; //ALeft + FHorzMargin; + Top := Y; + Width := Self.Width - Left - 4; + GetTextSize(Canvas, Caption, k, l); + w := Max(w, Left + k + FHorzMargin + 20); + } + end; +end; + +{ TAdvInputTaskDialogEx } + +//------------------------------------------------------------------------------ + +function TAdvInputTaskDialogEx.CreateButton(AOwner: TComponent): TWinControl; +begin + Result := TAdvGlowButton.Create(AOwner); + if Assigned(FAppearance) then + (Result as TAdvGlowButton).Appearance := FAppearance; + (Result as TAdvGlowButton).TabStop := true; + if Assigned(FOnButtonCreated) then + FOnButtonCreated(Self,(Result as TAdvGlowButton)); +end; + +function TAdvInputTaskDialogEx.CreateRadioButton( + AOwner: TComponent): TWinControl; +begin + Result := TAdvOfficeRadioButton.Create(AOwner); +end; + +function TAdvInputTaskDialogEx.GetButtonModalResult( + aButton: TWinControl): Integer; +begin + Result := mrNone; + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + Result := TAdvGlowButton(aButton).ModalResult; +end; + +procedure TAdvInputTaskDialogEx.SetButtonCancel(aButton: TWinControl; + Value: Boolean); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).Cancel := Value; +end; + +procedure TAdvInputTaskDialogEx.SetButtonCaption(aButton: TWinControl; + Value: TCaption); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).Caption := Value; +end; + +procedure TAdvInputTaskDialogEx.SetButtonDefault(aButton: TWinControl; + Value: Boolean); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).Default := Value; +end; + +procedure TAdvInputTaskDialogEx.SetButtonModalResult(aButton: TWinControl; + Value: Integer); +begin + if not Assigned(aButton) or not (aButton is TAdvGlowButton) then + Exit; + + TAdvGlowButton(aButton).ModalResult := Value; +end; + +procedure TAdvInputTaskDialogEx.SetRadioButtonCaption(Btn: TWinControl; + Value: string); +begin + TAdvOfficeRadioButton(Btn).Caption := Value; +end; + +procedure TAdvInputTaskDialogEx.SetRadioButtonState(Btn: TWinControl; + Checked: boolean); +begin + TAdvOfficeRadioButton(Btn).Checked := Checked; +end; + +procedure TAdvInputTaskDialogEx.InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); +begin + with TRadioButton(Btn) do + begin + Name := 'Radio' + inttostr(btnIndex); + Parent := AOwner; + Font.Name := AOwner.Canvas.Font.Name; + Font.Size := 8; + BiDiMode := AOwner.BiDiMode; + OnClick := OnClickEvent; + { + BoundsRect := TextRect; + Left := FHorzParaMargin + FHorzMargin; //ALeft + FHorzMargin; + Top := Y; + Width := Self.Width - Left - 4; + GetTextSize(Canvas, Caption, k, l); + w := Max(w, Left + k + FHorzMargin + 20); + } + end; +end; + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.dpk b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.dpk new file mode 100644 index 0000000..7713990 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.dpk @@ -0,0 +1,50 @@ +package TaskDialogPkgD2007; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'TMS TaskDialog'} +{$IMPLICITBUILD OFF} +{$DEFINE RELEASE} + +requires + rtl, + vcl, + designide, + dbrtl, + vcldb; + +contains + TaskDialog in 'TaskDialog.pas', + PictureContainer in 'PictureContainer.pas', + TaskDialogDE in 'TaskDialogDE.pas', + TaskDialogRegDE in 'TaskDialogRegDE.pas', + TaskDialogEx in 'TaskDialogEx.pas', + advgdip in 'advgdip.pas', + advglowbutton in 'advglowbutton.pas', + AdvGroupBox in 'AdvGroupBox.pas', + advhintinfo in 'advhintinfo.pas', + AdvOfficeButtons in 'AdvOfficeButtons.pas', + advstyleif in 'advstyleif.pas', + gdipicture in 'gdipicture.pas'; + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.dproj b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.dproj new file mode 100644 index 0000000..6594f6c --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.dproj @@ -0,0 +1,543 @@ + + + + {322e4f51-9fd5-43be-8659-42e8edcc60b1} + TaskDialogPkgD2007.dpk + Release + AnyCPU + DCC32 + ..\Lib\D11\TaskDialogPkgD2007.bpl + + + 7.0 + False + False + 0 + RELEASE + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + + + 7.0 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + + + Delphi.Personality + Package + +FalseTrueFalseTMS TaskDialogFalseFalseFalseTrueFalse1000FalseFalseFalseFalseFalse206712521.0.0.01.0.0.0TaskDialogPkgD2007.dpk + + + + + MainSource + + + + + + + + + + + + + + + + + + + + + diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.res b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.res new file mode 100644 index 0000000..5fc5c89 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogPkgD2007.res differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogRegDE.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogRegDE.pas new file mode 100644 index 0000000..3a9109f --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/TaskDialogRegDE.pas @@ -0,0 +1,49 @@ +{***************************************************************************} +{ TTaskDialog component } +{ for Delphi & C++Builder } +{ version 1.2 } +{ } +{ written by TMS Software } +{ copyright © 2006 - 2007 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit TaskDialogRegDE; + +interface +{$I TMSDEFS.INC} + +uses + Classes, TaskDialog, TaskDialogDE, + {$IFDEF DELPHI6_LVL} + {$IFDEF TMSDOTNET} + Borland.Vcl.Design.DesignIntf, Borland.Vcl.Design.DesignEditors + {$ENDIF} + {$IFNDEF TMSDOTNET} + DesignIntf, DesignEditors + {$ENDIF} + {$ELSE} + DsgnIntf + {$ENDIF} + ; + +procedure Register; + +implementation + +procedure Register; +begin + RegisterComponentEditor(TAdvTaskDialog,TTaskDialogEditor); +end; + +end. + diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/advgdip.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advgdip.pas new file mode 100644 index 0000000..7d617a0 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advgdip.pas @@ -0,0 +1,2897 @@ +{***************************************************************************} +{ GDI+ API Imports } +{ for Delphi & C++Builder } +{ version 1.0 } +{ } +{ written by TMS Software } +{ copyright © 2006 - 2007 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit AdvGDIP; + +{$HPPEMIT ''} +{$HPPEMIT '#pragma link "gdiplus.lib"'} +{$HPPEMIT ''} + +{$I TMSDEFS.INC} +{$ALIGN ON} +{$MINENUMSIZE 4} + +interface + +uses + Windows, ActiveX, Math, Graphics; + +type + INT16 = type Smallint; + UINT16 = type Word; + PUINT16 = ^UINT16; + UINT32 = type Cardinal; + TSingleDynArray = array of Single; + +var + GlowSpeed : integer = 30; + + +const + {$EXTERNALSYM GDIP_NOWRAP} + GDIP_NOWRAP = 4096; + WINGDIPDLL = 'gdiplus.dll'; + +//---------------------------------------------------------------------------- +// Memory Allocation APIs +//---------------------------------------------------------------------------- + +{$EXTERNALSYM GdipAlloc} +function GdipAlloc(size: ULONG): pointer; stdcall; +{$EXTERNALSYM GdipFree} +procedure GdipFree(ptr: pointer); stdcall; + +(**************************************************************************\ +* +* GDI+ base memory allocation class +* +\**************************************************************************) + +type + TAntiAlias = (aaNone, aaClearType, aaAntiAlias); + + TGdiplusBase = class + public + class function NewInstance: TObject; override; + procedure FreeInstance; override; + end; + +//-------------------------------------------------------------------------- +// Fill mode constants +//-------------------------------------------------------------------------- + + FillMode = ( + FillModeAlternate, // 0 + FillModeWinding // 1 + ); + TFillMode = FillMode; + +//-------------------------------------------------------------------------- +// Quality mode constants +//-------------------------------------------------------------------------- + +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM QualityMode} + QualityMode = ( + QualityModeInvalid = -1, + QualityModeDefault = 0, + QualityModeLow = 1, // Best performance + QualityModeHigh = 2 // Best rendering quality + ); + TQualityMode = QualityMode; +{$ELSE} + {$EXTERNALSYM QualityMode} + QualityMode = Integer; + const + QualityModeInvalid = -1; + QualityModeDefault = 0; + QualityModeLow = 1; // Best performance + QualityModeHigh = 2; // Best rendering quality +{$ENDIF} + +type +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM CompositingQuality} + CompositingQuality = ( + CompositingQualityInvalid = ord(QualityModeInvalid), + CompositingQualityDefault = ord(QualityModeDefault), + CompositingQualityHighSpeed = ord(QualityModeLow), + CompositingQualityHighQuality = ord(QualityModeHigh), + CompositingQualityGammaCorrected, + CompositingQualityAssumeLinear + ); + TCompositingQuality = CompositingQuality; +{$ELSE} + {$EXTERNALSYM CompositingQuality} + CompositingQuality = Integer; + const + CompositingQualityInvalid = QualityModeInvalid; + CompositingQualityDefault = QualityModeDefault; + CompositingQualityHighSpeed = QualityModeLow; + CompositingQualityHighQuality = QualityModeHigh; + CompositingQualityGammaCorrected = 3; + CompositingQualityAssumeLinear = 4; + +type + TCompositingQuality = CompositingQuality; +{$ENDIF} + +const + ImageFormatUndefined : TGUID = '{b96b3ca9-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatUndefined} + ImageFormatMemoryBMP : TGUID = '{b96b3caa-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatMemoryBMP} + ImageFormatBMP : TGUID = '{b96b3cab-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatBMP} + ImageFormatEMF : TGUID = '{b96b3cac-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatEMF} + ImageFormatWMF : TGUID = '{b96b3cad-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatWMF} + ImageFormatJPEG : TGUID = '{b96b3cae-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatJPEG} + ImageFormatPNG : TGUID = '{b96b3caf-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatPNG} + ImageFormatGIF : TGUID = '{b96b3cb0-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatGIF} + ImageFormatTIFF : TGUID = '{b96b3cb1-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatTIFF} + ImageFormatEXIF : TGUID = '{b96b3cb2-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatEXIF} + ImageFormatIcon : TGUID = '{b96b3cb5-0728-11d3-9d7b-0000f81ef32e}'; + {$EXTERNALSYM ImageFormatIcon} + + +type +//-------------------------------------------------------------------------- +// Unit constants +//-------------------------------------------------------------------------- + + Unit_ = ( + UnitWorld, // 0 -- World coordinate (non-physical unit) + UnitDisplay, // 1 -- Variable -- for PageTransform only + UnitPixel, // 2 -- Each unit is one device pixel. + UnitPoint, // 3 -- Each unit is a printer's point, or 1/72 inch. + UnitInch, // 4 -- Each unit is 1 inch. + UnitDocument, // 5 -- Each unit is 1/300 inch. + UnitMillimeter // 6 -- Each unit is 1 millimeter. + ); + TUnit = Unit_; + +//-------------------------------------------------------------------------- +// Dash style constants +//-------------------------------------------------------------------------- + + DashStyle = ( + DashStyleSolid, // 0 + DashStyleDash, // 1 + DashStyleDot, // 2 + DashStyleDashDot, // 3 + DashStyleDashDotDot, // 4 + DashStyleCustom // 5 + ); + TDashStyle = DashStyle; + + +//-------------------------------------------------------------------------- +// Various wrap modes for brushes +//-------------------------------------------------------------------------- + + WrapMode = ( + WrapModeTile, // 0 + WrapModeTileFlipX, // 1 + WrapModeTileFlipY, // 2 + WrapModeTileFlipXY, // 3 + WrapModeClamp // 4 + ); + TWrapMode = WrapMode; + +//-------------------------------------------------------------------------- +// LineGradient Mode +//-------------------------------------------------------------------------- + + LinearGradientMode = ( + LinearGradientModeHorizontal, // 0 + LinearGradientModeVertical, // 1 + LinearGradientModeForwardDiagonal, // 2 + LinearGradientModeBackwardDiagonal // 3 + ); + TLinearGradientMode = LinearGradientMode; + +//-------------------------------------------------------------------------- +// Line cap constants (only the lowest 8 bits are used). +//-------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM LineCap} + LineCap = ( + LineCapFlat = 0, + LineCapSquare = 1, + LineCapRound = 2, + LineCapTriangle = 3, + + LineCapNoAnchor = $10, // corresponds to flat cap + LineCapSquareAnchor = $11, // corresponds to square cap + LineCapRoundAnchor = $12, // corresponds to round cap + LineCapDiamondAnchor = $13, // corresponds to triangle cap + LineCapArrowAnchor = $14, // no correspondence + + LineCapCustom = $ff, // custom cap + + LineCapAnchorMask = $f0 // mask to check for anchor or not. + ); + TLineCap = LineCap; +{$ELSE} + {$EXTERNALSYM LineCap} + LineCap = Integer; + const + LineCapFlat = 0; + LineCapSquare = 1; + LineCapRound = 2; + LineCapTriangle = 3; + + LineCapNoAnchor = $10; // corresponds to flat cap + LineCapSquareAnchor = $11; // corresponds to square cap + LineCapRoundAnchor = $12; // corresponds to round cap + LineCapDiamondAnchor = $13; // corresponds to triangle cap + LineCapArrowAnchor = $14; // no correspondence + + LineCapCustom = $ff; // custom cap + + LineCapAnchorMask = $f0; // mask to check for anchor or not. + +type + TLineCap = LineCap; +{$ENDIF} + +//-------------------------------------------------------------------------- +// Region Comine Modes +//-------------------------------------------------------------------------- + + CombineMode = ( + CombineModeReplace, // 0 + CombineModeIntersect, // 1 + CombineModeUnion, // 2 + CombineModeXor, // 3 + CombineModeExclude, // 4 + CombineModeComplement // 5 (Exclude From) + ); + TCombineMode = CombineMode; + +//-------------------------------------------------------------------------- +// FontStyle: face types and common styles +//-------------------------------------------------------------------------- +type + {$EXTERNALSYM FontStyle} + FontStyle = Integer; + const + FontStyleRegular = Integer(0); + FontStyleBold = Integer(1); + FontStyleItalic = Integer(2); + FontStyleBoldItalic = Integer(3); + FontStyleUnderline = Integer(4); + FontStyleStrikeout = Integer(8); + Type + TFontStyle = FontStyle; + +//--------------------------------------------------------------------------- +// Smoothing Mode +//--------------------------------------------------------------------------- +{$IFDEF DELPHI6_UP} + {$EXTERNALSYM SmoothingMode} + SmoothingMode = ( + SmoothingModeInvalid = ord(QualityModeInvalid), + SmoothingModeDefault = ord(QualityModeDefault), + SmoothingModeHighSpeed = ord(QualityModeLow), + SmoothingModeHighQuality = ord(QualityModeHigh), + SmoothingModeNone, + SmoothingModeAntiAlias + ); + TSmoothingMode = SmoothingMode; +{$ELSE} + SmoothingMode = Integer; + const + SmoothingModeInvalid = QualityModeInvalid; + SmoothingModeDefault = QualityModeDefault; + SmoothingModeHighSpeed = QualityModeLow; + SmoothingModeHighQuality = QualityModeHigh; + SmoothingModeNone = 3; + SmoothingModeAntiAlias = 4; + +type + TSmoothingMode = SmoothingMode; + +{$ENDIF} + +//--------------------------------------------------------------------------- +// Text Rendering Hint +//--------------------------------------------------------------------------- + + TextRenderingHint = ( + TextRenderingHintSystemDefault, // Glyph with system default rendering hint + TextRenderingHintSingleBitPerPixelGridFit, // Glyph bitmap with hinting + TextRenderingHintSingleBitPerPixel, // Glyph bitmap without hinting + TextRenderingHintAntiAliasGridFit, // Glyph anti-alias bitmap with hinting + TextRenderingHintAntiAlias, // Glyph anti-alias bitmap without hinting + TextRenderingHintClearTypeGridFit // Glyph CT bitmap with hinting + ); + TTextRenderingHint = TextRenderingHint; + +//--------------------------------------------------------------------------- +// StringFormatFlags +//--------------------------------------------------------------------------- + +//--------------------------------------------------------------------------- +// String format flags +// +// DirectionRightToLeft - For horizontal text, the reading order is +// right to left. This value is called +// the base embedding level by the Unicode +// bidirectional engine. +// For vertical text, columns are read from +// right to left. +// By default, horizontal or vertical text is +// read from left to right. +// +// DirectionVertical - Individual lines of text are vertical. In +// each line, characters progress from top to +// bottom. +// By default, lines of text are horizontal, +// each new line below the previous line. +// +// NoFitBlackBox - Allows parts of glyphs to overhang the +// bounding rectangle. +// By default glyphs are first aligned +// inside the margines, then any glyphs which +// still overhang the bounding box are +// repositioned to avoid any overhang. +// For example when an italic +// lower case letter f in a font such as +// Garamond is aligned at the far left of a +// rectangle, the lower part of the f will +// reach slightly further left than the left +// edge of the rectangle. Setting this flag +// will ensure the character aligns visually +// with the lines above and below, but may +// cause some pixels outside the formatting +// rectangle to be clipped or painted. +// +// DisplayFormatControl - Causes control characters such as the +// left-to-right mark to be shown in the +// output with a representative glyph. +// +// NoFontFallback - Disables fallback to alternate fonts for +// characters not supported in the requested +// font. Any missing characters will be +// be displayed with the fonts missing glyph, +// usually an open square. +// +// NoWrap - Disables wrapping of text between lines +// when formatting within a rectangle. +// NoWrap is implied when a point is passed +// instead of a rectangle, or when the +// specified rectangle has a zero line length. +// +// NoClip - By default text is clipped to the +// formatting rectangle. Setting NoClip +// allows overhanging pixels to affect the +// device outside the formatting rectangle. +// Pixels at the end of the line may be +// affected if the glyphs overhang their +// cells, and either the NoFitBlackBox flag +// has been set, or the glyph extends to far +// to be fitted. +// Pixels above/before the first line or +// below/after the last line may be affected +// if the glyphs extend beyond their cell +// ascent / descent. This can occur rarely +// with unusual diacritic mark combinations. + +//--------------------------------------------------------------------------- + +Type + +//--------------------------------------------------------------------------- +// String alignment flags +//--------------------------------------------------------------------------- + + StringAlignment = ( + // Left edge for left-to-right text, + // right for right-to-left text, + // and top for vertical + StringAlignmentNear, + StringAlignmentCenter, + StringAlignmentFar + ); + TStringAlignment = StringAlignment; + + +//--------------------------------------------------------------------------- +// Trimming flags +//--------------------------------------------------------------------------- + + StringTrimming = ( + { + #define GDIPLUS_STRINGTRIMMING_None 0 && no trimming. + #define GDIPLUS_STRINGTRIMMING_Character 1 && nearest character. + #define GDIPLUS_STRINGTRIMMING_Word 2 && nearest wor + #define GDIPLUS_STRINGTRIMMING_EllipsisCharacter 3 && nearest character, ellipsis at end + #define GDIPLUS_STRINGTRIMMING_EllipsisWord 4 && nearest word, ellipsis at end + #define GDIPLUS_STRINGTRIMMING_EllipsisPath 5 && ellipsis in center, favouring last slash-delimited segment + } + StringTrimmingNone, + StringTrimmingCharacter, + StringTrimmingWord, + StringTrimmingEllipsisCharacter, + StringTrimmingEllipsisWord, + StringTrimmingEllipsisPath + ); + TStringTrimming = StringTrimming; + +//--------------------------------------------------------------------------- +// Hotkey prefix interpretation +//--------------------------------------------------------------------------- + + HotkeyPrefix = ( + HotkeyPrefixNone, + HotkeyPrefixShow, + HotkeyPrefixHide + ); + THotkeyPrefix = HotkeyPrefix; + +//--------------------------------------------------------------------------- +// Flush Intention flags +//--------------------------------------------------------------------------- + + FlushIntention = ( + FlushIntentionFlush, // Flush all batched rendering operations + FlushIntentionSync // Flush all batched rendering operations + // and wait for them to complete + ); + TFlushIntention = FlushIntention; + +//-------------------------------------------------------------------------- +// Status return values from GDI+ methods +//-------------------------------------------------------------------------- +type + Status = ( + Ok, + GenericError, + InvalidParameter, + OutOfMemory, + ObjectBusy, + InsufficientBuffer, + NotImplemented, + Win32Error, + WrongState, + Aborted, + FileNotFound, + ValueOverflow, + AccessDenied, + UnknownImageFormat, + FontFamilyNotFound, + FontStyleNotFound, + NotTrueTypeFont, + UnsupportedGdiplusVersion, + GdiplusNotInitialized, + PropertyNotFound, + PropertyNotSupported + ); + TStatus = Status; + +//-------------------------------------------------------------------------- +// Represents a location in a 2D coordinate system (floating-point coordinates) +//-------------------------------------------------------------------------- + +type + PGPPointF = ^TGPPointF; + TGPPointF = packed record + X : Single; + Y : Single; + end; + TPointFDynArray = array of TGPPointF; + + function MakePoint(X, Y: Single): TGPPointF; overload; + +//-------------------------------------------------------------------------- +// Represents a location in a 2D coordinate system (integer coordinates) +//-------------------------------------------------------------------------- + +type + PGPPoint = ^TGPPoint; + TGPPoint = packed record + X : Integer; + Y : Integer; + end; + TPointDynArray = array of TGPPoint; + + function MakePoint(X, Y: Integer): TGPPoint; overload; + +//-------------------------------------------------------------------------- +// Represents a rectangle in a 2D coordinate system (floating-point coordinates) +//-------------------------------------------------------------------------- + +type + PGPRectF = ^TGPRectF; + TGPRectF = packed record + X : Single; + Y : Single; + Width : Single; + Height: Single; + end; + TRectFDynArray = array of TGPRectF; + + function MakeRect(x, y, width, height: Single): TGPRectF; overload; + +type + PGPRect = ^TGPRect; + TGPRect = packed record + X : Integer; + Y : Integer; + Width : Integer; + Height: Integer; + end; + TRectDynArray = array of TGPRect; + + +(************************************************************************** +* +* GDI+ Startup and Shutdown APIs +* +**************************************************************************) +type + DebugEventLevel = ( + DebugEventLevelFatal, + DebugEventLevelWarning + ); + TDebugEventLevel = DebugEventLevel; + + // Callback function that GDI+ can call, on debug builds, for assertions + // and warnings. + + DebugEventProc = procedure(level: DebugEventLevel; message: PChar); stdcall; + + // Notification functions which the user must call appropriately if + // "SuppressBackgroundThread" (below) is set. + + NotificationHookProc = function(out token: ULONG): Status; stdcall; + + NotificationUnhookProc = procedure(token: ULONG); stdcall; + + // Input structure for GdiplusStartup + + GdiplusStartupInput = packed record + GdiplusVersion : Cardinal; // Must be 1 + DebugEventCallback : DebugEventProc; // Ignored on free builds + SuppressBackgroundThread: BOOL; // FALSE unless you're prepared to call + // the hook/unhook functions properly + SuppressExternalCodecs : BOOL; // FALSE unless you want GDI+ only to use + end; // its internal image codecs. + + TGdiplusStartupInput = GdiplusStartupInput; + PGdiplusStartupInput = ^TGdiplusStartupInput; + + // Output structure for GdiplusStartup() + + GdiplusStartupOutput = packed record + // The following 2 fields are NULL if SuppressBackgroundThread is FALSE. + // Otherwise, they are functions which must be called appropriately to + // replace the background thread. + // + // These should be called on the application's main message loop - i.e. + // a message loop which is active for the lifetime of GDI+. + // "NotificationHook" should be called before starting the loop, + // and "NotificationUnhook" should be called after the loop ends. + + NotificationHook : NotificationHookProc; + NotificationUnhook: NotificationUnhookProc; + end; + TGdiplusStartupOutput = GdiplusStartupOutput; + PGdiplusStartupOutput = ^TGdiplusStartupOutput; + + // GDI+ initialization. Must not be called from DllMain - can cause deadlock. + // + // Must be called before GDI+ API's or constructors are used. + // + // token - may not be NULL - accepts a token to be passed in the corresponding + // GdiplusShutdown call. + // input - may not be NULL + // output - may be NULL only if input->SuppressBackgroundThread is FALSE. + + {$EXTERNALSYM GdiplusStartup} + function GdiplusStartup(out token: ULONG; input: PGdiplusStartupInput; + output: PGdiplusStartupOutput): Status; stdcall; + + // GDI+ termination. Must be called before GDI+ is unloaded. + // Must not be called from DllMain - can cause deadlock. + // + // GDI+ API's may not be called after GdiplusShutdown. Pay careful attention + // to GDI+ object destructors. + + {$EXTERNALSYM GdiplusShutdown} + procedure GdiplusShutdown(token: ULONG); stdcall; + +type + PARGB = ^ARGB; + ARGB = DWORD; + {$EXTERNALSYM ARGB} + +type + + PGPColor = ^TGPColor; + {$EXTERNALSYM TGPCOLOR} + TGPColor = ARGB; + + function MakeColor(r, g, b: Byte): ARGB; overload; + function MakeColor(a, r, g, b: Byte): ARGB; overload; + function GetAlpha(color: ARGB): BYTE; + function GetRed(color: ARGB): BYTE; + function GetGreen(color: ARGB): BYTE; + function GetBlue(color: ARGB): BYTE; + +const + // Shift count and bit mask for A, R, G, B + AlphaShift = 24; + {$EXTERNALSYM AlphaShift} + RedShift = 16; + {$EXTERNALSYM RedShift} + GreenShift = 8; + {$EXTERNALSYM GreenShift} + BlueShift = 0; + {$EXTERNALSYM BlueShift} + + AlphaMask = $ff000000; + {$EXTERNALSYM AlphaMask} + RedMask = $00ff0000; + {$EXTERNALSYM RedMask} + GreenMask = $0000ff00; + {$EXTERNALSYM GreenMask} + BlueMask = $000000ff; + {$EXTERNALSYM BlueMask} + +type + PixelFormat = Integer; + {$EXTERNALSYM PixelFormat} + TPixelFormat = PixelFormat; + +const + PixelFormatIndexed = $00010000; // Indexes into a palette + {$EXTERNALSYM PixelFormatIndexed} + PixelFormatGDI = $00020000; // Is a GDI-supported format + {$EXTERNALSYM PixelFormatGDI} + PixelFormatAlpha = $00040000; // Has an alpha component + {$EXTERNALSYM PixelFormatAlpha} + PixelFormatPAlpha = $00080000; // Pre-multiplied alpha + {$EXTERNALSYM PixelFormatPAlpha} + PixelFormatExtended = $00100000; // Extended color 16 bits/channel + {$EXTERNALSYM PixelFormatExtended} + PixelFormatCanonical = $00200000; + {$EXTERNALSYM PixelFormatCanonical} + + PixelFormatUndefined = 0; + {$EXTERNALSYM PixelFormatUndefined} + PixelFormatDontCare = 0; + {$EXTERNALSYM PixelFormatDontCare} + + PixelFormat1bppIndexed = (1 or ( 1 shl 8) or PixelFormatIndexed or PixelFormatGDI); + {$EXTERNALSYM PixelFormat1bppIndexed} + PixelFormat4bppIndexed = (2 or ( 4 shl 8) or PixelFormatIndexed or PixelFormatGDI); + {$EXTERNALSYM PixelFormat4bppIndexed} + PixelFormat8bppIndexed = (3 or ( 8 shl 8) or PixelFormatIndexed or PixelFormatGDI); + {$EXTERNALSYM PixelFormat8bppIndexed} + PixelFormat16bppGrayScale = (4 or (16 shl 8) or PixelFormatExtended); + {$EXTERNALSYM PixelFormat16bppGrayScale} + PixelFormat16bppRGB555 = (5 or (16 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat16bppRGB555} + PixelFormat16bppRGB565 = (6 or (16 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat16bppRGB565} + PixelFormat16bppARGB1555 = (7 or (16 shl 8) or PixelFormatAlpha or PixelFormatGDI); + {$EXTERNALSYM PixelFormat16bppARGB1555} + PixelFormat24bppRGB = (8 or (24 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat24bppRGB} + PixelFormat32bppRGB = (9 or (32 shl 8) or PixelFormatGDI); + {$EXTERNALSYM PixelFormat32bppRGB} + PixelFormat32bppARGB = (10 or (32 shl 8) or PixelFormatAlpha or PixelFormatGDI or PixelFormatCanonical); + {$EXTERNALSYM PixelFormat32bppARGB} + PixelFormat32bppPARGB = (11 or (32 shl 8) or PixelFormatAlpha or PixelFormatPAlpha or PixelFormatGDI); + {$EXTERNALSYM PixelFormat32bppPARGB} + PixelFormat48bppRGB = (12 or (48 shl 8) or PixelFormatExtended); + {$EXTERNALSYM PixelFormat48bppRGB} + PixelFormat64bppARGB = (13 or (64 shl 8) or PixelFormatAlpha or PixelFormatCanonical or PixelFormatExtended); + {$EXTERNALSYM PixelFormat64bppARGB} + PixelFormat64bppPARGB = (14 or (64 shl 8) or PixelFormatAlpha or PixelFormatPAlpha or PixelFormatExtended); + {$EXTERNALSYM PixelFormat64bppPARGB} + PixelFormatMax = 15; + {$EXTERNALSYM PixelFormatMax} + +type + +{$IFDEF DELPHI6_UP} + RotateFlipType = ( + RotateNoneFlipNone = 0, + Rotate90FlipNone = 1, + Rotate180FlipNone = 2, + Rotate270FlipNone = 3, + + RotateNoneFlipX = 4, + Rotate90FlipX = 5, + Rotate180FlipX = 6, + Rotate270FlipX = 7, + + RotateNoneFlipY = Rotate180FlipX, + Rotate90FlipY = Rotate270FlipX, + Rotate180FlipY = RotateNoneFlipX, + Rotate270FlipY = Rotate90FlipX, + + RotateNoneFlipXY = Rotate180FlipNone, + Rotate90FlipXY = Rotate270FlipNone, + Rotate180FlipXY = RotateNoneFlipNone, + Rotate270FlipXY = Rotate90FlipNone + ); + TRotateFlipType = RotateFlipType; +{$ELSE} + + RotateFlipType = ( + RotateNoneFlipNone, // = 0, + Rotate90FlipNone, // = 1, + Rotate180FlipNone, // = 2, + Rotate270FlipNone, // = 3, + + RotateNoneFlipX, // = 4, + Rotate90FlipX, // = 5, + Rotate180FlipX, // = 6, + Rotate270FlipX // = 7, + ); + const + RotateNoneFlipY = Rotate180FlipX; + Rotate90FlipY = Rotate270FlipX; + Rotate180FlipY = RotateNoneFlipX; + Rotate270FlipY = Rotate90FlipX; + + RotateNoneFlipXY = Rotate180FlipNone; + Rotate90FlipXY = Rotate270FlipNone; + Rotate180FlipXY = RotateNoneFlipNone; + Rotate270FlipXY = Rotate90FlipNone; + +type + TRotateFlipType = RotateFlipType; +{$ENDIF} + +//--------------------------------------------------------------------------- +// Private GDI+ classes for internal type checking +//--------------------------------------------------------------------------- + + GpGraphics = Pointer; + + GpBrush = Pointer; + GpSolidFill = Pointer; + GpLineGradient = Pointer; + GpPathGradient = Pointer; + + GpPen = Pointer; + + GpImage = Pointer; + GpBitmap = Pointer; + + GpPath = Pointer; + GpRegion = Pointer; + + GpFontFamily = Pointer; + GpFont = Pointer; + GpStringFormat = Pointer; + GpFontCollection = Pointer; + + GpStatus = TStatus; + GpFillMode = TFillMode; + GpWrapMode = TWrapMode; + GpUnit = TUnit; + GpPointF = PGPPointF; + GpPoint = PGPPoint; + GpRectF = PGPRectF; + GpRect = PGPRect; + GpDashStyle = TDashStyle; + GpLineCap = TLineCap; + GpFlushIntention = TFlushIntention; + + function GdipCreatePath(brushMode: GPFILLMODE; + out path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePath} + + (* function GdipClonePath(path: GPPATH; + out clonePath: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipClonePath} + *) + function GdipDeletePath(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeletePath} + (* + function GdipStartPathFigure(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipStartPathFigure} + *) + function GdipClosePathFigure(path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipClosePathFigure} + + function GdipAddPathLine(path: GPPATH; + x1, y1, x2, y2: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathLine} + + function GdipAddPathArc(path: GPPATH; x, y, width, height, startAngle, + sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathArc} + + function GdipAddPathEllipse(path: GPPATH; x: Single; y: Single; + width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathEllipse} + + function GdipAddPathPie(path: GPPATH; x: Single; y: Single; width: Single; + height: Single; startAngle: Single; sweepAngle: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPie} + +//---------------------------------------------------------------------------- +// Brush APIs +//---------------------------------------------------------------------------- + + function GdipDeleteBrush(brush: GPBRUSH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteBrush} + +//---------------------------------------------------------------------------- +// SolidBrush APIs +//---------------------------------------------------------------------------- + + function GdipCreateSolidFill(color: ARGB; + out brush: GPSOLIDFILL): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateSolidFill} + +//---------------------------------------------------------------------------- +// LineBrush APIs +//---------------------------------------------------------------------------- + + function GdipCreateLineBrushFromRect(rect: GPRECTF; color1: ARGB; + color2: ARGB; mode: LINEARGRADIENTMODE; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushFromRect} + + function GdipCreateLineBrushFromRectI(rect: GPRECT; color1: ARGB; + color2: ARGB; mode: LINEARGRADIENTMODE; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushFromRectI} + + function GdipCreateLineBrushFromRectWithAngle(rect: GPRECTF; color1: ARGB; + color2: ARGB; angle: Single; isAngleScalable: Bool; wrapMode: GPWRAPMODE; + out lineGradient: GPLINEGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateLineBrushFromRectWithAngle} + +//---------------------------------------------------------------------------- +// PathGradientBrush APIs +//---------------------------------------------------------------------------- + + function GdipCreatePathGradient(points: GPPOINTF; count: Integer; + wrapMode: GPWRAPMODE; out polyGradient: GPPATHGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePathGradient} + + function GdipCreatePathGradientFromPath(path: GPPATH; + out polyGradient: GPPATHGRADIENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePathGradientFromPath} + + function GdipGetPathGradientCenterColor(brush: GPPATHGRADIENT; + out colors: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientCenterColor} + + function GdipSetPathGradientCenterColor(brush: GPPATHGRADIENT; + colors: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientCenterColor} + + function GdipGetPathGradientSurroundColorsWithCount(brush: GPPATHGRADIENT; + color: PARGB; var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientSurroundColorsWithCount} + + function GdipSetPathGradientSurroundColorsWithCount(brush: GPPATHGRADIENT; + color: PARGB; var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientSurroundColorsWithCount} + + function GdipGetPathGradientCenterPoint(brush: GPPATHGRADIENT; + points: GPPOINTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientCenterPoint} + + function GdipGetPathGradientCenterPointI(brush: GPPATHGRADIENT; + points: GPPOINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientCenterPointI} + + function GdipSetPathGradientCenterPoint(brush: GPPATHGRADIENT; + points: GPPOINTF): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientCenterPoint} + + function GdipSetPathGradientCenterPointI(brush: GPPATHGRADIENT; + points: GPPOINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPathGradientCenterPointI} + + function GdipGetPathGradientPointCount(brush: GPPATHGRADIENT; + var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientPointCount} + + function GdipGetPathGradientSurroundColorCount(brush: GPPATHGRADIENT; + var count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPathGradientSurroundColorCount} + +//---------------------------------------------------------------------------- +// Pen APIs +//---------------------------------------------------------------------------- + + function GdipCreatePen1(color: ARGB; width: Single; unit_: GPUNIT; + out pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreatePen1} + + function GdipDeletePen(pen: GPPEN): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeletePen} + +//---------------------------------------------------------------------------- +// Graphics APIs +//---------------------------------------------------------------------------- + + function GdipFlush(graphics: GPGRAPHICS; + intention: GPFLUSHINTENTION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFlush} + + function GdipCreateFromHDC(hdc: HDC; + out graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFromHDC} + + function GdipDeleteGraphics(graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteGraphics} + + function GdipGetDC(graphics: GPGRAPHICS; var hdc: HDC): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetDC} + + function GdipReleaseDC(graphics: GPGRAPHICS; hdc: HDC): GPSTATUS; stdcall; + {$EXTERNALSYM GdipReleaseDC} + + function GdipSetSmoothingMode(graphics: GPGRAPHICS; + smoothingMode: SMOOTHINGMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetSmoothingMode} + + function GdipGetSmoothingMode(graphics: GPGRAPHICS; + var smoothingMode: SMOOTHINGMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetSmoothingMode} + + function GdipSetTextRenderingHint(graphics: GPGRAPHICS; + mode: TEXTRENDERINGHINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetTextRenderingHint} + + function GdipGetTextRenderingHint(graphics: GPGRAPHICS; + var mode: TEXTRENDERINGHINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetTextRenderingHint} + + function GdipDrawRectangle(graphics: GPGRAPHICS; pen: GPPEN; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawRectangle} + + function GdipDrawRectangleI(graphics: GPGRAPHICS; pen: GPPEN; x: Integer; + y: Integer; width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawRectangleI} + + + function GdipDrawPath(graphics: GPGRAPHICS; pen: GPPEN; + path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawPath} + + function GdipFillRectangle(graphics: GPGRAPHICS; brush: GPBRUSH; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillRectangle} + + function GdipFillPath(graphics: GPGRAPHICS; brush: GPBRUSH; + path: GPPATH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipFillPath} + + function GdipDrawImageI(graphics: GPGRAPHICS; image: GPIMAGE; x: Integer; + y: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageI} + + function GdipDrawImage(graphics: GPGRAPHICS; image: GPIMAGE; x: Single; + y: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImage} + + function GdipDrawImageRect(graphics: GPGRAPHICS; image: GPIMAGE; x: Single; + y: Single; width: Single; height: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageRect} + + function GdipDrawImageRectI(graphics: GPGRAPHICS; image: GPIMAGE; x: Integer; + y: Integer; width: Integer; height: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawImageRectI} + + function GdipGetImageRawFormat(image: GPIMAGE; + format: PGUID): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageRawFormat} + + function GdipGetPenDashStyle(pen: GPPEN; + out dashstyle: GPDASHSTYLE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetPenDashStyle} + + function GdipSetPenDashStyle(pen: GPPEN; + dashstyle: GPDASHSTYLE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenDashStyle} + + function GdipSetClipRect(graphics: GPGRAPHICS; x: Single; y: Single; + width: Single; height: Single; combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipRect} + + function GdipSetClipRegion(graphics: GPGRAPHICS; region: GPREGION; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetClipRegion} + + function GdipCreateRegionRect(rect: GPRECTF; + out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegionRect} + + function GdipCreateRegionPath(path: GPPATH; + out region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateRegionPath} + + function GdipDeleteRegion(region: GPREGION): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteRegion} + + function GdipCombineRegionPath(region: GPREGION; path: GPPATH; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCombineRegionPath} + + function GdipCombineRegionRegion(region: GPREGION; region2: GPREGION; + combineMode: COMBINEMODE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCombineRegionRegion} + +//---------------------------------------------------------------------------- +// FontFamily APIs +//---------------------------------------------------------------------------- + + function GdipCreateFontFamilyFromName(name: PWCHAR; + fontCollection: GPFONTCOLLECTION; + out FontFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFontFamilyFromName} + + function GdipDeleteFontFamily(FontFamily: GPFONTFAMILY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteFontFamily} + +//---------------------------------------------------------------------------- +// Font APIs +//---------------------------------------------------------------------------- + + function GdipCreateFont(fontFamily: GPFONTFAMILY; emSize: Single; + style: Integer; unit_: Integer; out font: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateFont} + + function GdipDeleteFont(font: GPFONT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteFont} + +//---------------------------------------------------------------------------- +// Image APIs +//---------------------------------------------------------------------------- + + function GdipLoadImageFromStream(stream: ISTREAM; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromStream} + + function GdipLoadImageFromFileICM(filename: PWCHAR; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromFileICM} + + function GdipLoadImageFromFile(filename: PWCHAR; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromFile} + + function GdipLoadImageFromStreamICM(stream: ISTREAM; + out image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipLoadImageFromStreamICM} + + function GdipDisposeImage(image: GPIMAGE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDisposeImage} + + function GdipGetImageWidth(image: GPIMAGE; var width: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageWidth} + + function GdipGetImageHeight(image: GPIMAGE; var height: UINT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetImageHeight} + + +//---------------------------------------------------------------------------- +// Text APIs +//---------------------------------------------------------------------------- + + function GdipDrawString(graphics: GPGRAPHICS; string_: PWCHAR; + length: Integer; font: GPFONT; layoutRect: PGPRectF; + stringFormat: GPSTRINGFORMAT; brush: GPBRUSH): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDrawString} + + function GdipMeasureString(graphics: GPGRAPHICS; string_: PWCHAR; + length: Integer; font: GPFONT; layoutRect: PGPRectF; + stringFormat: GPSTRINGFORMAT; boundingBox: PGPRectF; + codepointsFitted: PInteger; linesFilled: PInteger): GPSTATUS; stdcall; + {$EXTERNALSYM GdipMeasureString} + + function GdipSetStringFormatHotkeyPrefix(format: GPSTRINGFORMAT; + hotkeyPrefix: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatHotkeyPrefix} + + function GdipGetStringFormatHotkeyPrefix(format: GPSTRINGFORMAT; + out hotkeyPrefix: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatHotkeyPrefix} + +//---------------------------------------------------------------------------- +// String format APIs +//---------------------------------------------------------------------------- + + function GdipCreateStringFormat(formatAttributes: Integer; language: LANGID; + out format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateStringFormat} + + function GdipDeleteStringFormat(format: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipDeleteStringFormat} + + function GdipCloneStringFormat(format: GPSTRINGFORMAT; + out newFormat: GPSTRINGFORMAT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCloneStringFormat} + + function GdipSetStringFormatAlign(format: GPSTRINGFORMAT; + align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatAlign} + + function GdipGetStringFormatAlign(format: GPSTRINGFORMAT; + out align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatAlign} + + function GdipSetStringFormatLineAlign(format: GPSTRINGFORMAT; + align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatLineAlign} + + function GdipGetStringFormatLineAlign(format: GPSTRINGFORMAT; + out align: STRINGALIGNMENT): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatLineAlign} + + + function GdipSetStringFormatTrimming(format: GPSTRINGFORMAT; + trimming: STRINGTRIMMING): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetStringFormatTrimming} + + function GdipGetStringFormatTrimming(format: GPSTRINGFORMAT; + out trimming: STRINGTRIMMING): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetStringFormatTrimming} + + function GdipSetCompositingQuality(graphics: GPGRAPHICS; + compositingQuality: COMPOSITINGQUALITY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetCompositingQuality} + + function GdipGetCompositingQuality(graphics: GPGRAPHICS; + var compositingQuality: COMPOSITINGQUALITY): GPSTATUS; stdcall; + {$EXTERNALSYM GdipGetCompositingQuality} + + function GdipImageRotateFlip(image: GPIMAGE; rfType: ROTATEFLIPTYPE): GPSTATUS; stdcall; + {$EXTERNALSYM GdipImageRotateFlip} + + function GdipCreateBitmapFromStreamICM(stream: ISTREAM; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromStreamICM} + + function GdipCreateBitmapFromStream(stream: ISTREAM; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromStream} + + function GdipCreateBitmapFromScan0(width: Integer; height: Integer; + stride: Integer; format: PIXELFORMAT; scan0: PBYTE; + out bitmap: GPBITMAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipCreateBitmapFromScan0} + + function GdipBitmapGetPixel(bitmap: GPBITMAP; x: Integer; y: Integer; + var color: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBitmapGetPixel} + + function GdipBitmapSetPixel(bitmap: GPBITMAP; x: Integer; y: Integer; + color: ARGB): GPSTATUS; stdcall; + {$EXTERNALSYM GdipBitmapSetPixel} + + function GdipSetPenEndCap(pen: GPPEN; endCap: GPLINECAP): GPSTATUS; stdcall; + {$EXTERNALSYM GdipSetPenEndCap} + + function GdipAddPathLine2I(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathLine2I} + + + function GdipAddPathPolygon(path: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPolygon} + + function GdipAddPathPolygonI(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathPolygonI} + + function GdipAddPathCurveI(path: GPPATH; points: GPPOINT; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurveI} + + function GdipAddPathCurve(path: GPPATH; points: GPPOINTF; + count: Integer): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurve} + + function GdipAddPathCurve2I(path: GPPATH; points: GPPOINT; count: Integer; + tension: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathCurve2I} + + function GdipResetClip(graphics: GPGRAPHICS): GPSTATUS; stdcall; + {$EXTERNALSYM GdipResetClip} + + function GdipAddPathBezier(path: GPPATH; + x1, y1, x2, y2, x3, y3, x4, y4: Single): GPSTATUS; stdcall; + {$EXTERNALSYM GdipAddPathBezier} + +//*************************************************************************** +//--------------------------------------------------------------------------- +// GDI+ classes for forward reference +//--------------------------------------------------------------------------- + +type + TGPGraphics = class; + TGPPen = class; + TGPBrush = class; + TGPFontFamily = class; + TGPGraphicsPath = class; + TGPSolidBrush = class; + TGPLinearGradientBrush = class; + TGPPathGradientBrush = class; + TGPFont = class; + TGPFontCollection = class; + +//------------------------------------------------------------------------------ +// GPRegion +//------------------------------------------------------------------------------ + TGPRegion = class(TGdiplusBase) + protected + nativeRegion: GpRegion; + lastResult: TStatus; + function SetStatus(status: TStatus): TStatus; + procedure SetNativeRegion(nativeRegion: GpRegion); + public + constructor Create(rect: TGPRectF); reintroduce; overload; + constructor Create(path: TGPGraphicsPath); reintroduce; overload; + destructor Destroy; override; + function Exclude(path: TGPGraphicsPath): TStatus; overload; + function Union(region: TGPRegion): TStatus; overload; + end; + +//-------------------------------------------------------------------------- +// FontFamily +//-------------------------------------------------------------------------- + + TGPFontFamily = class(TGdiplusBase) + protected + nativeFamily: GpFontFamily; + lastResult: TStatus; + function SetStatus(status: TStatus): TStatus; + public + constructor Create(nativeOrig: GpFontFamily; status: TStatus); reintroduce; overload; + constructor Create(name: WideString; fontCollection: TGPFontCollection = nil); reintroduce; overload; + destructor Destroy; override; + property Status: TStatus read lastResult; + end; + +//-------------------------------------------------------------------------- +// Font Collection +//-------------------------------------------------------------------------- + + TGPFontCollection = class(TGdiplusBase) + protected + nativeFontCollection: GpFontCollection; + lastResult: TStatus; + function SetStatus(status: TStatus): TStatus; + public + constructor Create; + destructor Destroy; override; + end; + +//-------------------------------------------------------------------------- +// TFont +//-------------------------------------------------------------------------- + + TGPFont = class(TGdiplusBase) + protected + nativeFont: GpFont; + lastResult: TStatus; + procedure SetNativeFont(Font: GpFont); + function SetStatus(status: TStatus): TStatus; + public + constructor Create(font: GpFont; status: TStatus); reintroduce; overload; + constructor Create(family: TGPFontFamily; emSize: Single; + style: TFontStyle = FontStyleRegular; + unit_: TUnit = UnitPoint); reintroduce; overload; + destructor Destroy; override; + property Status: TStatus read lastResult; + end; + +(**************************************************************************\ +* +* GDI+ Brush class +* +\**************************************************************************) + + //-------------------------------------------------------------------------- + // Abstract base class for various brush types + //-------------------------------------------------------------------------- + + TGPBrush = class(TGdiplusBase) + protected + nativeBrush: GpBrush; + lastResult: TStatus; + procedure SetNativeBrush(nativeBrush: GpBrush); + function SetStatus(status: TStatus): TStatus; + public + constructor Create(nativeBrush: GpBrush; status: TStatus); reintroduce; overload; + constructor Create; overload; + destructor Destroy; override; + end; + + //-------------------------------------------------------------------------- + // Solid Fill Brush Object + //-------------------------------------------------------------------------- + + TGPSolidBrush = class(TGPBrush) + public + constructor Create(color: TGPColor); reintroduce; overload; + constructor Create; reintroduce; overload; + end; + + //-------------------------------------------------------------------------- + // Linear Gradient Brush Object + //-------------------------------------------------------------------------- + + TGPLinearGradientBrush = class(TGPBrush) + public + constructor Create; reintroduce; overload; + constructor Create(rect: TGPRectF; color1, color2: TGPColor; + mode: TLinearGradientMode); reintroduce; overload; + constructor Create(rect: TGPRect; color1, color2: TGPColor; + mode: TLinearGradientMode); reintroduce; overload; + end; + +(**************************************************************************\ +* +* GDI+ Pen class +* +\**************************************************************************) + +//-------------------------------------------------------------------------- +// Pen class +//-------------------------------------------------------------------------- + + TGPPen = class(TGdiplusBase) + protected + nativePen: GpPen; + lastResult: TStatus; + procedure SetNativePen(nativePen: GpPen); + function SetStatus(status: TStatus): TStatus; + public + constructor Create(nativePen: GpPen; status: TStatus); reintroduce; overload; + constructor Create(color: TGPColor; width: Single = 1.0); reintroduce; overload; + destructor Destroy; override; + function GetDashStyle: TDashStyle; + function SetDashStyle(dashStyle: TDashStyle): TStatus; + function SetEndCap(endCap: TLineCap): TStatus; + end; + +(**************************************************************************\ +* +* GDI+ StringFormat class +* +\**************************************************************************) + + TGPStringFormat = class(TGdiplusBase) + protected + nativeFormat: GpStringFormat; + lastError: TStatus; + function SetStatus(newStatus: GpStatus): TStatus; + procedure Assign(source: TGPStringFormat); + public + constructor Create(clonedStringFormat: GpStringFormat; status: TStatus); reintroduce; overload; + constructor Create(formatFlags: Integer = 0; language: LANGID = LANG_NEUTRAL); reintroduce; overload; + destructor Destroy; override; + function SetAlignment(align: TStringAlignment): TStatus; + function GetAlignment: TStringAlignment; + function SetLineAlignment(align: TStringAlignment): TStatus; + function GetLineAlignment: TStringAlignment; + function SetTrimming(trimming: TStringTrimming): TStatus; + function GetTrimming: TStringTrimming; + function SetHotkeyPrefix(hotkeyPrefix: THotkeyPrefix): TStatus; + function GetHotkeyPrefix: THotkeyPrefix; + + end; + +(**************************************************************************\ +* +* GDI+ Graphics Path class +* +\**************************************************************************) + + TGPGraphicsPath = class(TGdiplusBase) + protected + nativePath: GpPath; + lastResult: TStatus; + procedure SetNativePath(nativePath: GpPath); + function SetStatus(status: TStatus): TStatus; + public + constructor Create(nativePath: GpPath); reintroduce; overload; + constructor Create(fillMode: TFillMode = FillModeAlternate); reintroduce; overload; + destructor Destroy; override; + + function CloseFigure: TStatus; + + function AddLine(const pt1, pt2: TGPPointF): TStatus; overload; + function AddLine(x1, y1, x2, y2: Single): TStatus; overload; + function AddLines(points: PGPPoint; count: Integer): TStatus; overload; + + function AddArc(rect: TGPRectF; startAngle, sweepAngle: Single): TStatus; overload; + function AddArc(x, y, width, height, startAngle, sweepAngle: Single): TStatus; overload; + + function AddEllipse(rect: TGPRectF): TStatus; overload; + function AddEllipse(x, y, width, height: Single): TStatus; overload; + + function AddPie(rect: TGPRectF; startAngle, sweepAngle: Single): TStatus; overload; + function AddPie(x, y, width, height, startAngle, sweepAngle: Single): TStatus; overload; + + function AddPolygon(points: PGPPointF; count: Integer): TStatus; overload; + function AddPolygon(points: PGPPoint; count: Integer): TStatus; overload; + + + function AddCurve(points: PGPPointF; count: Integer): TStatus; overload; + function AddCurve(points: PGPPoint; count: Integer): TStatus; overload; + function AddCurve(points: PGPPoint; count: Integer; tension: Single): TStatus; overload; + + function AddBezier(pt1, pt2, pt3, pt4: TGPPoint): TStatus; overload; + function AddBezier(pt1, pt2, pt3, pt4: TGPPointF): TStatus; overload; + function AddBezier(x1, y1, x2, y2, x3, y3, x4, y4: Single): TStatus; overload; + end; + +//-------------------------------------------------------------------------- +// Path Gradient Brush +//-------------------------------------------------------------------------- + + TGPPathGradientBrush = class(TGPBrush) + public + {constructor Create(points: PGPPointF; count: Integer; + wrapMode: TWrapMode = WrapModeClamp); reintroduce; overload; } + constructor Create(path: TGPGraphicsPath); reintroduce; //overload; + function GetCenterColor(out Color: TGPColor): TStatus; + function SetCenterColor(color: TGPColor): TStatus; + function GetPointCount: Integer; + function GetSurroundColors(colors: PARGB; var count: Integer): TStatus; + function SetSurroundColors(colors: PARGB; var count: Integer): TStatus; + function GetCenterPoint(out point: TGPPointF): TStatus; overload; + function GetCenterPoint(out point: TGPPoint): TStatus; overload; + function SetCenterPoint(point: TGPPointF): TStatus; overload; + function SetCenterPoint(point: TGPPoint): TStatus; overload; + end; + +(**************************************************************************\ +* TGPImage +***************************************************************************) + TGPImageFormat = (ifUndefined, ifMemoryBMP, ifBMP, ifEMF, ifWMF, ifJPEG, + ifPNG, ifGIF, ifTIFF, ifEXIF, ifIcon); + + TGPImage = class(TGdiplusBase) + protected + nativeImage: GpImage; + lastResult: TStatus; + loadStatus: TStatus; + procedure SetNativeImage(nativeImage: GpImage); + function SetStatus(status: TStatus): TStatus; + public + constructor Create(nativeImage: GpImage; status: TStatus); reintroduce; overload; + constructor Create(filename: WideString; useEmbeddedColorManagement: BOOL = FALSE); reintroduce; overload; + constructor Create(stream: IStream; useEmbeddedColorManagement: BOOL = FALSE); reintroduce; overload; + destructor Destroy; override; + function GetFormat: TGPImageFormat; + function GetWidth: UINT; + function GetHeight: UINT; + function RotateFlip(rotateFlipType: TRotateFlipType): TStatus; + end; + + TGPBitmap = class(TGPImage) + protected + constructor Create(nativeBitmap: GpBitmap); reintroduce; overload; + public + constructor Create(stream: IStream; useEmbeddedColorManagement: BOOL = FALSE); reintroduce; overload; + constructor Create(width, height: Integer; format: TPixelFormat = PixelFormat32bppARGB); reintroduce; overload; + function FromStream(stream: IStream; useEmbeddedColorManagement: BOOL = FALSE): TGPBitmap; + function GetPixel(x, y: Integer; out color: TGPColor): TStatus; + function SetPixel(x, y: Integer; color: TGPColor): TStatus; + end; + +(**************************************************************************\ +* +* GDI+ Graphics Object +* +\**************************************************************************) + + TGPGraphics = class(TGdiplusBase) + protected + nativeGraphics: GpGraphics; + lastResult: TStatus; + procedure SetNativeGraphics(graphics: GpGraphics); + function SetStatus(status: TStatus): TStatus; + function GetNativeGraphics: GpGraphics; + public + //constructor Create(graphics: GpGraphics); reintroduce; overload; + constructor Create(hdc: HDC); reintroduce; overload; + destructor Destroy; override; + procedure Flush(intention: TFlushIntention = FlushIntentionFlush); + //------------------------------------------------------------------------ + // GDI Interop methods + //------------------------------------------------------------------------ + // Locks the graphics until ReleaseDC is called + function GetHDC: HDC; + procedure ReleaseHDC(hdc: HDC); + //------------------------------------------------------------------------ + // Rendering modes + //------------------------------------------------------------------------ + function SetCompositingQuality(compositingQuality: TCompositingQuality): TStatus; + function GetCompositingQuality: TCompositingQuality; + + function SetTextRenderingHint(newMode: TTextRenderingHint): TStatus; + function GetTextRenderingHint: TTextRenderingHint; + function GetSmoothingMode: TSmoothingMode; + function SetSmoothingMode(smoothingMode: TSmoothingMode): TStatus; + // DrawPath + function DrawPath(pen: TGPPen; path: TGPGraphicsPath): TStatus; + // FillRectangle(s) + function FillRectangle(brush: TGPBrush; const rect: TGPRectF): TStatus; overload; + function FillRectangle(brush: TGPBrush; x, y, width, height: Single): TStatus; overload; + // DrawString + function DrawString(string_: String; length: Integer; font: TGPFont; + const layoutRect: TGPRectF; stringFormat: TGPStringFormat; brush: TGPBrush): TStatus; overload; + {$IFDEF DELPHI6_LVL} + function DrawString(string_: widestring; length: Integer; font: TGPFont; + const layoutRect: TGPRectF; stringFormat: TGPStringFormat; brush: TGPBrush): TStatus; overload; + {$ENDIF} + // MeasureString + function MeasureString(string_: WideString; length: Integer; font: TGPFont; + const layoutRect: TGPRectF; stringFormat: TGPStringFormat; out boundingBox: TGPRectF; + codepointsFitted: PInteger = nil; linesFilled: PInteger = nil): TStatus; overload; + function GetLastStatus: TStatus; + // DrawRectangle + function DrawRectangle(pen: TGPPen; const rect: TGPRectF): TStatus; overload; + function DrawRectangle(pen: TGPPen; x, y, width, height: Single): TStatus; overload; + // DrawImage + function DrawImage(image: TGPImage; x, y: Integer): TStatus; overload; + function DrawImageRect(image: TGPImage; x, y, w, h: Integer): TStatus; overload; + // FillPath + function FillPath(brush: TGPBrush; path: TGPGraphicsPath): TStatus; + // Clip + function ExcludeClip(const rect: TGPRectF): TStatus; overload; + function ExcludeClip(region: TGPRegion): TStatus; overload; + function SetClip(region: TGPRegion; combineMode: TCombineMode = CombineModeReplace): TStatus; + function ResetClip: TStatus; + end; + + function ColorToARGB(Color: TColor): ARGB; + +//////////////////////////////////////////////////////////////////////////////// + +var + StartupInput: TGDIPlusStartupInput; + StartupOutput: TGdiplusStartupOutput; + gdiplusToken: ULONG; + + + +implementation + +function ColorToARGB(Color: TColor): ARGB; +var + c: TColor; +begin + c := ColorToRGB(Color); + Result := ARGB( $FF000000 or ((DWORD(c) and $FF) shl 16) or ((DWORD(c) and $FF00) or ((DWORD(c) and $ff0000) shr 16))); +end; + + + function GdipAlloc; external WINGDIPDLL name 'GdipAlloc'; + procedure GdipFree; external WINGDIPDLL name 'GdipFree'; + function GdiplusStartup; external WINGDIPDLL name 'GdiplusStartup'; + procedure GdiplusShutdown; external WINGDIPDLL name 'GdiplusShutdown'; + + function GdipCreatePath; external WINGDIPDLL name 'GdipCreatePath'; + function GdipDeletePath; external WINGDIPDLL name 'GdipDeletePath'; + //function GdipStartPathFigure; external WINGDIPDLL name 'GdipStartPathFigure'; + function GdipClosePathFigure; external WINGDIPDLL name 'GdipClosePathFigure'; + function GdipAddPathLine; external WINGDIPDLL name 'GdipAddPathLine'; + function GdipAddPathArc; external WINGDIPDLL name 'GdipAddPathArc'; + function GdipAddPathEllipse; external WINGDIPDLL name 'GdipAddPathEllipse'; + function GdipAddPathPie; external WINGDIPDLL name 'GdipAddPathPie'; + function GdipDeleteBrush; external WINGDIPDLL name 'GdipDeleteBrush'; + function GdipCreateSolidFill; external WINGDIPDLL name 'GdipCreateSolidFill'; + function GdipCreateLineBrushFromRect; external WINGDIPDLL name 'GdipCreateLineBrushFromRect'; + function GdipCreateLineBrushFromRectI; external WINGDIPDLL name 'GdipCreateLineBrushFromRectI'; + function GdipCreateLineBrushFromRectWithAngle; external WINGDIPDLL name 'GdipCreateLineBrushFromRectWithAngle'; + function GdipCreatePathGradient; external WINGDIPDLL name 'GdipCreatePathGradient'; + function GdipCreatePathGradientFromPath; external WINGDIPDLL name 'GdipCreatePathGradientFromPath'; + function GdipGetPathGradientCenterColor; external WINGDIPDLL name 'GdipGetPathGradientCenterColor'; + function GdipSetPathGradientCenterColor; external WINGDIPDLL name 'GdipSetPathGradientCenterColor'; + function GdipGetPathGradientSurroundColorsWithCount; external WINGDIPDLL name 'GdipGetPathGradientSurroundColorsWithCount'; + function GdipSetPathGradientSurroundColorsWithCount; external WINGDIPDLL name 'GdipSetPathGradientSurroundColorsWithCount'; + function GdipGetPathGradientCenterPoint; external WINGDIPDLL name 'GdipGetPathGradientCenterPoint'; + function GdipGetPathGradientCenterPointI; external WINGDIPDLL name 'GdipGetPathGradientCenterPointI'; + function GdipSetPathGradientCenterPoint; external WINGDIPDLL name 'GdipSetPathGradientCenterPoint'; + function GdipSetPathGradientCenterPointI; external WINGDIPDLL name 'GdipSetPathGradientCenterPointI'; + function GdipGetPathGradientPointCount; external WINGDIPDLL name 'GdipGetPathGradientPointCount'; + function GdipGetPathGradientSurroundColorCount; external WINGDIPDLL name 'GdipGetPathGradientSurroundColorCount'; + function GdipCreatePen1; external WINGDIPDLL name 'GdipCreatePen1'; + function GdipDeletePen; external WINGDIPDLL name 'GdipDeletePen'; + function GdipFlush; external WINGDIPDLL name 'GdipFlush'; + function GdipCreateFromHDC; external WINGDIPDLL name 'GdipCreateFromHDC'; + function GdipDeleteGraphics; external WINGDIPDLL name 'GdipDeleteGraphics'; + function GdipGetDC; external WINGDIPDLL name 'GdipGetDC'; + function GdipReleaseDC; external WINGDIPDLL name 'GdipReleaseDC'; + function GdipSetSmoothingMode; external WINGDIPDLL name 'GdipSetSmoothingMode'; + function GdipGetSmoothingMode; external WINGDIPDLL name 'GdipGetSmoothingMode'; + function GdipSetTextRenderingHint; external WINGDIPDLL name 'GdipSetTextRenderingHint'; + function GdipGetTextRenderingHint; external WINGDIPDLL name 'GdipGetTextRenderingHint'; + function GdipDrawPath; external WINGDIPDLL name 'GdipDrawPath'; + function GdipFillRectangle; external WINGDIPDLL name 'GdipFillRectangle'; + function GdipCreateFontFamilyFromName; external WINGDIPDLL name 'GdipCreateFontFamilyFromName'; + function GdipDeleteFontFamily; external WINGDIPDLL name 'GdipDeleteFontFamily'; + function GdipCreateFont; external WINGDIPDLL name 'GdipCreateFont'; + function GdipDeleteFont; external WINGDIPDLL name 'GdipDeleteFont'; + function GdipDrawString; external WINGDIPDLL name 'GdipDrawString'; + function GdipMeasureString; external WINGDIPDLL name 'GdipMeasureString'; + function GdipCreateStringFormat; external WINGDIPDLL name 'GdipCreateStringFormat'; + function GdipDeleteStringFormat; external WINGDIPDLL name 'GdipDeleteStringFormat'; + function GdipCloneStringFormat; external WINGDIPDLL name 'GdipCloneStringFormat'; + function GdipSetStringFormatAlign; external WINGDIPDLL name 'GdipSetStringFormatAlign'; + function GdipGetStringFormatAlign; external WINGDIPDLL name 'GdipGetStringFormatAlign'; + function GdipSetStringFormatLineAlign; external WINGDIPDLL name 'GdipSetStringFormatLineAlign'; + function GdipGetStringFormatLineAlign; external WINGDIPDLL name 'GdipGetStringFormatLineAlign'; + function GdipSetStringFormatTrimming; external WINGDIPDLL name 'GdipSetStringFormatTrimming'; + function GdipGetStringFormatTrimming; external WINGDIPDLL name 'GdipGetStringFormatTrimming'; + function GdipGetImageRawFormat; external WINGDIPDLL name 'GdipGetImageRawFormat'; + function GdipDrawImage; external WINGDIPDLL name 'GdipDrawImage'; + function GdipDrawImageI; external WINGDIPDLL name 'GdipDrawImageI'; + function GdipDrawImageRect; external WINGDIPDLL name 'GdipDrawImageRect'; + function GdipDrawImageRectI; external WINGDIPDLL name 'GdipDrawImageRectI'; + function GdipDrawRectangle; external WINGDIPDLL name 'GdipDrawRectangle'; + function GdipDrawRectangleI; external WINGDIPDLL name 'GdipDrawRectangleI'; + function GdipFillPath; external WINGDIPDLL name 'GdipFillPath'; + function GdipLoadImageFromFileICM; external WINGDIPDLL name 'GdipLoadImageFromFileICM'; + function GdipLoadImageFromFile; external WINGDIPDLL name 'GdipLoadImageFromFile'; + function GdipLoadImageFromStream; external WINGDIPDLL name 'GdipLoadImageFromStream'; + function GdipLoadImageFromStreamICM; external WINGDIPDLL name 'GdipLoadImageFromStreamICM'; + function GdipDisposeImage; external WINGDIPDLL name 'GdipDisposeImage'; + function GdipGetImageWidth; external WINGDIPDLL name 'GdipGetImageWidth'; + function GdipGetImageHeight; external WINGDIPDLL name 'GdipGetImageHeight'; + function GdipGetPenDashStyle; external WINGDIPDLL name 'GdipGetPenDashStyle'; + function GdipSetPenDashStyle; external WINGDIPDLL name 'GdipSetPenDashStyle'; + function GdipSetStringFormatHotkeyPrefix; external WINGDIPDLL name 'GdipSetStringFormatHotkeyPrefix'; + function GdipGetStringFormatHotkeyPrefix; external WINGDIPDLL name 'GdipGetStringFormatHotkeyPrefix'; + function GdipSetClipRect; external WINGDIPDLL name 'GdipSetClipRect'; + function GdipSetClipRegion; external WINGDIPDLL name 'GdipSetClipRegion'; + function GdipCreateRegionRect; external WINGDIPDLL name 'GdipCreateRegionRect'; + function GdipCreateRegionPath; external WINGDIPDLL name 'GdipCreateRegionPath'; + function GdipDeleteRegion; external WINGDIPDLL name 'GdipDeleteRegion'; + function GdipCombineRegionPath; external WINGDIPDLL name 'GdipCombineRegionPath'; + function GdipCombineRegionRegion; external WINGDIPDLL name 'GdipCombineRegionRegion'; + function GdipSetCompositingQuality; external WINGDIPDLL name 'GdipSetCompositingQuality'; + function GdipGetCompositingQuality; external WINGDIPDLL name 'GdipGetCompositingQuality'; + function GdipImageRotateFlip; external WINGDIPDLL name 'GdipImageRotateFlip'; + function GdipCreateBitmapFromStreamICM; external WINGDIPDLL name 'GdipCreateBitmapFromStreamICM'; + function GdipCreateBitmapFromStream; external WINGDIPDLL name 'GdipCreateBitmapFromStream'; + function GdipCreateBitmapFromScan0; external WINGDIPDLL name 'GdipCreateBitmapFromScan0'; + function GdipBitmapGetPixel; external WINGDIPDLL name 'GdipBitmapGetPixel'; + function GdipBitmapSetPixel; external WINGDIPDLL name 'GdipBitmapSetPixel'; + function GdipSetPenEndCap; external WINGDIPDLL name 'GdipSetPenEndCap'; + function GdipAddPathLine2I; external WINGDIPDLL name 'GdipAddPathLine2I'; + + function GdipAddPathPolygon; external WINGDIPDLL name 'GdipAddPathPolygon'; + function GdipAddPathPolygonI; external WINGDIPDLL name 'GdipAddPathPolygonI'; + function GdipAddPathCurveI; external WINGDIPDLL name 'GdipAddPathCurveI'; + function GdipAddPathCurve; external WINGDIPDLL name 'GdipAddPathCurve'; + function GdipAddPathCurve2I; external WINGDIPDLL name 'GdipAddPathCurve2I'; + function GdipResetClip; external WINGDIPDLL name 'GdipResetClip'; + function GdipAddPathBezier; external WINGDIPDLL name 'GdipAddPathBezier'; +// ----------------------------------------------------------------------------- +// TGdiplusBase class +// ----------------------------------------------------------------------------- + + +class function TGdiplusBase.NewInstance: TObject; +var + p : pointer; + sz : ULONG; +begin + { Note: GidpAlloc may fail on Windows XP if application is started from + Delphi 2007 in debug mode. + The reason for this fix is to workaround the following problem: + After an application with a TAdvOfficeToolBar executes a standard TOpenDialog, + an exception is raised while drawing the officetoolbar. } + sz := ULONG(InstanceSize); + p := GdipAlloc(sz); + if not Assigned(p) then + begin + //GdipAlloc failed --> restart GDI+ and try again + GdiplusStartup(gdiplusToken, @StartupInput, @StartupOutput); + p := GdipAlloc(sz); + end; + Result := InitInstance(p); +end; + +procedure TGdiplusBase.FreeInstance; +begin + CleanupInstance; + GdipFree(Self); +end; + + +//-------------------------------------------------------------------------- +// TGPPoint Util +//-------------------------------------------------------------------------- + +function MakePoint(X, Y: Integer): TGPPoint; +begin + result.X := X; + result.Y := Y; +end; + +function MakePoint(X, Y: Single): TGPPointF; +begin + Result.X := X; + result.Y := Y; +end; + +// ----------------------------------------------------------------------------- +// RectF class +// ----------------------------------------------------------------------------- + +function MakeRect(x, y, width, height: Single): TGPRectF; overload; +begin + Result.X := x; + Result.Y := y; + Result.Width := width; + Result.Height := height; +end; + + +//****************************************************************************** +(**************************************************************************\ +* +* GDI+ StringFormat class +* +\**************************************************************************) + +constructor TGPStringFormat.Create(formatFlags: Integer = 0; language: LANGID = LANG_NEUTRAL); +begin + nativeFormat := nil; + lastError := GdipCreateStringFormat(formatFlags, language, nativeFormat); +end; + +destructor TGPStringFormat.Destroy; +begin + GdipDeleteStringFormat(nativeFormat); +end; + +function TGPStringFormat.SetAlignment(align: TStringAlignment): TStatus; +begin + result := SetStatus(GdipSetStringFormatAlign(nativeFormat, align)); +end; + +function TGPStringFormat.GetAlignment: TStringAlignment; +begin + SetStatus(GdipGetStringFormatAlign(nativeFormat, result)); +end; + +function TGPStringFormat.SetLineAlignment(align: TStringAlignment): TStatus; +begin + result := SetStatus(GdipSetStringFormatLineAlign(nativeFormat, align)); +end; + +function TGPStringFormat.GetLineAlignment: TStringAlignment; +begin + SetStatus(GdipGetStringFormatLineAlign(nativeFormat, result)); +end; + + +function TGPStringFormat.SetTrimming(trimming: TStringTrimming): TStatus; +begin + result := SetStatus(GdipSetStringFormatTrimming(nativeFormat, trimming)); +end; + +function TGPStringFormat.GetTrimming: TStringTrimming; +begin + SetStatus(GdipGetStringFormatTrimming(nativeFormat, result)); +end; + +function TGPStringFormat.SetHotkeyPrefix(hotkeyPrefix: THotkeyPrefix): TStatus; +begin + result := SetStatus(GdipSetStringFormatHotkeyPrefix(nativeFormat, Integer(hotkeyPrefix))); +end; + +function TGPStringFormat.GetHotkeyPrefix: THotkeyPrefix; +var HotkeyPrefix: Integer; +begin + SetStatus(GdipGetStringFormatHotkeyPrefix(nativeFormat, HotkeyPrefix)); + result := THotkeyPrefix(HotkeyPrefix); +end; + + +function TGPStringFormat.SetStatus(newStatus: GpStatus): TStatus; +begin + if (newStatus <> Ok) then lastError := newStatus; + result := newStatus; +end; + +// operator = +procedure TGPStringFormat.Assign(source: TGPStringFormat); +begin + assert(assigned(source)); + GdipDeleteStringFormat(nativeFormat); + lastError := GdipCloneStringFormat(source.nativeFormat, nativeFormat); +end; + +constructor TGPStringFormat.Create(clonedStringFormat: GpStringFormat; status: TStatus); +begin + lastError := status; + nativeFormat := clonedStringFormat; +end; + +(**************************************************************************\ +* +* GDI+ Pen class +* +\**************************************************************************) + +//-------------------------------------------------------------------------- +// Pen class +//-------------------------------------------------------------------------- + +constructor TGPPen.Create(color: TGPColor; width: Single = 1.0); +var unit_: TUnit; +begin + unit_ := UnitWorld; + nativePen := nil; + lastResult := GdipCreatePen1(color, width, unit_, nativePen); +end; + +destructor TGPPen.Destroy; +begin + GdipDeletePen(nativePen); +end; + +constructor TGPPen.Create(nativePen: GpPen; status: TStatus); +begin + lastResult := status; + SetNativePen(nativePen); +end; + +procedure TGPPen.SetNativePen(nativePen: GpPen); +begin + self.nativePen := nativePen; +end; + +function TGPPen.SetStatus(status: TStatus): TStatus; +begin + if (status <> Ok) then lastResult := status; + result := status; +end; + +function TGPPen.GetDashStyle: TDashStyle; +begin + SetStatus(GdipGetPenDashStyle(nativePen, result)); +end; + +function TGPPen.SetDashStyle(dashStyle: TDashStyle): TStatus; +begin + result := SetStatus(GdipSetPenDashStyle(nativePen, dashStyle)); +end; + +function TGPPen.SetEndCap(endCap: TLineCap): TStatus; +begin + result := SetStatus(GdipSetPenEndCap(nativePen, endCap)); +end; + + +(**************************************************************************\ +* +* GDI+ Brush class +* +\**************************************************************************) + +//-------------------------------------------------------------------------- +// Abstract base class for various brush types +//-------------------------------------------------------------------------- + +destructor TGPBrush.Destroy; +begin + GdipDeleteBrush(nativeBrush); +end; + +constructor TGPBrush.Create; +begin + SetStatus(NotImplemented); +end; + +constructor TGPBrush.Create(nativeBrush: GpBrush; status: TStatus); +begin + lastResult := status; + SetNativeBrush(nativeBrush); +end; + +procedure TGPBrush.SetNativeBrush(nativeBrush: GpBrush); +begin + self.nativeBrush := nativeBrush; +end; + +function TGPBrush.SetStatus(status: TStatus): TStatus; +begin + if (status <> Ok) then lastResult := status; + result := status; +end; + +//-------------------------------------------------------------------------- +// Solid Fill Brush Object +//-------------------------------------------------------------------------- + +constructor TGPSolidBrush.Create(color: TGPColor); +var + brush: GpSolidFill; +begin + brush := nil; + lastResult := GdipCreateSolidFill(color, brush); + SetNativeBrush(brush); +end; + +constructor TGPSolidBrush.Create; +begin + // hide parent function +end; + +//-------------------------------------------------------------------------- +// Linear Gradient Brush Object +//-------------------------------------------------------------------------- + +constructor TGPLinearGradientBrush.Create(rect: TGPRectF; color1, color2: TGPColor; mode: TLinearGradientMode); +var brush: GpLineGradient; +begin + brush := nil; + lastResult := GdipCreateLineBrushFromRect(@rect, color1, + color2, mode, WrapModeTile, brush); + SetNativeBrush(brush); +end; + +constructor TGPLinearGradientBrush.Create(rect: TGPRect; color1, color2: TGPColor; mode: TLinearGradientMode); +var brush: GpLineGradient; +begin + brush := nil; + lastResult := GdipCreateLineBrushFromRectI(@rect, color1, + color2, mode, WrapModeTile, brush); + SetNativeBrush(brush); +end; + +constructor TGPLinearGradientBrush.Create; +begin + // hide parent function +end; + +(**************************************************************************\ +* +* GDI+ Graphics Object +* +\**************************************************************************) + +constructor TGPGraphics.Create(hdc: HDC); +var + graphics: GpGraphics; +begin + graphics:= nil; + lastResult := GdipCreateFromHDC(hdc, graphics); + SetNativeGraphics(graphics); +end; + +destructor TGPGraphics.Destroy; +begin + GdipDeleteGraphics(nativeGraphics); +end; + +procedure TGPGraphics.Flush(intention: TFlushIntention = FlushIntentionFlush); +begin + GdipFlush(nativeGraphics, intention); +end; + +//------------------------------------------------------------------------ +// GDI Interop methods +//------------------------------------------------------------------------ + +// Locks the graphics until ReleaseDC is called + +function TGPGraphics.GetHDC: HDC; +begin + SetStatus(GdipGetDC(nativeGraphics, result)); +end; + +procedure TGPGraphics.ReleaseHDC(hdc: HDC); +begin + SetStatus(GdipReleaseDC(nativeGraphics, hdc)); +end; + +function TGPGraphics.SetTextRenderingHint(newMode: TTextRenderingHint): TStatus; +begin + result := SetStatus(GdipSetTextRenderingHint(nativeGraphics, newMode)); +end; + +function TGPGraphics.GetTextRenderingHint: TTextRenderingHint; +begin + SetStatus(GdipGetTextRenderingHint(nativeGraphics, result)); +end; + +function TGPGraphics.GetSmoothingMode: TSmoothingMode; +var + smoothingMode: TSmoothingMode; +begin + smoothingMode := SmoothingModeInvalid; + SetStatus(GdipGetSmoothingMode(nativeGraphics, smoothingMode)); + result := smoothingMode; +end; + +function TGPGraphics.SetSmoothingMode(smoothingMode: TSmoothingMode): TStatus; +begin + result := SetStatus(GdipSetSmoothingMode(nativeGraphics, smoothingMode)); +end; + +function TGPGraphics.DrawPath(pen: TGPPen; path: TGPGraphicsPath): TStatus; +var + nPen: GpPen; + nPath: GpPath; +begin + if Assigned(pen) then + nPen := pen.nativePen + else + nPen := nil; + if Assigned(path) then + nPath := path.nativePath + else + nPath := nil; + Result := SetStatus(GdipDrawPath(nativeGraphics, nPen, nPath)); +end; + +function TGPGraphics.FillRectangle(brush: TGPBrush; const rect: TGPRectF): TStatus; +begin + Result := FillRectangle(brush, rect.X, rect.Y, rect.Width, rect.Height); +end; + +function TGPGraphics.FillRectangle(brush: TGPBrush; x, y, width, height: Single): TStatus; +begin + result := SetStatus(GdipFillRectangle(nativeGraphics, brush.nativeBrush, x, y, + width, height)); +end; + +function TGPGraphics.DrawString( string_: string; length: Integer; font: TGPFont; + const layoutRect: TGPRectF; stringFormat: TGPStringFormat; brush: TGPBrush): TStatus; +var + nFont: GpFont; + nStringFormat: GpStringFormat; + nBrush: GpBrush; + wCh: PWidechar; + i: integer; +begin + if Assigned(font) then + nfont := font.nativeFont + else + nfont := nil; + if Assigned(stringFormat) then + nstringFormat := stringFormat.nativeFormat + else + nstringFormat := nil; + + {charset issue} + i := System.Length(string_); + GetMem(wCh, i * 2 + 2); + FillChar(wCh^, i * 2 + 2,0); + StringToWidechar(string_, wCh, i * 2 + 2); + {/charset issue} + + if Assigned(brush) then + nbrush := brush.nativeBrush + else + nbrush := nil; +// Result := SetStatus(GdipDrawString(nativeGraphics, PWideChar(string_), +// length, nfont, @layoutRect, nstringFormat, nbrush)); + + {charset issue} + Result := SetStatus(GdipDrawString(nativeGraphics, wCh, + length, nfont, @layoutRect, nstringFormat, nbrush)); + + FreeMem(wCh); + {/charset issue} +end; + +{$IFDEF DELPHI6_LVL} +function TGPGraphics.DrawString( string_: widestring; length: Integer; font: TGPFont; + const layoutRect: TGPRectF; stringFormat: TGPStringFormat; brush: TGPBrush): TStatus; +var + nFont: GpFont; + nStringFormat: GpStringFormat; + nBrush: GpBrush; +begin + if Assigned(font) then + nfont := font.nativeFont + else + nfont := nil; + if Assigned(stringFormat) then + nstringFormat := stringFormat.nativeFormat + else + nstringFormat := nil; + + if Assigned(brush) then + nbrush := brush.nativeBrush + else + nbrush := nil; + + Result := SetStatus(GdipDrawString(nativeGraphics, PWideChar(string_), + length, nfont, @layoutRect, nstringFormat, nbrush)); +end; +{$ENDIF} + +function TGPGraphics.MeasureString(string_: WideString; length: Integer; font: TGPFont; + const layoutRect: TGPRectF; stringFormat: TGPStringFormat; out boundingBox: TGPRectF; + codepointsFitted: PInteger = nil; linesFilled: PInteger = nil): TStatus; +var + nFont: GpFont; + nStringFormat: GpStringFormat; +begin + if Assigned(font) then + nfont := font.nativeFont + else + nfont := nil; + if Assigned(stringFormat) then + nstringFormat := stringFormat.nativeFormat + else + nstringFormat := nil; + + Result := SetStatus(GdipMeasureString(nativeGraphics, PWideChar(string_), + length, nfont, @layoutRect, nstringFormat, @boundingBox, codepointsFitted, + linesFilled)); +end; + +function TGPGraphics.GetLastStatus: TStatus; +begin + result := lastResult; + lastResult := Ok; +end; + +{ +constructor TGPGraphics.Create(graphics: GpGraphics); +begin + lastResult := Ok; + SetNativeGraphics(graphics); +end; +} + +procedure TGPGraphics.SetNativeGraphics(graphics: GpGraphics); +begin + self.nativeGraphics := graphics; +end; + +function TGPGraphics.SetStatus(status: TStatus): TStatus; +begin + if (status <> Ok) then + lastResult := status; + result := status; +end; + +function TGPGraphics.GetNativeGraphics: GpGraphics; +begin + result := self.nativeGraphics; +end; + +//------------------------------------------------------------------------------ + + constructor TGPRegion.Create(rect: TGPRectF); + var + region: GpRegion; + begin + region := nil; + lastResult := GdipCreateRegionRect(@rect, region); + SetNativeRegion(region); + end; + + constructor TGPRegion.Create(path: TGPGraphicsPath); + var + region: GpRegion; + begin + region := nil; + lastResult := GdipCreateRegionPath(path.nativePath, region); + SetNativeRegion(region); + end; + + destructor TGPRegion.Destroy; + begin + GdipDeleteRegion(nativeRegion); + end; + + function TGPRegion.Exclude(path: TGPGraphicsPath): TStatus; + begin + result := SetStatus(GdipCombineRegionPath(nativeRegion, path.nativePath, CombineModeExclude)); + end; + + function TGPRegion.SetStatus(status: TStatus): TStatus; + begin + if (status <> Ok) then lastResult := status; + result := status; + end; + + procedure TGPRegion.SetNativeRegion(nativeRegion: GpRegion); + begin + self.nativeRegion := nativeRegion; + end; + + function TGPRegion.Union(region: TGPRegion): TStatus; + begin + result := SetStatus(GdipCombineRegionRegion(nativeRegion, region.nativeRegion, + CombineModeUnion)); + end; + +(**************************************************************************\ +* +* GDI+ Font Family class +* +\**************************************************************************) + + constructor TGPFontFamily.Create(name: WideString; fontCollection: TGPFontCollection = nil); + var nfontCollection: GpfontCollection; + begin + nativeFamily := nil; + if assigned(fontCollection) then nfontCollection := fontCollection.nativeFontCollection else nfontCollection := nil; + lastResult := GdipCreateFontFamilyFromName(PWideChar(name), nfontCollection, nativeFamily); + end; + + destructor TGPFontFamily.Destroy; + begin + GdipDeleteFontFamily (nativeFamily); + end; + + function TGPFontFamily.SetStatus(status: TStatus): TStatus; + begin + if (status <> Ok) then lastResult := status; + result := status; + end; + + constructor TGPFontFamily.Create(nativeOrig: GpFontFamily; status: TStatus); + begin + lastResult := status; + nativeFamily := nativeOrig; + end; + +(**************************************************************************\ +* +* GDI+ Font class +* +\**************************************************************************) + + constructor TGPFont.Create(family: TGPFontFamily; emSize: Single; + style: TFontStyle = FontStyleRegular; unit_: TUnit = UnitPoint); + var + font: GpFont; + nFontFamily: GpFontFamily; + begin + font := nil; + if Assigned(Family) then + nFontFamily := Family.nativeFamily + else + nFontFamily := nil; + + lastResult := GdipCreateFont(nFontFamily, emSize, Integer(style), Integer(unit_), font); + + SetNativeFont(font); + end; + + destructor TGPFont.Destroy; + begin + GdipDeleteFont(nativeFont); + end; + + constructor TGPFont.Create(font: GpFont; status: TStatus); + begin + lastResult := status; + SetNativeFont(font); + end; + + procedure TGPFont.SetNativeFont(Font: GpFont); + begin + nativeFont := Font; + end; + + function TGPFont.SetStatus(status: TStatus): TStatus; + begin + if (status <> Ok) then lastResult := status; + result := status; + end; + +(**************************************************************************\ +* +* Font collections (Installed and Private) +* +\**************************************************************************) + + constructor TGPFontCollection.Create; + begin + nativeFontCollection := nil; + end; + + destructor TGPFontCollection.Destroy; + begin + inherited Destroy; + end; + + function TGPFontCollection.SetStatus(status: TStatus): TStatus; + begin + lastResult := status; + result := lastResult; + end; + +(**************************************************************************\ +* +* GDI+ Graphics Path class +* +\**************************************************************************) + + constructor TGPGraphicsPath.Create(fillMode: TFillMode = FillModeAlternate); + begin + nativePath := nil; + lastResult := GdipCreatePath(fillMode, nativePath); + end; + + destructor TGPGraphicsPath.Destroy; + begin + GdipDeletePath(nativePath); + end; + + function TGPGraphicsPath.CloseFigure: TStatus; + begin + result := SetStatus(GdipClosePathFigure(nativePath)); + end; + + function TGPGraphicsPath.AddLine(const pt1, pt2: TGPPointF): TStatus; + begin + result := AddLine(pt1.X, pt1.Y, pt2.X, pt2.Y); + end; + + function TGPGraphicsPath.AddLine(x1, y1, x2, y2: Single): TStatus; + begin + result := SetStatus(GdipAddPathLine(nativePath, x1, y1, + x2, y2)); + end; + + function TGPGraphicsPath.AddArc(rect: TGPRectF; startAngle, sweepAngle: Single): TStatus; + begin + result := AddArc(rect.X, rect.Y, rect.Width, rect.Height, + startAngle, sweepAngle); + end; + + function TGPGraphicsPath.AddArc(x, y, width, height, startAngle, sweepAngle: Single): TStatus; + begin + result := SetStatus(GdipAddPathArc(nativePath, x, y, width, height, startAngle, sweepAngle)); + end; + + function TGPGraphicsPath.AddEllipse(rect: TGPRectF): TStatus; + begin + result := AddEllipse(rect.X, rect.Y, rect.Width, rect.Height); + end; + + function TGPGraphicsPath.AddEllipse(x, y, width, height: Single): TStatus; + begin + result := SetStatus(GdipAddPathEllipse(nativePath, + x, + y, + width, + height)); + end; + + { + constructor TGPGraphicsPath.Create(path: TGPGraphicsPath); + var clonepath: GpPath; + begin + clonepath := nil; + SetStatus(GdipClonePath(path.nativePath, clonepath)); + SetNativePath(clonepath); + end; + } + constructor TGPGraphicsPath.Create(nativePath: GpPath); + begin + lastResult := Ok; + SetNativePath(nativePath); + end; + + procedure TGPGraphicsPath.SetNativePath(nativePath: GpPath); + begin + self.nativePath := nativePath; + end; + + function TGPGraphicsPath.SetStatus(status: TStatus): TStatus; + begin + if (status <> Ok) then LastResult := status; + result := status; + end; + +//-------------------------------------------------------------------------- +// Path Gradient Brush +//-------------------------------------------------------------------------- + { + constructor TGPPathGradientBrush.Create(points: PGPPointF; count: Integer; wrapMode: TWrapMode = WrapModeClamp); + var brush: GpPathGradient; + begin + brush := nil; + lastResult := GdipCreatePathGradient(points, count, wrapMode, brush); + SetNativeBrush(brush); + end; + } + constructor TGPPathGradientBrush.Create(path: TGPGraphicsPath); + var brush: GpPathGradient; + begin + brush := nil; + lastResult := GdipCreatePathGradientFromPath(path.nativePath, brush); + SetNativeBrush(brush); + end; + + function TGPPathGradientBrush.GetCenterColor(out Color: TGPColor): TStatus; + begin + SetStatus(GdipGetPathGradientCenterColor(GpPathGradient(nativeBrush), Color)); + result := lastResult; + end; + + function TGPPathGradientBrush.SetCenterColor(color: TGPColor): TStatus; + begin + SetStatus(GdipSetPathGradientCenterColor(GpPathGradient(nativeBrush),color)); + result := lastResult; + end; + + function TGPPathGradientBrush.GetPointCount: Integer; + begin + SetStatus(GdipGetPathGradientPointCount(GpPathGradient(nativeBrush), result)); + end; + + function TGPPathGradientBrush.GetSurroundColors(colors: PARGB; var count: Integer): TStatus; + var + count1: Integer; + begin + if not assigned(colors) then + begin + result := SetStatus(InvalidParameter); + exit; + end; + + SetStatus(GdipGetPathGradientSurroundColorCount(GpPathGradient(nativeBrush), count1)); + + if(lastResult <> Ok) then + begin + result := lastResult; + exit; + end; + + if((count < count1) or (count1 <= 0)) then + begin + result := SetStatus(InsufficientBuffer); + exit; + end; + + SetStatus(GdipGetPathGradientSurroundColorsWithCount(GpPathGradient(nativeBrush), colors, count1)); + if(lastResult = Ok) then + count := count1; + + result := lastResult; + end; + + function TGPPathGradientBrush.SetSurroundColors(colors: PARGB; var count: Integer): TStatus; + var + count1: Integer; + type + TDynArrDWORD = array of DWORD; + begin + if (colors = nil) then + begin + result := SetStatus(InvalidParameter); + exit; + end; + + count1 := GetPointCount; + + if((count > count1) or (count1 <= 0)) then + begin + result := SetStatus(InvalidParameter); + exit; + end; + + count1 := count; + + SetStatus(GdipSetPathGradientSurroundColorsWithCount( + GpPathGradient(nativeBrush), colors, count1)); + + if(lastResult = Ok) then count := count1; + result := lastResult; + end; + + function TGPPathGradientBrush.GetCenterPoint(out point: TGPPointF): TStatus; + begin + result := SetStatus(GdipGetPathGradientCenterPoint(GpPathGradient(nativeBrush), @point)); + end; + + function TGPPathGradientBrush.GetCenterPoint(out point: TGPPoint): TStatus; + begin + result := SetStatus(GdipGetPathGradientCenterPointI(GpPathGradient(nativeBrush), @point)); + end; + + function TGPPathGradientBrush.SetCenterPoint(point: TGPPointF): TStatus; + begin + result := SetStatus(GdipSetPathGradientCenterPoint(GpPathGradient(nativeBrush), @point)); + end; + + function TGPPathGradientBrush.SetCenterPoint(point: TGPPoint): TStatus; + begin + result := SetStatus(GdipSetPathGradientCenterPointI(GpPathGradient(nativeBrush), @point)); + end; + +function TGPGraphics.DrawRectangle(pen: TGPPen; const rect: TGPRectF): TStatus; +begin + Result := DrawRectangle(pen, rect.X, rect.Y, rect.Width, rect.Height); +end; + +function TGPGraphics.DrawRectangle(pen: TGPPen; x, y, width, height: Single): TStatus; +begin + Result := SetStatus(GdipDrawRectangle(nativeGraphics, pen.nativePen, x, y, width, height)); +end; + +function TGPGraphics.DrawImage(image: TGPImage; x, y: Integer): TStatus; +var + nImage: GpImage; +begin + if Assigned(Image) then + nImage := Image.nativeImage + else + nImage := nil; + + Result := SetStatus(GdipDrawImageI(nativeGraphics, nimage, x, y)); +end; + +function TGPGraphics.DrawImageRect(image: TGPImage; x, y, w, h: Integer): TStatus; +var + nImage: GpImage; +begin + if Assigned(Image) then + nImage := Image.nativeImage + else + nImage := nil; + + Result := SetStatus(GdipDrawImageRect(nativeGraphics, nimage, x, y, w, h)); +end; + + +constructor TGPImage.Create(filename: WideString; + useEmbeddedColorManagement: BOOL = FALSE); +begin + nativeImage := nil; + if(useEmbeddedColorManagement) then + begin + lastResult := GdipLoadImageFromFileICM(PWideChar(filename), nativeImage); + end + else + begin + lastResult := GdipLoadImageFromFile(PWideChar(filename), nativeImage); + end; +end; + +constructor TGPImage.Create(stream: IStream; + useEmbeddedColorManagement: BOOL = FALSE); +begin + nativeImage := nil; + if (useEmbeddedColorManagement) then + lastResult := GdipLoadImageFromStreamICM(stream, nativeImage) + else + lastResult := GdipLoadImageFromStream(stream, nativeImage); +end; + +destructor TGPImage.Destroy; +begin + GdipDisposeImage(nativeImage); +end; + +function TGPImage.GetFormat: TGPImageFormat; +var + format: TGUID; +begin + GdipGetImageRawFormat(nativeImage, @format); + + Result := ifUndefined; + + if IsEqualGUID(format, ImageFormatMemoryBMP) then + Result := ifMemoryBMP; + + if IsEqualGUID(format, ImageFormatBMP) then + Result := ifBMP; + + if IsEqualGUID(format, ImageFormatEMF) then + Result := ifEMF; + + if IsEqualGUID(format, ImageFormatWMF) then + Result := ifWMF; + + if IsEqualGUID(format, ImageFormatJPEG) then + Result := ifJPEG; + + if IsEqualGUID(format, ImageFormatGIF) then + Result := ifGIF; + + if IsEqualGUID(format, ImageFormatPNG) then + Result := ifPNG; + + if IsEqualGUID(format, ImageFormatTIFF) then + Result := ifTIFF; + + if IsEqualGUID(format, ImageFormatEXIF) then + Result := ifEXIF; + + if IsEqualGUID(format, ImageFormatIcon) then + Result := ifIcon; +end; + +function TGPImage.GetHeight: UINT; +var + height: UINT; + +begin + height := 0; + SetStatus(GdipGetImageHeight(nativeImage, height)); + result := height; +end; + +function TGPImage.GetWidth: UINT; +var + width: UINT; +begin + width := 0; + SetStatus(GdipGetImageWidth(nativeImage, width)); + result := width; +end; + +constructor TGPImage.Create(nativeImage: GpImage; status: TStatus); +begin + SetNativeImage(nativeImage); + lastResult := status; +end; + +procedure TGPImage.SetNativeImage(nativeImage: GpImage); +begin + self.nativeImage := nativeImage; +end; + +function TGPImage.SetStatus(status: TStatus): TStatus; +begin + if (status <> Ok) then lastResult := status; + result := status; +end; + + +function TGPGraphicsPath.AddLines(points: PGPPoint; count: Integer): TStatus; +begin + result := SetStatus(GdipAddPathLine2I(nativePath, points, count)); +end; + +function TGPGraphicsPath.AddPie(rect: TGPRectF; startAngle, + sweepAngle: Single): TStatus; +begin + result := AddPie(rect.X, rect.Y, rect.Width, rect.Height, startAngle, sweepAngle); +end; + +function TGPGraphicsPath.AddPie(x, y, width, height, startAngle, + sweepAngle: Single): TStatus; +begin + result := SetStatus(GdipAddPathPie(nativePath, x, y, width, height, startAngle, sweepAngle)); +end; + +function TGPGraphicsPath.AddPolygon(points: PGPPointF; + count: Integer): TStatus; +begin + result := SetStatus(GdipAddPathPolygon(nativePath, points, count)); +end; + +function TGPGraphicsPath.AddPolygon(points: PGPPoint; + count: Integer): TStatus; +begin + result := SetStatus(GdipAddPathPolygonI(nativePath, points, count)); +end; + +function TGPGraphicsPath.AddCurve(points: PGPPointF; + count: Integer): TStatus; +begin + result := SetStatus(GdipAddPathCurve(nativePath, points, count)); +end; + +function TGPGraphicsPath.AddCurve(points: PGPPoint; + count: Integer): TStatus; +begin + result := SetStatus(GdipAddPathCurveI(nativePath, points, count)); +end; + +function TGPGraphicsPath.AddCurve(points: PGPPoint; count: Integer; tension: Single): TStatus; +begin + result := SetStatus(GdipAddPathCurve2I(nativePath, points, count, tension)); +end; + +function TGPGraphicsPath.AddBezier(pt1, pt2, pt3, pt4: TGPPoint): TStatus; +begin + result := AddBezier(pt1.X, pt1.Y, pt2.X, pt2.Y, pt3.X, pt3.Y, pt4.X, pt4.Y); +end; + +function TGPGraphicsPath.AddBezier(pt1, pt2, pt3, pt4: TGPPointF): TStatus; +begin + result := AddBezier(pt1.X, pt1.Y, pt2.X, pt2.Y, pt3.X, pt3.Y, pt4.X, pt4.Y); +end; + +function TGPGraphicsPath.AddBezier(x1, y1, x2, y2, x3, y3, x4, + y4: Single): TStatus; +begin + result := SetStatus(GdipAddPathBezier(nativePath, x1, y1, x2, y2, x3, y3, x4, y4)); +end; + +//------------------------------------------------------------------------------ + +function TGPGraphics.FillPath(brush: TGPBrush; + path: TGPGraphicsPath): TStatus; +begin + result := SetStatus(GdipFillPath(nativeGraphics, brush.nativeBrush, path.nativePath)); +end; + +function TGPGraphics.ExcludeClip(const rect: TGPRectF): TStatus; +begin + result := SetStatus(GdipSetClipRect(nativeGraphics, rect.X, rect.Y, rect.Width, rect.Height, CombineModeExclude)); +end; + +function TGPGraphics.ExcludeClip(region: TGPRegion): TStatus; +begin + result := SetStatus(GdipSetClipRegion(nativeGraphics, region.nativeRegion, CombineModeExclude)); +end; + +function TGPGraphics.SetClip(region: TGPRegion; + combineMode: TCombineMode): TStatus; +begin + result := SetStatus(GdipSetClipRegion(nativeGraphics, region.nativeRegion, combineMode)); +end; + +function TGPGraphics.ResetClip: TStatus; +begin + result := SetStatus(GdipResetClip(nativeGraphics)); +end; + +function MakeColor(a, r, g, b: Byte): ARGB; overload; +begin + result := ((DWORD(b) shl BlueShift) or + (DWORD(g) shl GreenShift) or + (DWORD(r) shl RedShift) or + (DWORD(a) shl AlphaShift)); +end; + +function MakeColor(r, g, b: Byte): ARGB; overload; +begin + result := MakeColor(255, r, g, b); +end; + +function GetAlpha(color: ARGB): BYTE; +begin + result := BYTE(color shr AlphaShift); +end; + +function GetRed(color: ARGB): BYTE; +begin + result := BYTE(color shr RedShift); +end; + +function GetGreen(color: ARGB): BYTE; +begin + result := BYTE(color shr GreenShift); +end; + +function GetBlue(color: ARGB): BYTE; +begin + result := BYTE(color shr BlueShift); +end; + +function TGPGraphics.GetCompositingQuality: TCompositingQuality; +begin + SetStatus(GdipGetCompositingQuality(nativeGraphics, result)); +end; + +function TGPGraphics.SetCompositingQuality( + compositingQuality: TCompositingQuality): TStatus; +begin + result := SetStatus(GdipSetCompositingQuality( nativeGraphics, compositingQuality)); +end; + +function TGPImage.RotateFlip(rotateFlipType: TRotateFlipType): TStatus; +begin + Result := SetStatus(GdipImageRotateFlip(nativeImage, rotateFlipType)); +end; + + +{ TGPBitmap } + +constructor TGPBitmap.Create(stream: IStream; useEmbeddedColorManagement: BOOL); +var + bitmap: GpBitmap; +begin + bitmap := nil; + if(useEmbeddedColorManagement) then + lastResult := GdipCreateBitmapFromStreamICM(stream, bitmap) + else + lastResult := GdipCreateBitmapFromStream(stream, bitmap); + SetNativeImage(bitmap); +end; + +constructor TGPBitmap.Create(nativeBitmap: GpBitmap); +begin + lastResult := Ok; + SetNativeImage(nativeBitmap); +end; + +constructor TGPBitmap.Create(width, height: Integer; format: TPixelFormat); +var + bitmap: GpBitmap; +begin + bitmap := nil; + lastResult := GdipCreateBitmapFromScan0(width, height, 0, format, nil, bitmap); + SetNativeImage(bitmap); +end; + +function TGPBitmap.FromStream(stream: IStream; + useEmbeddedColorManagement: BOOL): TGPBitmap; +begin + Result := TGPBitmap.Create(stream, useEmbeddedColorManagement); +end; + +function TGPBitmap.GetPixel(x, y: Integer; out color: TGPColor): TStatus; +begin + Result := SetStatus(GdipBitmapGetPixel(GpBitmap(nativeImage), x, y, color)); +end; + +function TGPBitmap.SetPixel(x, y: Integer; color: TGPColor): TStatus; +begin + Result := SetStatus(GdipBitmapSetPixel(GpBitmap(nativeImage), x, y, color)); +end; + + + +initialization +begin + // Initialize StartupInput structure + StartupInput.DebugEventCallback := nil; + + //StartupInput.SuppressBackgroundThread := False; + StartupInput.SuppressBackgroundThread := True; + StartupInput.SuppressExternalCodecs := False; + StartupInput.GdiplusVersion := 1; + + StartupOutput.NotificationHook := nil; + StartupOutput.NotificationUnhook := nil; + + // Initialize GDI+ + GdiplusStartup(gdiplusToken, @StartupInput, @StartupOutput); +end; + +finalization +begin + // Close GDI + + if not IsLibrary then + GdiplusShutdown(gdiplusToken); +end; + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/advglowbutton.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advglowbutton.pas new file mode 100644 index 0000000..85564a0 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advglowbutton.pas @@ -0,0 +1,5298 @@ +{***************************************************************************} +{ TAdvGlowButton component } +{ for Delphi & C++Builder } +{ } +{ written by TMS Software } +{ copyright © 2006 - 2008 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit AdvGlowButton; + +{$R ADVGLOWBUTTONDB.RES} + +{$I TMSDEFS.INC} + +{$T-} + +interface + +uses + Classes, Windows, Forms, Dialogs, Controls, Graphics, Messages, ExtCtrls, + SysUtils, Math, Menus, ImgList, AdvGDIP, GDIPicture, ActnList, + AdvHintInfo, AdvStyleIF, ActiveX + {$IFNDEF TMS_STD} + , DB + {$ENDIF} + ; + +const + DropDownSectWidth = 13; + + MAJ_VER = 1; // Major version nr. + MIN_VER = 8; // Minor version nr. + REL_VER = 1; // Release nr. + BLD_VER = 5; // Build nr. + + // version history + // 1.0.5.1 : Fixed issue with width & height initialization + // 1.0.5.2 : Improved fade painting + // 1.1.0.0 : New separate dropdown button hot & down effect + // : Silver, Blue, Black styles added + // 1.2.0.0 : New DropDownSplit property added + // 1.2.0.1 : Fixed issue with ModalResult <> mrNone + // 1.2.0.2 : Fixed issue with Action handling Checked state + // 1.2.0.3 : Fixed issue with disabled painting + // 1.2.0.4 : Fixed issue with key handling + // 1.3.0.0 : Added new property FocusType + // : Added new ShortCutHint, ShortCutHintPos & methods ShowShortCutHint, HideShortCutHint + // 1.3.0.1 : Fixed issue with font and aaNone + // 1.3.0.2 : Fixed issue with hot & down border painting + // 1.3.1.0 : New : exposed OnMouseEnter, OnMouseLeave + // : Fixed issue with Down property for bsCheck style + // 1.3.1.1 : Fixed issue with Down property for buttons with GroupIndex > 0 + // 1.3.1.2 : Improved transitioning from transparent to hot + // 1.3.1.3 : Fixed issue with actionlinks & bsCheck type + // 1.3.2.0 : New styler interface added + // 1.3.3.0 : New public property DroppedDown added + // 1.3.4.0 : New TAdvCustomGlowButton.ParentFont added + // : TButtonLayout blGlyphLeftAdjusted and blGlyphRightAdjusted added + // 1.3.5.0 : New borderless display possible by setting BorderStyle = bsNone + // 1.4.0.0 : Improved : seamlessly works with TrueType & non TrueType fonts + // : New : Spacing property added + // : New : WordWrap property added + // : New : AutoSize property added + // : New : MarginVert property added + // : New : MarginHorz property added + // : New : Rounded property added + // : New : DropDownDirection property added + // : New : HotImages, HotPicture property added + // 1.4.5.0 : New : PopupMenu property added + // : New : OnDrawButton event added + // : New : TButtonLayout blGlyphTopAdjusted and blGlyphBottomAdjusted added + // 1.4.6.0 : New : support for Office 2007 silver style added + // 1.4.6.1 : Fixed : issue with Win98 resource leak + // 1.5.0.0 : New : support for Unicode text via public property WideCaption + // : Improved : text drawing in aaNone AntiAlias mode + // 1.5.0.1 : Fix for use with fonts that are not installed + // 1.6.0.0 : New : support for Trimming added + // 1.6.0.1 : Fixed : issue with Action images + // 1.7.0.0 : New : Repeat functionality added with repeat initial delay & frequency setting + // : Improved wordwrap drawing with no text aliasing + // : New : support for using \n newline specifier in property inspector + // 1.7.0.1 : Fixed : drawing issue with Delphi 2007 + // 1.7.1.0 : New : F4 key to open attached dropdown menu + // 1.7.1.1 : Fixed : issue with DropDownSplit and OnClick event handler + // 1.7.2.0 : New : events OnEnter, OnExit added + // 1.7.2.1 : Improved : painting on MDI child windows + // 1.7.2.2 : Fixed : drawing issue with Delphi 2007 + // 1.8.0.0 : New : Notes & NotesFont + // : New : C++Builder 2007 support + // : Improved : drawing down state for Transparent button + // : Improved : drawing speed + // 1.8.0.1 : Fixed : runtime WideCaption assigning causes repaint + // 1.8.1.0 : Fixed : issue with inherited forms + // 1.8.1.1 : Fixed : issue with dbl click event + // : Fixed : issue with actions & groupindex + // : Fixed : border painting issue on checked buttons in bpMiddle, bpRight position + // 1.8.1.2 : Fixed : issue with ShowCaption & WideCaption + // 1.8.1.3 : Fixed : issue with using font not installed on the system + // 1.8.1.4 : Fixed : issue with WideCaption & aaNone AntiAlias type + // 1.8.1.5 : Fixed : issue with DblClick & OnClick event + + +type + TAdvCustomGlowButton = class; + TAdvGlowButton = class; + + TGlowState = (gsHover, gsPush, gsNone); + TAdvButtonStyle = (bsButton, bsCheck); + TAdvButtonState = (absUp, absDisabled, absDown, absDropDown, absExclusive); + TButtonLayout = (blGlyphLeft, blGlyphTop, blGlyphRight, blGlyphBottom, + blGlyphLeftAdjusted, blGlyphRightAdjusted, + blGlyphTopAdjusted, blGlyphBottomAdjusted); + + TDropDownPosition = (dpRight, dpBottom); + TDropDownDirection = (ddDown, ddRight); + TGDIPGradient = (ggRadial, ggVertical, ggDiagonalForward, ggDiagonalBackward); + + TFocusType = (ftBorder, ftHot, ftHotBorder, ftNone); + + TShortCutHintPos = (shpLeft, shpTop, shpRight, shpBottom, shpCenter); + + TButtonPosition = (bpStandalone, bpLeft, bpMiddle, bpRight); + + TGlowButtonState = (gsNormal, gsHot, gsDown); + + TButtonSizeState = (bsGlyph, bsLabel, bsLarge); + + TGlowButtonDrawEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect; State: TGlowButtonState) of object; + TSetButtonSizeEvent = procedure(Sender: TObject; var W, H: Integer) of object; + + TWinCtrl = class(TWinControl) + public + procedure PaintCtrls(DC: HDC; First: TControl); + end; + +{$IFDEF DELPHI6_LVL} + TAdvGlowButtonActionLink = class(TControlActionLink) + protected + FImageIndex: Integer; + FClient: TAdvCustomGlowButton; //TAdvGlowButton; + procedure AssignClient(AClient: TObject); override; + function IsCheckedLinked: Boolean; override; + function IsGroupIndexLinked: Boolean; override; + procedure SetGroupIndex(Value: Integer); override; + procedure SetChecked(Value: Boolean); override; + function IsImageIndexLinked: Boolean; override; + procedure SetImageIndex(Value: Integer); override; + end; +{$ENDIF} + + TShortCutHintWindow = class(THintWindow) + private + FColor: TColor; + FColorTo: TColor; + procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND; + protected + procedure Resize; override; + procedure Paint; override; + procedure CreateParams(var Params:TCreateParams);override; + published + property Color: TColor read FColor write FColor; + property ColorTo: TColor read FColorTo write FColorTo; + end; + + TGlowButtonAppearance = class(TPersistent) + private + FOnChange: TNotifyEvent; + FBorderColor: TColor; + FBorderColorHot: TColor; + FBorderColorDown: TColor; + FColor: TColor; + FColorTo: TColor; + FColorDown: TColor; + FColorDownTo: TColor; + FColorHot: TColor; + FColorHotTo: TColor; + FColorCheckedTo: TColor; + FBorderColorDisabled: TColor; + FBorderColorChecked: TColor; + FColorDisabled: TColor; + FColorDisabledTo: TColor; + FColorChecked: TColor; + FColorMirror: TColor; + FColorMirrorTo: TColor; + FColorMirrorHot: TColor; + FColorMirrorHotTo: TColor; + FColorMirrorDown: TColor; + FColorMirrorDownTo: TColor; + FGradientDown: TGDIPGradient; + FGradientMirror: TGDIPGradient; + FGradientMirrorHot: TGDIPGradient; + FGradient: TGDIPGradient; + FGradientMirrorDown: TGDIPGradient; + FGradientHot: TGDIPGradient; + FColorMirrorDisabledTo: TColor; + FColorMirrorDisabled: TColor; + FColorMirrorCheckedTo: TColor; + FColorMirrorChecked: TColor; + FGradientChecked: TGDIPGradient; + FGradientDisabled: TGDIPGradient; + FGradientMirrorChecked: TGDIPGradient; + FGradientMirrorDisabled: TGDIPGradient; + FSystemFont: boolean; + procedure SetSystemFont(const Value: boolean); + protected + procedure Changed; + public + constructor Create; + procedure Assign(Source: TPersistent); override; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + published + property BorderColor: TColor read FBorderColor write FBorderColor default clSilver; + property BorderColorHot: TColor read FBorderColorHot write FBorderColorHot default clBlue; + property BorderColorDown: TColor read FBorderColorDown write FBorderColorDown default clNavy; + property BorderColorChecked: TColor read FBorderColorChecked write FBorderColorChecked default clBlue; + property BorderColorDisabled: TColor read FBorderColorDisabled write FBorderColorDisabled default clGray; + property Color: TColor read FColor write FColor default clWhite; + property ColorTo: TColor read FColorTo write FColorTo default clWhite; + property ColorChecked: TColor read FColorChecked write FColorChecked; + property ColorCheckedTo: TColor read FColorCheckedTo write FColorCheckedTo; + property ColorDisabled: TColor read FColorDisabled write FColorDisabled; + property ColorDisabledTo: TColor read FColorDisabledTo write FColorDisabledTo; + property ColorDown: TColor read FColorDown write FColorDown; + property ColorDownTo: TColor read FColorDownTo write FColorDownTo; + property ColorHot: TColor read FColorHot write FColorHot; + property ColorHotTo: TColor read FColorHotTo write FColorHotTo; + property ColorMirror: TColor read FColorMirror write FColorMirror default clSilver; + property ColorMirrorTo: TColor read FColorMirrorTo write FColorMirrorTo default clWhite; + property ColorMirrorHot: TColor read FColorMirrorHot write FColorMirrorHot; + property ColorMirrorHotTo: TColor read FColorMirrorHotTo write FColorMirrorHotTo; + property ColorMirrorDown: TColor read FColorMirrorDown write FColorMirrorDown; + property ColorMirrorDownTo: TColor read FColorMirrorDownTo write FColorMirrorDownTo; + property ColorMirrorChecked: TColor read FColorMirrorChecked write FColorMirrorChecked; + property ColorMirrorCheckedTo: TColor read FColorMirrorCheckedTo write FColorMirrorCheckedTo; + property ColorMirrorDisabled: TColor read FColorMirrorDisabled write FColorMirrorDisabled; + property ColorMirrorDisabledTo: TColor read FColorMirrorDisabledTo write FColorMirrorDisabledTo; + property Gradient: TGDIPGradient read FGradient write FGradient default ggVertical; + property GradientMirror: TGDIPGradient read FGradientMirror write FGradientMirror default ggVertical; + property GradientHot: TGDIPGradient read FGradientHot write FGradientHot default ggRadial; + property GradientMirrorHot: TGDIPGradient read FGradientMirrorHot write FGradientMirrorHot default ggRadial; + property GradientDown: TGDIPGradient read FGradientDown write FGradientDown default ggRadial; + property GradientMirrorDown: TGDIPGradient read FGradientMirrorDown write FGradientMirrorDown default ggRadial; + property GradientChecked: TGDIPGradient read FGradientChecked write FGradientChecked default ggRadial; + property GradientMirrorChecked: TGDIPGradient read FGradientMirrorChecked write FGradientMirrorChecked default ggVertical; + property GradientDisabled: TGDIPGradient read FGradientDisabled write FGradientDisabled default ggRadial; + property GradientMirrorDisabled: TGDIPGradient read FGradientMirrorDisabled write FGradientMirrorDisabled default ggRadial; + property SystemFont: boolean read FSystemFont write SetSystemFont default true; + end; + + /// Button with glow hover & down effect + TAdvCustomGlowButton = class(TCustomControl, ITMSStyle) + private + FActive: Boolean; + FDown: Boolean; + FLeftDown: Boolean; + FMouseDown: Boolean; + FTimer: TTimer; + FStepHover: Integer; + FStepPush: Integer; + FTimeInc: Integer; + FGlowState: TGlowState; + FImages: TImageList; + FImageIndex: TImageIndex; + FState: TAdvButtonState; + FMouseInControl: Boolean; + FMouseEnter: Boolean; + FDownChecked: Boolean; + FInitialDown: Boolean; + FDragging: Boolean; + FStyle: TAdvButtonStyle; + FGroupIndex: Integer; + FAllowAllUp: Boolean; + FTransparent: Boolean; + FLayout: TButtonLayout; + FDropDownButton: Boolean; + FDropDownSplit: Boolean; + FDropDownDirection: TDropDownDirection; + FDropDownMenu: TPopupMenu; + FOnDropDown: TNotifyEvent; + FDropDownPosition: TDropDownPosition; + FAppearance: TGlowButtonAppearance; + FDisabledImages: TImageList; + FInternalImages: TImageList; + FHotImages: TImageList; + FIPicture: TGDIPPicture; + FIDisabledPicture: TGDIPPicture; + FIHotPicture: TGDIPPicture; + FShowCaption: Boolean; + FAntiAlias: TAntiAlias; + FModalResult: TModalResult; + FDefault: boolean; + FCancel: Boolean; + FInButton: Boolean; + FBorderStyle: TBorderStyle; + FButtonPosition: TButtonPosition; + FOfficeHint: TAdvHintInfo; + FCheckLinked: Boolean; + FGroupIndexLinked: Boolean; + FFocusType: TFocusType; + FShortCutHint: TShortCutHintWindow; + FShortCutHintPos: TShortCutHintPos; + FShortCutHintText: string; + FShowDisabled: Boolean; + FOnInternalKeyDown: TKeyEvent; + FOnMouseLeave: TNotifyEvent; + FOnMouseEnter: TNotifyEvent; + FDroppedDown: Boolean; + FOverlappedText: Boolean; + FSpacing: Integer; + FAutoSize: Boolean; + FWordWrap: Boolean; + FDoAutoSize: Boolean; + FFirstPaint: Boolean; + FMarginVert: integer; + FMarginHorz: integer; + FRounded: Boolean; + FOnDrawButton: TGlowButtonDrawEvent; + FWideCaption: widestring; + FTrimming: TStringTrimming; + FRepeatTimer: TTimer; + FInitRepeatPause: Integer; + FRepeatPause: Integer; + FRepeatClick: Boolean; + FOnInternalClick: TNotifyEvent; + FButtonSizeState: TButtonSizeState; + FMaxButtonSizeState: TButtonSizeState; + FOnSetButtonSize: TSetButtonSizeEvent; + FOldLayout: TButtonLayout; + FOldDropDownPosition: TDropDownPosition; + FMinButtonSizeState: TButtonSizeState; + FParentForm: TCustomForm; + FIsVista: boolean; + FNotes: TStringList; + FNotesFont: TFont; + procedure SetOfficeHint(const Value: TAdvHintInfo); + procedure SetButtonPosition(const Value: TButtonPosition); + procedure SetBorderStyle(const Value: TBorderStyle); + function GetVersion: string; + procedure SetVersion(const Value: string); + procedure SetDefault(const Value: boolean); + procedure SetAntiAlias(const Value: TAntiAlias); + procedure SetShowCaption(const Value: Boolean); + procedure SetDisabledPicture(const Value: TGDIPPicture); + procedure SetHotPicture(const Value: TGDIPPicture); + procedure SetPicture(const Value: TGDIPPicture); + procedure SetTransparent(const Value: Boolean); + procedure UpdateExclusive; + procedure UpdateTracking; + procedure SetImageIndex(const Value: TImageIndex); + procedure SetImages(const Value: TImageList); + procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED; + procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE; + procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER; + procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; + procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND; + procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; +{$IFNDEF TMSDOTNET} + procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED; +{$ENDIF} + procedure WMLButtonUp(var Msg:TWMLButtonDown); message WM_LBUTTONUP; + procedure WMLDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure TimerProc(Sender: TObject); + procedure OnAppearanceChanged(Sender: TObject); + procedure SetDown(Value: Boolean); + procedure SetStyle(const Value: TAdvButtonStyle); + procedure SetGroupIndex(const Value: Integer); + procedure SetAllowAllUp(const Value: Boolean); + procedure SetLayout(const Value: TButtonLayout); + procedure SetDropDownButton(const Value: Boolean); + procedure PopupBtnDown; + procedure SetDropDownPosition(const Value: TDropDownPosition); + procedure SetDropDownDirection(const Value: TDropDownDirection); + procedure SetAppearance(const Value: TGlowButtonAppearance); + procedure SetDisabledImages(const Value: TImageList); + procedure PictureChanged(Sender: TObject); + procedure DoDropDown; + procedure SetSpacing(const Value: integer); + procedure SetAutoSizeEx(const Value: boolean); + procedure SetShowDisabled(const Value: boolean); + procedure SetWordWrap(const Value: boolean); + procedure SetMarginVert(const Value: integer); + procedure SetMarginHorz(const Value: integer); + procedure SetRounded(const Value: boolean); + procedure SetTrimming(const Value: TStringTrimming); + procedure PerformResize; + function IsFontStored: Boolean; + procedure SetButtonSizeState(const Value: TButtonSizeState); + procedure SetMaxButtonSizeState(const Value: TButtonSizeState); + procedure SetMinButtonSizeState(const Value: TButtonSizeState); + procedure SetNotes(const Value: TStrings); + function GetNotes: TStrings; + procedure SetNotesFont(const Value: TFont); + procedure SetWideCaption(const Value: widestring); +// procedure SetCaption(const Value: string); +// function GetCaption: string; + protected + FHot: Boolean; + FDefaultPicDrawing: Boolean; + FDefaultCaptionDrawing: Boolean; + FCustomizerCreated: Boolean; + FCommandID: Integer; + procedure TimerExpired(Sender: TObject); virtual; + procedure DrawGlyphCaption; virtual; + procedure GetToolImage(bmp: TBitmap); virtual; + procedure SetDroppedDown(Value: Boolean); + procedure CreateParams(var Params:TCreateParams); override; + procedure Paint; override; + procedure Loaded; override; + procedure DoEnter; override; + procedure DoExit; override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyUp(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char); override; +{$IFDEF DELPHI6_LVL} + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; +{$ENDIF} + procedure Notification(AComponent: TComponent; AOperation: TOperation); override; + property GlowState: TGlowState read FGlowState write FGlowState; +{$IFDEF TMSDOTNET} + procedure ButtonPressed(Group: Integer; Button: TAdvGlowButton); +{$ENDIF} + property Down: Boolean read FDownChecked write SetDown default False; + property Style: TAdvButtonStyle read FStyle write SetStyle default bsButton; + property State: TAdvButtonState read FState write FState; + property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0; + property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False; + property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft; + property DroppedDown: Boolean read FDroppedDown; + property DropDownButton: Boolean read FDropDownButton write SetDropDownButton default False; + property DropDownDirection: TDropDownDirection read FDropDownDirection write SetDropDownDirection default ddDown; + property DropDownPosition: TDropDownPosition read FDropDownPosition write SetDropDownPosition default dpRight; + property DropDownSplit: Boolean read FDropDownSplit write FDropDownSplit default true; + property DropDownMenu: TPopupMenu read FDropDownMenu write FDropDownMenu; + property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown; + function GetVersionNr: Integer; virtual; + function IsMenuButton: Boolean; virtual; + function CanDrawBorder: Boolean; virtual; + function CanDrawFocused: Boolean; virtual; + procedure InternalClick; + property CheckLinked: Boolean read FCheckLinked write FCheckLinked; + property GroupIndexLinked: Boolean read FGroupIndexLinked write FGroupIndexLinked; + property OnInternalKeyDown: TKeyEvent read FOnInternalKeyDown write FOnInternalKeyDown; // Used by AdvToolBar + property OnInternalClick: TNotifyEvent read FOnInternalClick write FOnInternalClick; // Used by AdvToolBar + property OverlappedText: boolean read FOverlappedText write FOverlappedText; + property DoAutoSize: boolean read FDoAutoSize write FDoAutoSize; + property ButtonSizeState: TButtonSizeState read FButtonSizeState write SetButtonSizeState; // Used by AdvToolBar + property MaxButtonSizeState: TButtonSizeState read FMaxButtonSizeState write SetMaxButtonSizeState default bsLarge; + property MinButtonSizeState: TButtonSizeState read FMinButtonSizeState write SetMinButtonSizeState default bsGlyph; + property OnSetButtonSize: TSetButtonSizeEvent read FOnSetButtonSize write FOnSetButtonSize; // Used by AdvToolBar + function GetButtonSize(BtnSizeState: TButtonSizeState): TSize; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + procedure CreateWnd; override; + procedure Click; override; + property Appearance: TGlowButtonAppearance read FAppearance write SetAppearance; + procedure ShowShortCutHint; + procedure HideShortCutHint; + /// Sets the style of the component, make sure to include AdvStyleIF unit + procedure SetComponentStyle(AStyle: TTMSStyle); + property WideCaption: widestring read FWideCaption write SetWideCaption; + published + property Align; + property Action; + property Anchors; + property AntiAlias: TAntiAlias read FAntiAlias write SetAntiAlias default aaClearType; + property AutoSize: boolean read FAutoSize write SetAutoSizeEx default false; + property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; + property Cancel: Boolean read FCancel write FCancel default False; + //property Caption: string read GetCaption write SetCaption; + property Caption; + property Constraints; + property Default: boolean read FDefault write SetDefault default False; + property Font stored IsFontStored; + property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; + property Images: TImageList read FImages write SetImages; + property DisabledImages: TImageList read FDisabledImages write SetDisabledImages; + property DisabledPicture: TGDIPPicture read FIDisabledPicture write SetDisabledPicture; + property DragMode; + property DragKind; + property FocusType: TFocusType read FFocusType write FFocusType default ftBorder; + property HotImages: TImageList read FHotImages write FHotImages; + property HotPicture: TGDIPPicture read FIHotPicture write SetHotPicture; + property MarginVert: integer read FMarginVert write SetMarginVert default 2; + property MarginHorz: integer read FMarginHorz write SetMarginHorz default 2; + property ModalResult: TModalResult read FModalResult write FModalResult default 0; + property Notes: TStrings read GetNotes write SetNotes; + property NotesFont: TFont read FNotesFont write SetNotesFont; + property OfficeHint: TAdvHintInfo read FOfficeHint write SetOfficeHint; + property ParentFont default true; + property Picture: TGDIPPicture read FIPicture write SetPicture; + property PopupMenu; + property Position: TButtonPosition read FButtonPosition write SetButtonPosition default bpStandalone; + property InitRepeatPause: Integer read FInitRepeatPause write FInitRepeatPause default 400; + property RepeatPause: Integer read FRepeatPause write FRepeatPause default 100; + property RepeatClick: boolean read FRepeatClick write FRepeatClick default false; + property Rounded: Boolean read FRounded write SetRounded default true; + property ShortCutHint: string read FShortCutHintText write FShortCutHintText; + property ShortCutHintPos: TShortCutHintPos read FShortCutHintPos write FShortCutHintPos default shpTop; + property ShowCaption: Boolean read FShowCaption write SetShowCaption default true; + property ShowDisabled: Boolean read FShowDisabled write SetShowDisabled default true; + property Spacing: Integer read FSpacing write SetSpacing default 2; + property Transparent: Boolean read FTransparent write SetTransparent default false; + property Trimming: TStringTrimming read FTrimming write SetTrimming default StringTrimmingNone; + property Version: string read GetVersion write SetVersion stored False; + property WordWrap: boolean read FWordWrap write SetWordWrap default true; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnExit; + property OnEnter; + + property OnStartDock; + property OnStartDrag; + + property OnMouseDown; + property OnMouseUp; + property OnMouseMove; + property OnKeyDown; + property OnKeyUp; + property OnKeyPress; + property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; + property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave; + property OnDrawButton: TGlowButtonDrawEvent read FOnDrawButton write FOnDrawButton; + end; + + TAdvGlowButton = class(TAdvCustomGlowButton) + private + protected + public + property State; + property DroppedDown; + published + property AllowAllUp; + property Appearance; + property Down; + property Enabled; + property GroupIndex; + property Layout; + property Style; + property MaxButtonSizeState; + property MinButtonSizeState; + property DropDownButton; + property DropDownPosition; + property DropDownDirection; + property DropDownSplit; + property DropDownMenu; + property OnDropDown; + end; + + {$IFNDEF TMS_STD} + + //---- DB aware version + TDBGlowButtonType = (dbCustom, dbFirst, dbPrior, dbNext, dbLast, dbInsert, dbAppend, + dbDelete, dbEdit, dbPost, dbCancel, dbRefresh); + + TDBBDisableControl = (drBOF, drEOF, drReadonly, drNotEditing, drEditing, drEmpty, drEvent); + TDBBDisableControls = set of TDBBDisableControl; + + TBeforeActionEvent = procedure (Sender: TObject; var DoAction: Boolean) of object; + TAfterActionEvent = procedure (Sender: TObject; var ShowException: Boolean) of object; + TGetConfirmEvent = procedure (Sender: TObject; var Question: string; var Buttons: TMsgDlgButtons; var HelpCtx: Longint) of object; + TGetEnabledEvent = procedure (Sender: TObject; var Enabled: Boolean) of object; + + TDBGlowButtonDataLink = class(TDataLink) + private + FOnEditingChanged: TNotifyEvent; + FOnDataSetChanged: TNotifyEvent; + FOnActiveChanged: TNotifyEvent; + protected + procedure EditingChanged; override; + procedure DataSetChanged; override; + procedure ActiveChanged; override; + public + constructor Create; + property OnEditingChanged: TNotifyEvent + read FOnEditingChanged write FOnEditingChanged; + property OnDataSetChanged: TNotifyEvent + read FOnDataSetChanged write FOnDataSetChanged; + property OnActiveChanged: TNotifyEvent + read FOnActiveChanged write FOnActiveChanged; + end; + + TDBAdvGlowButton = class(TAdvCustomGlowButton) + private + FDataLink: TDBGlowButtonDataLink; + FAutoDisable: Boolean; + FDisableControls: TDBBDisableControls; + FOnAfterAction: TAfterActionEvent; + FOnBeforeAction: TBeforeActionEvent; + FDBButtonType: TDBGlowButtonType; + FOnGetConfirm: TGetConfirmEvent; + FOnGetEnabled: TGetEnabledEvent; + FOnEnabledChanged: TNotifyEvent; + FConfirmAction: Boolean; + FConfirmActionString: String; + FInProcUpdateEnabled: Boolean; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure OnDataSetEvents(Sender: TObject); + + function GetDataSource: TDataSource; + procedure SetDataSource(const Value: TDataSource); + procedure SetDBButtonType(const Value: TDBGlowButtonType); + procedure SetConfirmActionString(const Value: String); + protected + procedure Notification(AComponent: TComponent; AOperation: TOperation); override; + procedure Loaded; override; + procedure CalcDisableReasons; + procedure DoBeforeAction(var DoAction: Boolean); virtual; + procedure DoGetQuestion(var Question: string; var Buttons: TMsgDlgButtons; var HelpCtx: Longint); virtual; + function DoConfirmAction: Boolean; virtual; + procedure DoAction; virtual; + procedure UpdateEnabled; virtual; + procedure LoadGlyph; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Click; override; + published + property Action; + property Appearance; + property Layout; + property Constraints; + property AutoDisable: Boolean read FAutoDisable write FAutoDisable; + property ConfirmAction: Boolean read FConfirmAction write FConfirmAction; + property ConfirmActionString: String read FConfirmActionString write SetConfirmActionString; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DBButtonType: TDBGlowButtonType read FDBButtonType write SetDBButtonType; + property DisableControl: TDBBDisableControls read FDisableControls write FDisableControls; + property Enabled; + + property OnBeforeAction: TBeforeActionEvent read FOnBeforeAction write FOnBeforeAction; + property OnAfterAction: TAfterActionEvent read FOnAfterAction write FOnAfterAction; + property OnGetConfirm: TGetConfirmEvent read FOnGetConfirm write FOnGetConfirm; + property OnGetEnabled: TGetEnabledEvent read FOnGetEnabled write FOnGetEnabled; + property OnEnabledChanged: TNotifyEvent read FOnEnabledChanged write FOnEnabledChanged; + end; + + {$ENDIF} + +implementation + +{$IFNDEF TMS_STD} +uses + {$IFDEF DELPHI6_LVL} + VDBConsts + {$ELSE} + DBConsts + {$ENDIF} + ; +{$ENDIF} + +type + TButtonDisplay = (bdNone, bdButton, bdDropDown); + +//------------------------------------------------------------------------------ + +procedure DrawGradient(Canvas: TCanvas; FromColor, ToColor: TColor; Steps: Integer; R: TRect; Direction: Boolean); +var + diffr, startr, endr: Integer; + diffg, startg, endg: Integer; + diffb, startb, endb: Integer; + rstepr, rstepg, rstepb, rstepw: Real; + i, stepw: Word; + +begin + if Steps = 0 then + Steps := 1; + + FromColor := ColorToRGB(FromColor); + ToColor := ColorToRGB(ToColor); + + startr := (FromColor and $0000FF); + startg := (FromColor and $00FF00) shr 8; + startb := (FromColor and $FF0000) shr 16; + endr := (ToColor and $0000FF); + endg := (ToColor and $00FF00) shr 8; + endb := (ToColor and $FF0000) shr 16; + + diffr := endr - startr; + diffg := endg - startg; + diffb := endb - startb; + + rstepr := diffr / steps; + rstepg := diffg / steps; + rstepb := diffb / steps; + + if Direction then + rstepw := (R.Right - R.Left) / Steps + else + rstepw := (R.Bottom - R.Top) / Steps; + + with Canvas do + begin + for i := 0 to steps - 1 do + begin + endr := startr + Round(rstepr * i); + endg := startg + Round(rstepg * i); + endb := startb + Round(rstepb * i); + stepw := Round(i * rstepw); + Pen.Color := endr + (endg shl 8) + (endb shl 16); + Brush.Color := Pen.Color; + if Direction then + Rectangle(R.Left + stepw, R.Top, R.Left + stepw + Round(rstepw) + 1, R.Bottom) + else + Rectangle(R.Left, R.Top + stepw, R.Right, R.Top + stepw + Round(rstepw) + 1); + end; + end; +end; + +//------------------------------------------------------------------------------ + +function BrightnessColor(Col: TColor; Brightness: integer): TColor; overload; +var + r1,g1,b1: Integer; +begin + Col := ColorToRGB(Col); + r1 := GetRValue(Col); + g1 := GetGValue(Col); + b1 := GetBValue(Col); + + if r1 = 0 then + r1 := Max(0,Brightness) + else + r1 := Round( Min(100,(100 + Brightness))/100 * r1 ); + + if g1 = 0 then + g1 := Max(0,Brightness) + else + g1 := Round( Min(100,(100 + Brightness))/100 * g1 ); + + if b1 = 0 then + b1 := Max(0,Brightness) + else + b1 := Round( Min(100,(100 + Brightness))/100 * b1 ); + + Result := RGB(r1,g1,b1); +end; + +//------------------------------------------------------------------------------ + +function BrightnessColor(Col: TColor; BR,BG,BB: integer): TColor; overload; +var + r1,g1,b1: Integer; +begin + Col := Longint(ColorToRGB(Col)); + r1 := GetRValue(Col); + g1 := GetGValue(Col); + b1 := GetBValue(Col); + + if r1 = 0 then + r1 := Max(0,BR) + else + r1 := Round( Min(100,(100 + BR))/100 * r1 ); + + if g1 = 0 then + g1 := Max(0,BG) + else + g1 := Round( Min(100,(100 + BG))/100 * g1 ); + + if b1 = 0 then + b1 := Max(0,BB) + else + b1 := Round( Min(100,(100 + BB))/100 * b1 ); + + Result := RGB(r1,g1,b1); +end; + +//------------------------------------------------------------------------------ + +function BlendColor(Col1,Col2:TColor; BlendFactor:Integer): TColor; +var + r1,g1,b1: Integer; + r2,g2,b2: Integer; + +begin + if BlendFactor >= 100 then + begin + Result := Col1; + Exit; + end; + if BlendFactor <= 0 then + begin + Result := Col2; + Exit; + end; + + Col1 := Longint(ColorToRGB(Col1)); + r1 := GetRValue(Col1); + g1 := GetGValue(Col1); + b1 := GetBValue(Col1); + + Col2 := Longint(ColorToRGB(Col2)); + r2 := GetRValue(Col2); + g2 := GetGValue(Col2); + b2 := GetBValue(Col2); + + r1 := Round( BlendFactor/100 * r1 + (1 - BlendFactor/100) * r2); + g1 := Round( BlendFactor/100 * g1 + (1 - BlendFactor/100) * g2); + b1 := Round( BlendFactor/100 * b1 + (1 - BlendFactor/100) * b2); + + Result := RGB(r1,g1,b1); +end; + + +//------------------------------------------------------------------------------ + +procedure DrawOpenRoundRectMiddle(graphics: TGPGraphics; PC: TColor; X,Y,Width,Height,Radius: integer;Hot:boolean); +var + path:TGPGraphicsPath; + gppen:TGPPen; + +begin + path := TGPGraphicsPath.Create; + + gppen := tgppen.Create(ColorToARGB(PC),1); + path.AddLine(X-1, Y + height, X + width, Y + height); + graphics.DrawPath(gppen, path); + path.Free; + + path := TGPGraphicsPath.Create; + path.AddLine(X-1, Y, X + width, Y); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + + path := TGPGraphicsPath.Create; + gppen := tgppen.Create(ColorToARGB(BrightnessColor(PC,-5)),1); + path.AddLine(X + Width, Y, X + width, Y + Height); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + + if hot then + begin + path := TGPGraphicsPath.Create; + gppen := tgppen.Create(ColorToARGB(BrightnessColor(PC,-5)),1); + path.AddLine(X , Y, X , Y + Height); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + end + else + begin + path := TGPGraphicsPath.Create; + // 3D color effect + gppen := tgppen.Create(ColorToARGB(BrightnessColor(clwhite,-10)),1); + path.AddLine(X, Y + 2, X, Y + Height - 2); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + end; +end; + + +//------------------------------------------------------------------------------ + +procedure DrawOpenRoundRectLeft(graphics: TGPGraphics; PC:TColor; X,Y,Width,Height,Radius: integer); +var + path:TGPGraphicsPath; + gppen:TGPPen; +begin + path := TGPGraphicsPath.Create; + gppen := tgppen.Create(ColorToARGB(PC),1); + path.AddLine(X + width , Y + height, X + radius, Y + height); + path.AddArc(X, Y + height - (radius*2), radius*2, radius*2, 90, 90); + path.AddLine(X, Y + height - (radius*2), X, Y + radius); + path.AddArc(X, Y, radius*2, radius*2, 180, 90); + path.AddLine(X + radius, Y, X + width, Y); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + + path := TGPGraphicsPath.Create; + gppen := tgppen.Create(ColorToARGB(BrightnessColor(PC,-5)),1); + path.AddLine(X + Width , Y, X + width , Y + Height); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + +end; + +procedure DrawOpenRoundRectRight(graphics: TGPGraphics; PC: TColor; X,Y,Width,Height,Radius: integer;Hot: boolean); +var + path:TGPGraphicsPath; + gppen:TGPPen; +begin + path := TGPGraphicsPath.Create; + gppen := tgppen.Create(ColorToARGB(PC),1); + path.AddLine(X, Y, X + width - (radius *2), Y); + path.AddArc(X + width - (radius*2), Y, radius*2, radius*2, 270, 90); + path.AddLine(X + width, Y + radius, X + width, Y + height - (radius*2)); + path.AddArc(X + width - (radius*2), Y + height - (radius*2), radius*2, radius*2,0,90); + path.AddLine(X + width , Y + height, X, Y + height); + graphics.DrawPath(gppen, path); + gppen.Free; + + path.Free; + + + if hot then + begin + path := TGPGraphicsPath.Create; + gppen := tgppen.Create(ColorToARGB(BrightnessColor(PC,-5)),1); + path.AddLine(X , Y, X , Y + Height); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + end + else + begin + path := TGPGraphicsPath.Create; + // 3D color effect + gppen := tgppen.Create(ColorToARGB(BrightnessColor(clwhite,-10)),1); + path.AddLine(X, Y + 2, X, Y + Height - 2); + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; + end; +end; + +//------------------------------------------------------------------------------ + +procedure DrawDottedRoundRect(graphics: TGPGraphics; PC: TColor; X,Y,Width,Height,Radius: integer); +var + path:TGPGraphicsPath; + gppen:TGPPen; +begin + path := TGPGraphicsPath.Create; + gppen := tgppen.Create(ColorToARGB(PC),1); + gppen.SetDashStyle(DashStyleDot); + path.AddLine(X + radius, Y, X + width - (radius*2), Y); + path.AddArc(X + width - (radius*2), Y, radius*2, radius*2, 270, 90); + path.AddLine(X + width, Y + radius, X + width, Y + height - (radius*2)); + path.AddArc(X + width - (radius*2), Y + height - (radius*2), radius*2, radius*2,0,90); + path.AddLine(X + width - (radius*2), Y + height, X + radius, Y + height); + path.AddArc(X, Y + height - (radius*2), radius*2, radius*2, 90, 90); + path.AddLine(X, Y + height - (radius*2), X, Y + radius); + path.AddArc(X, Y, radius*2, radius*2, 180, 90); + path.CloseFigure; + graphics.DrawPath(gppen, path); + gppen.Free; + path.Free; +end; + + +//------------------------------------------------------------------------------ + +procedure DrawRoundRect(graphics: TGPGraphics; PC: TColor; X,Y,Width,Height,Radius: integer); +var + path:TGPGraphicsPath; + gppen:TGPPen; + r: integer; +begin + gppen := tgppen.Create(ColorToARGB(PC),1); + + if radius = 0 then + begin + graphics.DrawRectangle(gppen, X, Y, Width, Height); + end + else + begin + r := radius * 2; + path := TGPGraphicsPath.Create; + //gppen := tgppen.Create(ColorToARGB(PC),1); + path.AddLine(X + radius, Y, X + width - r, Y); + path.AddArc(X + width - r, Y, r, r, 270, 90); + path.AddLine(X + width, Y + radius, X + width, Y + height - r); + path.AddArc(X + width - r, Y + height - r, r, r,0,90); + path.AddLine(X + width - r, Y + height, X + radius, Y + height); + path.AddArc(X, Y + height - r, r, r, 90, 90); + path.AddLine(X, Y + height - r, X, Y + radius); + path.AddArc(X, Y, r, r, 180, 90); + path.CloseFigure; + graphics.DrawPath(gppen, path); + path.Free; + end; + gppen.Free; +end; + +procedure DrawArrow(Canvas: TCanvas; ArP: TPoint; ArClr, ArShad: TColor; Down:boolean); +begin + if Down then + begin + Canvas.Pen.Color := ArClr; + Canvas.MoveTo(ArP.X, ArP.Y); + Canvas.LineTo(ArP.X + 5, ArP.Y); + Canvas.MoveTo(ArP.X + 1, ArP.Y + 1); + Canvas.LineTo(ArP.X + 4, ArP.Y + 1); + Canvas.Pixels[ArP.X + 2, ArP.Y + 2] := ArClr; + Canvas.Pixels[ArP.X, ArP.Y + 1] := ArShad; + Canvas.Pixels[ArP.X + 4, ArP.Y + 1] := ArShad; + Canvas.Pixels[ArP.X + 1, ArP.Y + 2] := ArShad; + Canvas.Pixels[ArP.X + 3, ArP.Y + 2] := ArShad; + Canvas.Pixels[ArP.X + 2, ArP.Y + 3] := ArShad; + end + else + begin + Canvas.Pen.Color := ArClr; + Canvas.MoveTo(ArP.X, ArP.Y); + Canvas.LineTo(ArP.X, ArP.Y + 5); + Canvas.MoveTo(ArP.X + 1, ArP.Y + 1); + Canvas.LineTo(ArP.X + 1, ArP.Y + 4); + Canvas.Pixels[ArP.X + 2, ArP.Y + 2] := ArClr; + Canvas.Pixels[ArP.X + 2, ArP.Y + 1] := ArShad; + Canvas.Pixels[ArP.X + 1, ArP.Y + 4] := ArShad; + Canvas.Pixels[ArP.X + 2, ArP.Y + 1] := ArShad; + Canvas.Pixels[ArP.X + 3, ArP.Y + 2] := ArShad; + Canvas.Pixels[ArP.X + 3, ArP.Y + 2] := ArShad; + end; +end; + +procedure DrawButtonBackground(Canvas: TCanvas; Graphics: TGPGraphics; R: TRect; CF,CT: TColor; Gradient: TGDIPGradient; Upper: boolean); +var + path: TGPGraphicsPath; + pthGrBrush: TGPPathGradientBrush; + linGrBrush: TGPLinearGradientBrush; + solGrBrush: TGPSolidBrush; + + w,h,w2,h2: Integer; + colors : array[0..0] of TGPColor; + count: Integer; + +begin + w := r.Right - r.Left; + h := r.Bottom - r.Top; + + h2 := h div 2; + w2 := w div 2; + + { + // draw background + if Upper then + Canvas.Brush.Color := CF + else + Canvas.Brush.Color := CT; + Canvas.FillRect(rect(r.Left , r.Top, r.Right , r.Bottom)); + } + + if Upper then + solGrBrush := TGPSolidBrush.Create(ColorToARGB(CF)) + else + solGrBrush := TGPSolidBrush.Create(ColorToARGB(CT)); + + Graphics.FillRectangle(solGrBrush, MakeRect(r.Left , r.Top, r.Right , r.Bottom)); + + solGrBrush.Free; + + // Create a path that consists of a single ellipse. + path := TGPGraphicsPath.Create; + + if Upper then // take borders in account + path.AddEllipse(r.Left, r.Top - h2 + 2, r.Right , r.Bottom) + else + path.AddEllipse(r.Left, r.Top, r.Right , r.Bottom); + + pthGrBrush := nil; + linGrBrush := nil; + + case Gradient of + ggRadial: pthGrBrush := TGPPathGradientBrush.Create(path); + ggVertical: linGrBrush := TGPLinearGradientBrush.Create(MakeRect(r.Left,r.Top,w,h),ColorToARGB(CF),ColorToARGB(CT), LinearGradientModeVertical); + ggDiagonalForward: linGrBrush := TGPLinearGradientBrush.Create(MakeRect(r.Left,r.Top,w,h),ColorToARGB(CF),ColorToARGB(CT), LinearGradientModeForwardDiagonal); + ggDiagonalBackward: linGrBrush := TGPLinearGradientBrush.Create(MakeRect(r.Left,r.Top,w,h),ColorToARGB(CF),ColorToARGB(CT), LinearGradientModeBackwardDiagonal); + end; + + if Gradient = ggRadial then + begin + if Upper then + pthGrBrush.SetCenterPoint(MakePoint(r.Left + w2, r.Top)) + else + pthGrBrush.SetCenterPoint(MakePoint(r.Left + w2, r.Bottom)); + + // Set the color at the center point to blue. + if Upper then + begin + pthGrBrush.SetCenterColor(ColorToARGB(CT)); + colors[0] := ColorToARGB(CF); + end + else + begin + pthGrBrush.SetCenterColor(ColorToARGB(CF)); + colors[0] := ColorToARGB(CT); + end; + + count := 1; + pthGrBrush.SetSurroundColors(@colors, count); + graphics.FillRectangle(pthGrBrush, r.Left, r.Top, r.Right, r.Bottom); + pthGrBrush.Free; + end + else + begin + graphics.FillRectangle(linGrBrush, r.Left, r.Top, r.Right, r.Bottom); + linGrBrush.Free; + end; + + path.Free; +end; + +//------------------------------------------------------------------------------ + +procedure DrawStretchPicture(graphics : TGPGraphics; Canvas: TCanvas; R: TRect; Pic: TGDIPPicture); +var + Img: TGPImage; + pstm: IStream; + hGlobal: THandle; + pcbWrite: Longint; + ms: TMemoryStream; + bmp: TBitmap; +begin + ms := TMemoryStream.Create; + Pic.SaveToStream(ms); + hGlobal := GlobalAlloc(GMEM_MOVEABLE, ms.Size); + if (hGlobal = 0) then + begin + ms.Free; + raise Exception.Create('Could not allocate memory for image'); + end; + + try + pstm := nil; + + // Create IStream* from global memory + CreateStreamOnHGlobal(hGlobal, TRUE, pstm); + pstm.Write(ms.Memory, ms.Size,@pcbWrite); + + Img := TGPImage.Create(pstm); + if Img.GetFormat = ifBMP then + begin // use this alternative for easy bitmap auto transparent drawing + bmp := TBitmap.Create; + ms.Position := 0; + bmp.LoadFromStream(ms); + bmp.TransparentMode := tmAuto; + bmp.Transparent := true; + Canvas.StretchDraw(R, bmp); + bmp.Free; + end + else + begin + graphics.DrawImageRect(Img, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top); + end; + + Img.Free; + ms.Free; + finally + GlobalFree(hGlobal); + end; +end; + +//------------------------------------------------------------------------------ + +function DrawVistaButton(Canvas: TCanvas; r: TRect; CFU, CTU, CFB, CTB, PC: TColor; + GradientU, GradientB: TGDIPGradient; Caption:string; WideCaption: widestring; DrawCaption: Boolean; AFont: TFont; + Images: TImageList; ImageIndex: Integer; EnabledImage: Boolean; Layout: TButtonLayout; + DropDownButton: Boolean; DrawDwLine: Boolean; Enabled: Boolean; Focus: Boolean; DropDownPos: TDropDownPosition; + Picture: TGDIPPicture; ForcePicSize: TSize; AntiAlias: TAntiAlias; DrawPic: Boolean; Glyph: TBitmap; ButtonDisplay: TButtonDisplay; Transparent, Hot: boolean; + ButtonPosition: TButtonPosition; DropDownSplit, DrawBorder, OverlapText, WordWrap, AutoSize, Rounded, DropDir: Boolean; Spacing: integer; + Trimming: TStringTrimming;Notes: TStringList; NotesFont: TFont;Checked: boolean): TSize; +var + graphics : TGPGraphics; + path: TGPGraphicsPath; + pthGrBrush: TGPPathGradientBrush; + linGrBrush: TGPLinearGradientBrush; + count: Integer; + w,h,h2,h2d: Integer; + colors : array[0..0] of TGPColor; + fontFamily,nfontFamily: TGPFontFamily; + font,nfont: TGPFont; + rectf: TGPRectF; + stringFormat: TGPStringFormat; + solidBrush,nsolidBrush: TGPSolidBrush; + x1,y1,x2,y2: single; + fs,nfs: integer; + sizerect: TGPRectF; + noterect: TGPRectF; + ImgX, ImgY, ImgW, ImgH: Integer; + BtnR, DwR: TRect; + BR1,BR2: TRect; + DR1,DR2: TRect; + AP: TPoint; + szRect: TRect; + tm: TTextMetric; + ttf: boolean; + Radius: integer; + uformat,wwformat: Cardinal; + tdrect: TRect; + th, px, py: integer; + notesrect: TRect; + +begin + BtnR := R; + + if Rounded then + Radius := 3 + else + Radius := 0; + + if DropDownPos = dpRight then + begin + DwR := Rect(BtnR.Right - DropDownSectWidth, BtnR.Top, BtnR.Right, BtnR.Bottom); + if DropDownButton then + BtnR.Right := DwR.Left; + end + else // DropDownPos = doBottom + begin + DwR := Rect(BtnR.Left, BtnR.Bottom - DropDownSectWidth, BtnR.Right, BtnR.Bottom); + if DropDownButton then + BtnR.Bottom := DwR.Top; + end; + + if (Notes.Text <> '') then + Layout := blGlyphLeftAdjusted; + + w := r.Right - r.Left; + h := r.Bottom - r.Top; + + h2 := h div 2; + + // Create GDI+ canvas + graphics := TGPGraphics.Create(Canvas.Handle); + + if not Transparent then + begin + + if DropDownButton and (DrawDwLine) and DropDownSplit then + begin + if DropDownPos = dpRight then + begin + DR1 := Rect(r.Right - 12, r.Top + h2 - 1, r.Right, r.Bottom); + DR2 := Rect(r.Right - 12, r.Top, r.Right, r.Bottom - h2); + BR1 := Rect(r.Left, r.Top + h2 - 1, r.Right - 12, r.Bottom); + BR2 := Rect(r.Left, r.Top, r.Right - 12, r.Bottom - h2); + end + else + begin + DR1 := Rect(r.Left, r.Bottom - 6, r.Right, r.Bottom); + DR2 := Rect(r.Left, r.Bottom - 12, r.Right, r.Bottom - 6); + + DR2 := Rect(r.Left, r.Bottom - 12, r.Right, r.Bottom); + + h2d := (r.Bottom - r.Top - 12) div 2; + BR1 := Rect(r.Left, r.Top + h2d - 1, r.Right, r.Bottom - 12); + BR2 := Rect(r.Left, r.Top, r.Right, r.Bottom - 12 - h2d); + end; + + if ButtonDisplay = bdDropDown then + begin + DrawButtonBackground(Canvas, Graphics, BR1, CTB, CFB, GradientB, False); + DrawButtonBackground(Canvas, Graphics, BR2, CFU, CTU, GradientU, True); + + DrawButtonBackground(Canvas, Graphics, DR2, BrightnessColor(CFU,-10), BrightnessColor(CTU,-10), GradientU, True); + if (DropDownPos = dpRight) then + DrawButtonBackground(Canvas, Graphics, DR1, BrightnessColor(CTB,-10), BrightnessColor(CFB,-10), GradientB, False); + end + else + begin + DrawButtonBackground(Canvas, Graphics, BR1, BrightnessColor(CTB,-10), BrightnessColor(CFB,-10), GradientB, False); + DrawButtonBackground(Canvas, Graphics, BR2, BrightnessColor(CFU,-10), BrightnessColor(CTU,-10), GradientU, True); + + DrawButtonBackground(Canvas, Graphics, DR2, CFU, CTU, ggRadial, True); + if DropDownPos = dpRight then + DrawButtonBackground(Canvas, Graphics, DR1, CTB, CFB, GradientB, False); + end; + end + else + begin + DrawButtonBackground(Canvas, Graphics, Rect(r.Left, r.Top + h2 - 1, r.Right, r.Bottom), CTB, CFB, GradientB, False); + DrawButtonBackground(Canvas, Graphics, Rect(r.Left, r.Top, r.Right, r.Bottom - h2), CFU, CTU, GradientU, True); + end; + end; + + graphics.SetSmoothingMode(SmoothingModeAntiAlias); + + if not Transparent and DrawBorder then + begin + case ButtonPosition of + bpStandalone: DrawRoundRect(Graphics, PC, r.Left, r.Top, r.Right - 1, r.Bottom - 1, Radius); + bpLeft: DrawOpenRoundRectLeft(Graphics, PC, r.Left, r.Top, r.Right - 1, r.Bottom - 1, Radius); + bpRight: DrawOpenRoundRectRight(Graphics, PC, r.Left, r.Top, r.Right - 1, r.Bottom - 1, Radius, Hot or Checked); + bpMiddle: DrawOpenRoundRectMiddle(Graphics, PC, r.Left, r.Top, r.Right - 1, r.Bottom - 1, Radius, Hot or Checked); + end; + end; + + if Focus then // Draw focus line + begin + graphics.SetSmoothingMode(SmoothingModeAntiAlias); + DrawRoundRect(graphics, $E4AD89,r.Left + 1,r.Top + 1, r.Right - 3, r.Bottom - 3, Radius); + graphics.SetSmoothingMode(SmoothingModeAntiAlias); + DrawDottedRoundRect(graphics, clGray,r.Left + 2,r.Top + 2, r.Right - 5, r.Bottom - 5, Radius); + end; + + ImgX := 0; + ImgY := 0; + ImgH := 0; + ImgW := 0; + + fontFamily := TGPFontFamily.Create(AFont.Name); + + if (fontFamily.Status in [FontFamilyNotFound, FontStyleNotFound]) then + begin + fontFamily.Free; + fontFamily := TGPFontFamily.Create('Arial'); + end; + + nfontFamily := TGPFontFamily.Create(NotesFont.Name); + + if (nfontFamily.Status in [FontFamilyNotFound, FontStyleNotFound]) then + begin + nfontFamily.Free; + nfontFamily := TGPFontFamily.Create('Arial'); + end; + + + fs := 0; + if (fsBold in AFont.Style) then + fs := fs + 1; + if (fsItalic in AFont.Style) then + fs := fs + 2; + if (fsUnderline in AFont.Style) then + fs := fs + 4; + + nfs := 0; + if (fsBold in NotesFont.Style) then + nfs := nfs + 1; + if (fsItalic in NotesFont.Style) then + nfs := nfs + 2; + if (fsUnderline in NotesFont.Style) then + nfs := nfs + 4; + + if Assigned(Glyph) and not Glyph.Empty and (Glyph.Width > 1) and (Glyph.Height > 1) then + begin + ImgW := Glyph.Width; + ImgH := Glyph.Height; + + if (ForcePicSize.CX > 0) and (ForcePicSize.CY > 0) then + begin + ImgW := ForcePicSize.CX; + ImgH := ForcePicSize.CY; + end; + end + else if Assigned(Picture) and not Picture.Empty then + begin + Picture.GetImageSizes; + ImgW := Picture.Width; + ImgH := Picture.Height; + if (ForcePicSize.CX > 0) and (ForcePicSize.CY > 0) then + begin + ImgW := ForcePicSize.CX; + ImgH := ForcePicSize.CY; + end; + end + else + begin + if (ImageIndex > -1) and Assigned(Images) then + begin + ImgW := Images.Width; + ImgH := Images.Height; + {end + else if Assigned(ToolImage) and not (ToolImage.Empty) and (ToolImage.Width > 1) then + begin + ImgW := ToolImage.Width; + ImgH := ToolImage.Height; } + end; + end; + + if DrawCaption and ((Caption <> '') or (WideCaption <> '')) then + if (ImgW > 0) then + ImgW := ImgW + Spacing; + + Result.cx := ImgW; + Result.cy := ImgH; + + if (Caption <> '') or (WideCaption <> '') then + begin + if pos('\n',caption) > 0 then + begin + if (ForcePicSize.cx > 0) and (ForcePicSize.cy > 0) then + Caption := StringReplace(caption, '\n', ' ', [rfReplaceAll, rfIgnoreCase]) + else + Caption := StringReplace(caption, '\n', #10#13, [rfReplaceAll, rfIgnoreCase]); + end; + + Canvas.Font.Name := AFont.Name; + + ttf := false; + + GetTextMetrics(Canvas.Handle, tm); + + if ((tm.tmPitchAndFamily AND TMPF_VECTOR) = TMPF_VECTOR) then + begin + if not ((tm.tmPitchAndFamily AND TMPF_DEVICE) = TMPF_DEVICE) then + begin + ttf := true; + end + end; + + if Screen.Fonts.IndexOf(AFont.Name) = -1 then + ttf := false; + + font := TGPFont.Create(fontFamily, AFont.Size , fs, UnitPoint); + + w := BtnR.Right - BtnR.Left; + h := BtnR.Bottom - BtnR.Top; + + x1 := r.Left; + y1 := r.Top; + x2 := w; + y2 := h; + + if AutoSize then + begin + x2 := 4096; + y2 := 4096; + end; + + rectf := MakeRect(x1,y1,x2,y2); + + if WordWrap then + stringFormat := TGPStringFormat.Create(0) + else + stringFormat := TGPStringFormat.Create(GDIP_NOWRAP); + + if Enabled then + solidBrush := TGPSolidBrush.Create(ColorToARGB(AFont.Color)) + else + solidBrush := TGPSolidBrush.Create(ColorToARGB(clGray)); + + // Center-justify each line of text. + // stringFormat.SetAlignment(StringAlignmentCenter); + case Layout of + blGlyphLeftAdjusted: stringFormat.SetAlignment(StringAlignmentNear); + blGlyphRightAdjusted: stringFormat.SetAlignment(StringAlignmentFar); + else stringFormat.SetAlignment(StringAlignmentCenter); + end; + + // Center the block of text (top to bottom) in the rectangle. + + case Layout of + blGlyphTopAdjusted: stringFormat.SetLineAlignment(StringAlignmentNear); + blGlyphBottomAdjusted: stringFormat.SetLineAlignment(StringAlignmentFar); + else stringFormat.SetLineAlignment(StringAlignmentCenter); + end; + + stringFormat.SetHotkeyPrefix(HotkeyPrefixShow); + stringFormat.SetTrimming(Trimming); + + case AntiAlias of + aaClearType:graphics.SetTextRenderingHint(TextRenderingHintClearTypeGridFit); + aaAntiAlias:graphics.SetTextRenderingHint(TextRenderingHintAntiAlias); + end; + + if (AntiAlias = aaNone) or not ttf then + begin + Canvas.Font.Assign(AFont); + szRect.Left := round(rectf.X); + szRect.Top := round(rectf.Y); + + szRect.Right := szRect.Left + 2; + + if Caption <> '' then + szRect.Bottom := DrawText(Canvas.Handle,PChar(Caption),Length(Caption), szrect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE{ or DT_VCENTER}) + else + szRect.Bottom := DrawTextW(Canvas.Handle,PWideChar(WideCaption),Length(WideCaption), szrect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE{ or DT_VCENTER}); + + sizeRect.Width := szRect.Right - szRect.Left; + sizeRect.Height := szRect.Bottom - szRect.Top; + + notesRect := Rect(0,0,0,0); + + if Notes.Text <> '' then + begin + Canvas.Font.Assign(NotesFont); + notesRect.Left := round(rectf.X); + notesRect.Top := round(rectf.Y); + notesRect.Right := notesRect.Left + 2; + notesRect.Bottom := DrawText(Canvas.Handle,PChar(Notes.Text),Length(Notes.Text), notesRect, DT_CALCRECT or DT_LEFT or DT_WORDBREAK); + + noteRect.Width := notesRect.Right - notesRect.Left; + noteRect.Height := notesRect.Bottom - notesRect.Top; + end; + + case Layout of + blGlyphLeft: + begin + sizeRect.X := (w - (szRect.Right - szRect.Left) - ImgW) div 2; + sizeRect.Y := szRect.Top; + Result.cx := ImgW + Spacing + round(sizerect.Width); + Result.cy := Max(ImgH + Spacing, Spacing + round(sizerect.Height)); + end; + blGlyphLeftAdjusted: + begin + sizeRect.X := szRect.Left; + sizeRect.Y := szRect.Top; + Result.cx := ImgW + Spacing + Max(round(sizerect.Width),round(noteRect.Width)); + Result.cy := Max(ImgH + Spacing, Spacing + round(sizerect.Height)+round(noteRect.Height)); + end; + blGlyphTop: + begin + sizeRect.X := szRect.Left; + sizeRect.Y := (h - (szRect.Bottom - szRect.Top) - ImgH - 2) div 2; + Result.cx := Max(ImgW + Spacing, Spacing + round(sizerect.Width)); + Result.cy := ImgH + Spacing + round(sizerect.Height); + end; + blGlyphTopAdjusted: + begin + sizeRect.X := szRect.Left; + sizeRect.Y := szRect.Top; + Result.cx := Max(ImgW + Spacing, Spacing + round(sizerect.Width)); + Result.cy := ImgH + Spacing + round(sizerect.Height); + end; + blGlyphRight: + begin + sizeRect.X := szRect.Left; + sizeRect.Y := szRect.Top; + Result.cx := ImgW + Spacing + round(sizerect.Width); + Result.cy := Max(ImgH + Spacing, Spacing + round(sizerect.Height)); + end; + blGlyphRightAdjusted: + begin + sizeRect.X := szRect.Left; + sizeRect.Y := szRect.Top; + Result.cx := ImgW + Spacing + round(sizerect.Width); + Result.cy := Max(ImgH + Spacing, Spacing + round(sizerect.Height)); + end; + blGlyphBottom: + begin + sizeRect.X := szRect.Left; + sizeRect.Y := szRect.Top; + Result.cx := Max(ImgW + Spacing, Spacing + round(sizerect.Width)); + Result.cy := ImgH + Spacing + round(sizerect.Height); + end; + blGlyphBottomAdjusted: + begin + sizeRect.X := szRect.Left; + sizeRect.Y := szRect.Top; + Result.cx := Max(ImgW + Spacing, Spacing + round(sizerect.Width)); + Result.cy := ImgH + Spacing + round(sizerect.Height); + end; + end; + //Result.cx := ImgW + Spacing + round(sizerect.Width); + //Result.cy := Max(ImgH + Spacing, Spacing + round(sizerect.Height)); + end + else + begin + if Caption <> '' then + graphics.MeasureString(Caption, Length(Caption), font, rectf, stringFormat, sizeRect) + else + graphics.MeasureString(WideCaption, Length(WideCaption), font, rectf, stringFormat, sizeRect); + + noteRect := MakeRect(0,0,0,0); + + if Notes.Text <> '' then + begin + nfont := TGPFont.Create(nfontFamily, NotesFont.Size , nfs, UnitPoint); + graphics.MeasureString(Notes.Text, Length(Notes.Text), nfont, rectf, stringFormat, noteRect); + nfont.Free; + end; + + case Layout of + blGlyphLeft, blGlyphLeftAdjusted, blGlyphRight, blGlyphRightAdjusted: + begin + Result.cx := ImgW + Spacing + Max(round(sizerect.Width), round(noteRect.Width)); + Result.cy := Max(ImgH + Spacing, Spacing + round(sizerect.Height)+round(noteRect.Height)); + end; + blGlyphTop, blGlyphTopAdjusted, blGlyphBottom, blGlyphBottomAdjusted: + begin + Result.cx := Max(ImgW + Spacing, Spacing + round(sizerect.Width)); + Result.cy := ImgH + Spacing + round(sizerect.Height); + end; + end; + end; + + if not AutoSize then + begin + if not WordWrap then + begin + x2 := w; + y2 := h; + rectf := MakeRect(x1,y1,x2,y2); + end; + + +// if (ImgW > 0) then + begin + case Layout of + blGlyphLeft: + begin + if (AntiAlias = aaNone) or not ttf then + begin + x1 := sizeRect.X + ImgW; + x2 := w - 2 - ImgW; + ImgX := round(sizeRect.X); + end + else + begin + x1 := r.Left + 2 + ImgW; + x2 := w - 2 - ImgW; + ImgX := round(sizerect.X - ImgW div 2); + end; + if ImgX < 2 then ImgX := 2; + ImgY := r.Top + Max(0, (h - ImgH) div 2); + end; + blGlyphLeftAdjusted: + begin + x1 := r.Left + 2 + ImgW; + x2 := w - 2 - ImgW; + + ImgX := round(sizerect.X - ImgW div 2); + if ImgX < 2 then ImgX := 2; + ImgY := r.Top + Max(0, (h - ImgH) div 2); + end; + blGlyphTop: + begin + if (AntiAlias = aaNone) or not ttf then + begin + y1 := r.Top + ImgH; + // y1 := sizeRect.Y + ImgH; + y2 := h - 2 - ImgH; + + ImgX := r.Left + Max(0, (w - ImgW) div 2); +// ImgY := round(sizeRect.Y); + ImgY := round(y2 - sizerect.Height); + ImgY := Max(0, ImgY div 2); + ImgY := round(y1) - ImgH + ImgY - 4; + end + else + begin + y1 := r.Top + ImgH; + y2 := h - 2 - ImgH; + ImgX := r.Left + Max(0, (w - ImgW) div 2); + ImgY := round(y2 - sizerect.Height); + ImgY := Max(0, ImgY div 2); + ImgY := round(y1) - ImgH + ImgY; + end; + if ImgY < 2 then ImgY := 2; + end; + blGlyphTopAdjusted: + begin + y1 := r.Top{ + 2} + ImgH; + y2 := h - 2 - ImgH; + + ImgX := r.Left + Max(0, (w - ImgW) div 2); + if Layout = blGlyphTopAdjusted then + ImgY := 0 //force to top margin + else + ImgY := round(y2 - sizerect.Height); + ImgY := Max(0, ImgY div 2); + ImgY := round(y1) - ImgH + ImgY; //round(sizerect.Height) - ImgY - 4; + if ImgY < 2 then ImgY := 2; + end; + blGlyphRight, blGlyphRightAdjusted: + begin + x1 := 2; + x2 := w - 4 - ImgW; + if Layout = blGlyphRightAdjusted then + ImgX := w - ImgW - 2 + else + begin + + ImgX := round(X2 - sizerect.width); + ImgX := Max(0, ImgX div 2); + ImgX := ImgX + round(sizerect.width) + 4; + if ImgX > (w - ImgW) then + ImgX := w - ImgW - 2; + end; + ImgY := r.Top + Max(0, (h - ImgH) div 2); + end; + blGlyphBottom: + begin + if (AntiAlias = aaNone) or not ttf then + begin + y1 := 2; + y2 := h - 2 - ImgH; + + ImgX := r.Left + Max(0, (w - ImgW) div 2); + ImgY := round(y2 - sizerect.Height); + ImgY := Max(0, ImgY div 2); + ImgY := round(sizerect.Height + 5) + ImgY; + if ImgY > (h - ImgH) then ImgY := h - ImgH - 2; + end + else + begin + y1 := 2; + y2 := h - 2 - ImgH; + + ImgX := r.Left + Max(0, (w - ImgW) div 2); + ImgY := round(y2 - sizerect.Height); + ImgY := Max(0, ImgY div 2); + ImgY := round(sizerect.Height + 2) + ImgY; + if ImgY > (h - ImgH) then ImgY := h - ImgH - 2; + end; + end; + blGlyphBottomAdjusted: + begin + if (AntiAlias = aaNone) or not ttf then + begin + y1 := 2; + y2 := h - 4 - ImgH; + + ImgX := r.Left + Max(0, (w - ImgW) div 2); + ImgY := (h - ImgH - 2); + end + else + begin + y1 := 2; + y2 := h - 2 - ImgH; + + ImgX := r.Left + Max(0, (w - ImgW) div 2); + if Layout = blGlyphBottomAdjusted then + ImgY := h; //force to bottom margin + + ImgY := Max(0, ImgY div 2); + ImgY := round(sizerect.Height + 2) + ImgY; + if ImgY > (h - ImgH) then ImgY := h - ImgH - 2; + end; + end; + end; + end; + + if OverlapText then + rectf := MakeRect(r.Left, r.Top, r.Right, r.Bottom) + else + rectf := MakeRect(x1, y1, x2, y2); + + if DrawPic and OverlapText then + begin + if Assigned(Glyph) and not Glyph.Empty and (Glyph.Width > 1) and (Glyph.Height > 1) then + Canvas.Draw(ImgX, ImgY, Glyph); + end; + + if DrawCaption then + begin + if (AntiAlias = aaNone) or not ttf then + begin + szRect.Left := round(rectf.X); + szRect.Top := round(rectf.Y); + szRect.Right := szRect.Left + round(rectf.Width); + szRect.Bottom := szRect.Top + round(rectf.Height); + + Canvas.Brush.Style := bsClear; + if WordWrap then + wwformat := 0 + else + wwformat := DT_SINGLELINE; + + uformat := DT_VCENTER or wwformat; + + case Layout of + blGlyphLeft: + begin + uformat := DT_VCENTER or wwformat or DT_LEFT; + szrect.Left := szrect.Left; + end; + blGlyphLeftAdjusted: + begin + uformat := DT_VCENTER or wwformat or DT_LEFT; + szrect.Left := szrect.Left + 2; + + if Notes.Text <> '' then + begin + uformat := uformat AND NOT DT_VCENTER; + szrect.Top := ((szRect.Bottom - szRect.Top) - round(sizeRect.Height) - round(noteRect.Height)) div 2; + end; + + end; + blGlyphTop: + begin + uformat := DT_TOP or wwformat or DT_CENTER or DT_VCENTER; + end; + blGlyphTopAdjusted: uformat := DT_TOP or wwformat or DT_CENTER; + blGlyphRight: uformat := DT_VCENTER or wwformat or DT_CENTER; + blGlyphRightAdjusted: uformat := DT_VCENTER or wwformat or DT_RIGHT; + blGlyphBottom: uformat := DT_VCENTER or wwformat or DT_CENTER; + blGlyphBottomAdjusted: uformat := DT_BOTTOM or wwformat or DT_CENTER; + end; + + tdrect := szrect; + + Canvas.Font.Assign(AFont); + + if not Enabled then + Canvas.Font.Color := clGray; + + if WordWrap then + begin + if Caption <> '' then + th := DrawText(Canvas.Handle,PChar(Caption),Length(Caption), szrect, uformat or DT_CALCRECT) + else + th := DrawTextW(Canvas.Handle,PWideChar(WideCaption),Length(WideCaption), szrect, uformat or DT_CALCRECT); + + case Layout of + blGlyphTopAdjusted: + begin + // do nothing + end; + blGlyphTop: + begin + tdrect.Top := ImgY + ImgH; + tdrect.Top := tdrect.Top + (tdrect.Bottom - tdrect.Top - th) div 2; + end; + blGlyphBottomAdjusted: + begin + tdrect.Top := tdrect.Bottom - th; + end; + else + begin + tdrect.Top := (tdrect.Bottom - tdrect.Top - th) div 2; + end; + end; + end; + + if Caption <> '' then + DrawText(Canvas.Handle,PChar(Caption),Length(Caption), tdrect, uformat) + else + DrawTextW(Canvas.Handle,PWideChar(WideCaption),Length(WideCaption), tdrect, uformat); + + if (Notes.Text <> '') then + begin + tdRect.Top := tdRect.Top + round(sizeRect.Height); + tdRect.Bottom := tdRect.Top + round(noteRect.Height); + Canvas.Font.Assign(NotesFont); + DrawText(Canvas.Handle,PChar(Notes.Text),Length(Notes.Text), tdrect, uformat); + end; + end + else + begin + if (Notes.Text <> '') then + begin + stringFormat.SetLineAlignment(StringAlignmentNear); + rectf.Y := rectf.Y + ((rectf.Height) - round(sizeRect.Height) - round(noteRect.Height)) / 2; + end; + + if (Caption <> '') then + graphics.DrawString(Caption, Length(Caption), font, rectf, stringFormat, solidBrush) + else + graphics.DrawString(WideCaption, Length(WideCaption), font, rectf, stringFormat, solidBrush); + + if (Notes.Text <> '') then + begin + rectf.Y := rectf.Y + round(sizeRect.Height); + nfont := TGPFont.Create(nfontFamily, NotesFont.Size , nfs, UnitPoint); + nsolidBrush := TGPSolidBrush.Create(ColorToARGB(NotesFont.Color)); + graphics.DrawString(Notes.Text, Length(Notes.Text), nfont, rectf, stringFormat, nsolidBrush); + nsolidBrush.Free; + nfont.Free; + end + end; + end; + end; + + stringformat.Free; + solidBrush.Free; + font.Free; + end; + + + fontFamily.Free; + nfontFamily.Free; + + if not AutoSize then + begin + if DropDownButton then + begin + if DropDownPos = dpRight then + w := w - 8 + else + h := h - 8; + end; + + if DrawPic and not OverlapText then + begin + if Assigned(Glyph) and not Glyph.Empty and (Glyph.Width > 1) and (Glyph.Height > 1) then + begin + if (ForcePicSize.CX > 0) and (ForcePicSize.CY > 0) then + begin + Glyph.Transparent := True; + if (Caption = '') and (WideCaption = '') then + begin + px := r.Left + Max(0, (w - ImgW) div 2); + py := r.Top + Max(0, (h - ImgH) div 2); + Canvas.StretchDraw(Rect(px, py, px + ForcePicSize.CX, py + ForcePicSize.CY), Glyph); + end + else + Canvas.StretchDraw(Rect(ImgX, ImgY, ImgX + ForcePicSize.CX, ImgY + ForcePicSize.CY), Glyph); + end + else + begin + if (Caption = '') and (WideCaption = '') then + Canvas.Draw(r.Left + Max(0, (w - ImgW) div 2), r.Top + Max(0, (h - ImgH) div 2), Glyph) + else + Canvas.Draw(ImgX, ImgY, Glyph); + end; + end + else + if Assigned(Picture) and not Picture.Empty then + begin + if (ForcePicSize.CX > 0) and (ForcePicSize.CY > 0) then + begin + if (Caption = '') and (WideCaption = '') then + begin + px := r.Left + Max(0, (w - ImgW) div 2); + py := r.Top + Max(0, (h - ImgH) div 2); + //Canvas.StretchDraw(Rect(px, py, px + ForcePicSize.CX, py + ForcePicSize.CY), Picture); + DrawStretchPicture(graphics, Canvas, Rect(px, py, px + ForcePicSize.CX, py + ForcePicSize.CY), Picture); + end + else + begin + //Canvas.StretchDraw(Rect(ImgX, ImgY, ImgX + ForcePicSize.CX, ImgY + ForcePicSize.CY), Picture); + DrawStretchPicture(graphics, Canvas, Rect(ImgX, ImgY, ImgX + ForcePicSize.CX, ImgY + ForcePicSize.CY), Picture); + end; + end + else + begin + if (Caption = '') and (WideCaption = '') then + Canvas.Draw(r.Left + Max(0, (w - ImgW) div 2), r.Top + Max(0, (h - ImgH) div 2), Picture) + else + Canvas.Draw(ImgX, ImgY, Picture); + end; + end + else + if (ImageIndex <> -1) and Assigned(Images) then + begin + if (Caption = '') and (WideCaption = '') then + Images.Draw(Canvas, r.Left + Max(0, (w - Images.Width) div 2), r.Top + Max(0, (h - Images.Height) div 2), ImageIndex, EnabledImage) + else + begin + Images.Draw(Canvas, ImgX, ImgY, ImageIndex, EnabledImage); + end; + {end + else if Assigned(ToolImage) and not (ToolImage.Empty) and (ToolImage.Width > 1) then + begin + if Caption = '' then + Canvas.Draw(r.Left + Max(0, (w - ImgW) div 2), r.Top + Max(0, (h - ImgH) div 2), ToolImage) + else + Canvas.Draw(ImgX, ImgY, ToolImage); } + end; + end; + + + Canvas.Brush.Style := bsClear; + + if DropDownButton then + begin + if DrawDwLine and DropDownSplit then + begin + Canvas.Pen.Color := ColorToRGB(PC); + if (DropDownPos = dpRight) then + begin + Canvas.MoveTo(DwR.Left, DwR.Top); + Canvas.LineTo(DwR.Left, DwR.Bottom); + end + else + begin + Canvas.MoveTo(DwR.Left, DwR.Top); + Canvas.LineTo(DwR.Right, DwR.Top); + end; + end; + + AP.X := DwR.Left + ((DwR.Right - DwR.Left - 5) div 2); + AP.Y := DwR.Top + ((DwR.Bottom - DwR.Top - 3) div 2) + 1; + + if not Enabled then + DrawArrow(Canvas, AP, clGray, clWhite, DropDir) + else + DrawArrow(Canvas, AP, clBlack, clWhite, DropDir); + end; + end; + + graphics.Free; +end; + +//------------------------------------------------------------------------------ + +{TWinCtrl} + +procedure TWinCtrl.PaintCtrls(DC: HDC; First: TControl); +begin + PaintControls(DC, First); +end; + +//------------------------------------------------------------------------------ + +{ TAdvGlowButton } + + +//------------------------------------------------------------------------------ + + +procedure TAdvCustomGlowButton.CMMouseEnter(var Msg: TMessage); +begin + inherited; + + if Assigned(FOnMouseEnter) then + FOnMouseEnter(Self); + + if (csDesigning in ComponentState) then + Exit; + + if FMouseEnter then + Exit; + + FHot := true; + + if FLeftDown then + FDown := true; + + if not Assigned(FTimer) then + begin + FTimer := TTimer.Create(self); + FTimer.OnTimer := TimerProc; + FTimer.Interval := GlowSpeed; + FTimer.Enabled := true; + end; + + if not FDown and (GlowState <> gsPush) then + begin + FTimeInc := 20; + GlowState := gsHover; + end; + Invalidate; + + FMouseInControl := true; + FMouseEnter := true; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.CMMouseLeave(var Msg: TMessage); +begin + inherited; + + if Assigned(FOnMouseLeave) then + FOnMouseLeave(Self); + + if (csDesigning in ComponentState) then + Exit; + + if not FMouseEnter then + Exit; + + FMouseEnter := false; + FMouseInControl := false; + + FHot := false; + FInButton := false; + +// Repaint; + + // down process busy + if FDown and FMouseDown then + begin + FDown := False; + FTimeInc := -20; + GlowState := gsHover; + Invalidate; + FLeftDown := true; + end + else + //if not (Style = bsCheck) then + begin + FDown := false; + FStepHover := 100; + FTimeInc := -20; + GlowState := gsHover; + Invalidate; + end; + + if not Assigned(FTimer) then + begin + FTimer := TTimer.Create(self); + FTimer.OnTimer := TimerProc; + FTimer.Interval := GlowSpeed; + FTimer.Enabled := true; + end; + +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.CMTextChanged(var Message: TMessage); +begin + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.CNCommand(var Message: TWMCommand); +begin + if Message.NotifyCode = BN_CLICKED then + Click; +end; + +//------------------------------------------------------------------------------ + +constructor TAdvCustomGlowButton.Create(AOwner: TComponent); +begin + inherited; + FTimer := nil; + FImageIndex := -1; + DoubleBuffered := true; + FGroupIndex := 0; + FState := absUp; + FStyle := bsButton; + FTransparent := False; + FLayout := blGlyphLeft; + FDropDownButton := False; + FDropDownPosition := dpRight; + FDropDownDirection := ddDown; + FDropDownSplit := true; + FShowCaption := true; + FFocusType := ftBorder; + FShortCutHint := nil; + FShortCutHintPos := shpTop; + FShowDisabled := true; + FOverlappedText := false; + FSpacing := 2; + FWordWrap := true; + FFirstPaint := true; + FMarginVert := 2; + FMarginHorz := 2; + FRounded := true; + FInitRepeatPause := 400; + FRepeatPause := 100; + FRepeatClick := false; + + FIPicture := TGDIPPicture.Create; + FIPicture.OnChange := PictureChanged; + + FIDisabledPicture := TGDIPPicture.Create; + FIDisabledPicture.OnChange := PictureChanged; + FIHotPicture := TGDIPPicture.Create; + + ParentFont := true; + FAppearance := TGlowButtonAppearance.Create; + FAppearance.OnChange := OnAppearanceChanged; + FInternalImages := nil; + FAntiAlias := aaClearType; + FBorderStyle := bsSingle; + + FOfficeHint := TAdvHintInfo.Create; + + Width := 100; + Height := 41; + + FDefaultPicDrawing := True; + FDefaultCaptionDrawing := True; + FTrimming := StringTrimmingNone; + + FCommandID := -1; + + FButtonSizeState := bsLarge; + FMaxButtonSizeState := bsLarge; + FMinButtonSizeState := bsGlyph; + FOldLayout := Layout; + FOldDropDownPosition := DropDownPosition; + + FNotes := TStringList.Create; + FNotesFont := TFont.Create; + FNotesFont.Name := 'Tahoma'; + FNotesFont.Size := 8; +end; + + +procedure TAdvCustomGlowButton.CreateParams(var Params: TCreateParams); +begin + inherited; +// if FTransparent then +// Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT; +end; + +procedure TAdvCustomGlowButton.CreateWnd; +begin + inherited; + FActive := FDefault; + FParentForm := GetParentForm(Self); +end; + +//------------------------------------------------------------------------------ + +destructor TAdvCustomGlowButton.Destroy; +begin + if Assigned(FShortCutHint) then + FShortCutHint.Free; + FOfficeHint.Free; + FAppearance.Free; + FIPicture.Free; + FIDisabledPicture.Free; + FIHotPicture.Free; + FNotes.Free; + FNotesFont.Free; + inherited; +end; + +procedure TAdvCustomGlowButton.DoEnter; +begin + inherited; + Invalidate; +end; + +procedure TAdvCustomGlowButton.DoExit; +begin + inherited; + FDown := false; + FState := absUp; + Invalidate; +end; + +procedure TAdvCustomGlowButton.ShowShortCutHint; +var + pt: TPoint; +begin + if not Assigned(FShortCutHint) then + begin + FShortCutHint := TShortCutHintWindow.Create(Self); + FShortCutHint.Parent := Self; + FShortCutHint.Visible := False; + FShortCutHint.Color := clWhite; + FShortCutHint.ColorTo := Appearance.Color; + end; + + FShortCutHint.Caption := FShortCutHintText; + + pt := ClientToScreen(Point(0,0)); + + case ShortCutHintPos of + shpLeft: + begin + FShortCutHint.Left := pt.X - (FShortCutHint.Width div 2); + FShortCutHint.Top := pt.Y + (self.Height - FShortCutHint.Height) div 2; + end; + shpTop: + begin + FShortCutHint.Left := pt.X + (self.Width - FShortCutHint.Width) div 2; + FShortCutHint.Top := pt.Y - (FShortCutHint.Height div 2); + end; + shpRight: + begin + FShortCutHint.Left := pt.X + self.Width - (FShortCutHint.Width div 2); + FShortCutHint.Top := pt.Y + (self.Height - FShortCutHint.Height) div 2; + end; + shpBottom: + begin + FShortCutHint.Left := pt.X + (self.Width - FShortCutHint.Width) div 2; + FShortCutHint.Top := pt.Y + self.Height - (FShortCutHint.Height div 2); + end; + shpCenter: + begin + FShortCutHint.Left := pt.X + (self.Width - FShortCutHint.Width) div 2; + FShortCutHint.Top := pt.Y + (self.Height - FShortCutHint.Height) div 2; + end; + end; + + FShortCutHint.Visible := true; +end; + +procedure TAdvCustomGlowButton.HideShortCutHint; +begin + if Assigned(FShortCutHint) then + begin + FShortCutHint.Visible := false; + //FShortCutHint.Free; + //FShortCutHint := nil; + end; +end; + +function TAdvCustomGlowButton.GetVersion: string; +var + vn: Integer; +begin + vn := GetVersionNr; + Result := IntToStr(Hi(Hiword(vn))) + '.' + IntToStr(Lo(Hiword(vn))) + + '.' + IntToStr(Hi(Loword(vn))) + '.' + IntToStr(Lo(Loword(vn))); +end; + +function TAdvCustomGlowButton.GetVersionNr: Integer; +begin + Result := MakeLong(MakeWord(BLD_VER, REL_VER), MakeWord(MIN_VER, MAJ_VER)); +end; + +procedure TAdvCustomGlowButton.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited; + if (Key in [VK_SPACE, VK_RETURN]) then + begin + FDown := True; + FState := absDown; + Repaint; + end; + + if (Key = VK_F4) then + DoDropDown; + + if Assigned(FOnInternalKeyDown) then + FOnInternalKeyDown(Self, Key, Shift); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.WMGetDlgCode(var Message: TMessage); +begin + if Assigned(FOnInternalKeyDown) then + Message.Result := DLGC_WANTARROWS + else + inherited; +end; + + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.KeyPress(var Key: Char); +var + Form: TCustomForm; +begin + inherited; + + if (Key in [#32, #13]) then + begin + Form := GetParentForm(Self); + if Form <> nil then + Form.ModalResult := ModalResult; + + if Assigned(OnClick) then + OnClick(Self); + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.KeyUp(var Key: Word; Shift: TShiftState); +begin + inherited; + FDown := False; + FState := absUp; + Repaint; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.Assign(Source: TPersistent); +begin + if (Source is TAdvCustomGlowButton) then + begin + Align := (Source as TAdvCustomGlowButton).Align; + Action := (Source as TAdvCustomGlowButton).Action; + Anchors := (Source as TAdvCustomGlowButton).Anchors; + AntiAlias := (Source as TAdvCustomGlowButton).AntiAlias; + AutoSize := (Source as TAdvCustomGlowButton).AutoSize; + BorderStyle := (Source as TAdvCustomGlowButton).BorderStyle; + Cancel := (Source as TAdvCustomGlowButton).Cancel; + Caption := (Source as TAdvCustomGlowButton).Caption; + Constraints := (Source as TAdvCustomGlowButton).Constraints; + Default := (Source as TAdvCustomGlowButton).Default; + Font.Assign((Source as TAdvCustomGlowButton).Font); + ImageIndex := (Source as TAdvCustomGlowButton).ImageIndex; + Images.Assign((Source as TAdvCustomGlowButton).Images); + DisabledImages.Assign((Source as TAdvCustomGlowButton).DisabledImages); + DisabledPicture.Assign((Source as TAdvCustomGlowButton).DisabledPicture); + DragMode := (Source as TAdvCustomGlowButton).DragMode; + DragKind := (Source as TAdvCustomGlowButton).DragKind; + FocusType := (Source as TAdvCustomGlowButton).FocusType; + HotImages.Assign((Source as TAdvCustomGlowButton).HotImages); + HotPicture.Assign((Source as TAdvCustomGlowButton).HotPicture); + MarginVert := (Source as TAdvCustomGlowButton).MarginVert; + MarginHorz := (Source as TAdvCustomGlowButton).MarginHorz; + ModalResult := (Source as TAdvCustomGlowButton).ModalResult; + Notes.Assign((Source as TAdvCustomGlowButton).Notes); + NotesFont.Assign((Source as TAdvCustomGlowButton).NotesFont); + OfficeHint.Assign((Source as TAdvCustomGlowButton).OfficeHint); + ParentFont := (Source as TAdvCustomGlowButton).ParentFont;; + Picture.Assign((Source as TAdvCustomGlowButton).Picture); + PopupMenu := (Source as TAdvCustomGlowButton).PopupMenu; + Position := (Source as TAdvCustomGlowButton).Position; + InitRepeatPause := (Source as TAdvCustomGlowButton).InitRepeatPause; + RepeatPause := (Source as TAdvCustomGlowButton).RepeatPause; + RepeatClick := (Source as TAdvCustomGlowButton).RepeatClick; + Rounded := (Source as TAdvCustomGlowButton).Rounded; + ShortCutHint := (Source as TAdvCustomGlowButton).ShortCutHint; + ShortCutHintPos := (Source as TAdvCustomGlowButton).ShortCutHintPos; + ShowCaption := (Source as TAdvCustomGlowButton).ShowCaption; + ShowDisabled := (Source as TAdvCustomGlowButton).ShowDisabled; + Spacing := (Source as TAdvCustomGlowButton).Spacing; + Transparent := (Source as TAdvCustomGlowButton).Transparent; + Trimming := (Source as TAdvCustomGlowButton).Trimming; + Version := (Source as TAdvCustomGlowButton).Version; + WordWrap := (Source as TAdvCustomGlowButton).WordWrap; + ShowHint := (Source as TAdvCustomGlowButton).ShowHint; + TabOrder := (Source as TAdvCustomGlowButton).TabOrder; + TabStop := (Source as TAdvCustomGlowButton).TabStop; + Visible := (Source as TAdvCustomGlowButton).Visible; + end; + +end; + +procedure TAdvCustomGlowButton.Click; +var + Form: TCustomForm; +begin + Form := GetParentForm(Self); + if Form <> nil then Form.ModalResult := ModalResult; + if Assigned(FOnInternalClick) then + FOnInternalClick(Self); + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.Loaded; +begin + inherited; + if (Down <> FInitialDown) then + Down := FInitialDown; + FIsVista := IsVista; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.DoDropDown; +var + pt: TPoint; +begin + if IsMenuButton or Assigned(FDropDownMenu) then + begin + {State := absDropDown; + Invalidate; + CheckMenuDropdown; } + + if Assigned(FDropDownMenu) then + begin + //FDown := false; + //FHot := false; + FState := absDown; + PopupBtnDown; + Invalidate; + + if DropDownDirection = ddDown then + pt := Point(Left, Top + Height) + else + pt := Point(Left + Width, Top); + + pt := Parent.ClientToScreen(pt); + FDropDownMenu.Popup(pt.X,pt.Y); + + FState := absUp; + Repaint; + end; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGlowButton.IsFontStored: Boolean; +begin + Result := not ParentFont; +end; + +function TAdvCustomGlowButton.IsMenuButton: Boolean; +begin + Result := False; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.TimerExpired(Sender: TObject); +begin + FRepeatTimer.Interval := RepeatPause; + if (FDown) and MouseCapture then + begin + try + Click; + except + FRepeatTimer.Enabled := False; + raise; + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.MouseUp(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + inherited MouseUp(Button, Shift, X, Y); + if FRepeatTimer <> nil then + FRepeatTimer.Enabled := False; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, + Y: Integer); +var + pt:TPoint; + InBottomDrop,InRightDrop: boolean; + InSepBtn: boolean; + +begin + inherited; + + if Button <> mbLeft then + Exit; + + if FRepeatClick then + begin + if FRepeatTimer = nil then + FRepeatTimer := TTimer.Create(Self); + + FRepeatTimer.OnTimer := TimerExpired; + FRepeatTimer.Interval := InitRepeatPause; + FRepeatTimer.Enabled := True; + end; + + + FDown := true; + FMouseDown := true; + + if TabStop then + SetFocus; + + if not Assigned(FTimer) then + begin + FTimer := TTimer.Create(self); + FTimer.OnTimer := TimerProc; + FTimer.Interval := GlowSpeed; + FTimer.Enabled := true; + end; + + //FStepPush := 0; + FTimeInc := +20; + GlowState := gsPush; + + if not DropDownButton and IsMenuButton and false then + begin + Invalidate; + DoDropDown; + end; + + InBottomDrop := (DropDownPosition = dpRight) and (X > (Width - DropDownSectWidth)); + InRightDrop := (DropDownPosition = dpBottom) and (Y > (Height - DropDownSectWidth)); + + InSepBtn := (InBottomDrop or InRightDrop); + + + if (not FDropDownButton and IsMenuButton) or + (FDropDownButton and InSepBtn and DropDownSplit) or + (FDropDownButton and not DropDownSplit and (not ((Style = bsCheck) or (GroupIndex > 0)))) + then + begin + // FState := absUp; + FMouseInControl := False; + // FMouseDownInControl := False; + PopupBtnDown; + + if Assigned(FDropDownMenu) then + begin + FDown := false; + FHot := false; + SetDroppedDown(True); + FMouseEnter := true; + //FMenuSel := true; + Repaint; + + if DropDownDirection = ddDown then + pt := Point(Left, Top + Height) + else + pt := Point(Left + Width, Top); + + pt := Parent.ClientToScreen(pt); + //if Assigned(AdvToolBar) then + //FDropDownMenu.MenuStyler := AdvToolBar.FCurrentToolBarStyler.CurrentAdvMenuStyler; + FDropDownMenu.Popup(pt.X,pt.Y); + SetDroppedDown(False); + //FMenuSel := false; + + GetCursorPos(pt); + pt := ScreenToClient(pt); + if not PtInRect(ClientRect, pt) then + begin + FMouseEnter := false; + FMouseInControl := false; + FHot := false; + FInButton := false; + end; + Repaint; + end; + + Invalidate; + + Exit; + end + else + begin + if (Style = bsCheck) then + SetDown(not FDownChecked); + + if not FDownChecked then + begin + FState := absDown; + Invalidate; + end; + + if (Style = bsCheck) then + begin + FState := absDown; + Repaint; + end; + + FDragging := True; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.InternalClick; +begin + if (not FDropDownButton and IsMenuButton) or (FDropDownButton and not ((Style = bsCheck) or (GroupIndex > 0)) and + (not DropDownSplit)) then + begin + + end + else + begin + if Style = bsCheck then + SetDown(not FDownChecked); + + if not FDownChecked then + begin + FState := absDown; + Invalidate; + end; + + if (Style = bsCheck) then + begin + FState := absDown; + Repaint; + end; + end; + + Click; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.WMLDblClk(var Msg: TWMLButtonDblClk); +begin + inherited; +end; + +procedure TAdvCustomGlowButton.WMPaint(var Msg: TWMPaint); +var + DC, MemDC: HDC; + MemBitmap, OldBitmap: HBITMAP; + PS: TPaintStruct; +begin + if not FDoubleBuffered or (Msg.DC <> 0) then + begin + if not (csCustomPaint in ControlState) and (ControlCount = 0) then + inherited + else + PaintHandler(Msg); + end + else + begin + DC := GetDC(0); + MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom); + ReleaseDC(0, DC); + MemDC := CreateCompatibleDC(0); + OldBitmap := SelectObject(MemDC, MemBitmap); + try + DC := BeginPaint(Handle, PS); + Perform(WM_ERASEBKGND, MemDC, MemDC); + Msg.DC := MemDC; + WMPaint(Msg); + Msg.DC := 0; + BitBlt(DC, 0, 0, ClientRect.Right, ClientRect.Bottom, MemDC, 0, 0, SRCCOPY); + EndPaint(Handle, PS); + finally + SelectObject(MemDC, OldBitmap); + DeleteDC(MemDC); + DeleteObject(MemBitmap); + end; + end; +end; + +(* +begin + {$IFDEF VER185} + if TForm(FParentForm).FormStyle = fsMDIChild then + begin + DoubleBuffered := (Application.MainForm.ActiveMDIChild = FParentForm); + end + else + DoubleBuffered := (FParentForm.Handle = GetActiveWindow); + {$ENDIF} + inherited; +*) + + +//------------------------------------------------------------------------------ +procedure TAdvCustomGlowButton.WMLButtonUp(var Msg:TWMLButtonDown); +var + DoClick: Boolean; + +begin + FTimeInc := -20; + GlowState := gsPush; + + FMouseDown := false; + FLeftDown := false; + + if not Assigned(FTimer) then + begin + FTimer := TTimer.Create(self); + FTimer.OnTimer := TimerProc; + FTimer.Interval := GlowSpeed; + FTimer.Enabled := true; + end; + + if not DropDownButton and IsMenuButton then + begin + // do nothing + end + else + if FDragging then + begin + FDragging := False; + + DoClick := (Msg.XPos >= 0) and (Msg.XPos < ClientWidth) and (Msg.YPos >= 0) and (Msg.YPos <= ClientHeight); + + if (FGroupIndex = 0) then + begin + // Redraw face in-case mouse is captured + FState := absUp; + FMouseInControl := False; + //FHot := false; + + if (Style = bsCheck) then + begin + if Assigned(Action) then + begin + inherited; + if (FCheckLinked or FGroupIndexLinked) then + Exit; + end; + + // ***** extension for toolbar compactbutton handling + if not DoClick and Self.Down then + begin + Self.Down := not Self.Down; + end; + + if (Style <> bsCheck) then + SetDown(not FDownChecked); + + //FState := absUp; + Repaint; + end; + if DoClick and not (FState in [absExclusive, absDown]) then + Invalidate; + end + else + begin + if Assigned(Action) then + if FCheckLinked or FGroupIndexLinked then + begin + inherited; + Exit; + end; + + if DoClick then + begin + SetDown(not FDownChecked); + if FDownChecked then + Repaint; + end + else + begin + if FDownChecked then + FState := absExclusive; + Repaint; + end; + + end; + + //if DoClick then + // Click; + + UpdateTracking; + end; + + ControlState := ControlState + [csClicked]; + + inherited; + + if (Style = bsCheck) or (GroupIndex > 0) then + begin + //FState := absUp; + Repaint; + //FHot := true; + //FMouseInControl := true; + end; + + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.Notification(AComponent: TComponent; + AOperation: TOperation); +begin + inherited; + if (AOperation = opRemove) and (AComponent = FImages) then + FImages := nil; + + if (AOperation = opRemove) and (AComponent = FDisabledImages) then + FDisabledImages := nil; + + if (AOperation = opRemove) and (AComponent = FHotImages) then + begin + FHotImages := nil; + end; + + if (AOperation = opRemove) and (AComponent = DropdownMenu) then + DropdownMenu := nil; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.DrawGlyphCaption; +begin + +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.GetToolImage(bmp: TBitmap); +begin + +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDroppedDown(Value: Boolean); +begin + FDroppedDown := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.Paint; +var + GradColor: TColor; + GradColorTo: TColor; + GradColorMirror: TColor; + GradColorMirrorTo: TColor; + PenColor: TColor; + GradB, GradU: TGDIPGradient; + DrawDwLn: Boolean; + ImgList: TImageList; + Pic: TGDIPPicture; + EnabledImg: Boolean; + Rgn1, Rgn2: HRGN; + R: TRect; + i, w, h: Integer; + p: TPoint; + DCaption: string; + DWideCaption: widestring; + BD: TButtonDisplay; + DrawFocused, DrawFocusedHot: boolean; + bmp: TBitmap; + sz: TSize; + gs: TGlowButtonState; + PicSize: TSize; + AFont: TFont; + +begin + if FTransparent and not FMouseEnter then + begin + // TRANSPARENCY CODE + + R := ClientRect; + rgn1 := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom); + SelectClipRgn(Canvas.Handle, rgn1); + + i := SaveDC(Canvas.Handle); + p := ClientOrigin; + Windows.ScreenToClient(Parent.Handle, p); + p.x := -p.x; + p.y := -p.y; + MoveWindowOrg(Canvas.Handle, p.x, p.y); + + SendMessage(Parent.Handle, WM_ERASEBKGND, Canvas.Handle, 0); + // transparency ? + SendMessage(Parent.Handle, WM_PAINT, Canvas.Handle, 0); + + if (Parent is TWinCtrl) then + (Parent as TWinCtrl).PaintCtrls(Canvas.Handle, nil); + + RestoreDC(Canvas.Handle, i); + + SelectClipRgn(Canvas.Handle, 0); + DeleteObject(rgn1); + end; + + if not Enabled then + begin + FState := absDisabled; + FDragging := False; + end + else + begin + if (FState = absDisabled) then + if FDownChecked and (GroupIndex <> 0) then + FState := absExclusive + else + FState := absUp; + end; + + + if (Style = bsCheck) and (Down) then + begin + FState := absDown; + end; + + with Appearance do + begin + DrawDwLn := False; + if ((State = absDisabled) or not Enabled) and FShowDisabled then + begin + if (1>0) {Transparent} then + begin + GradColor := FColorDisabled; + GradColorTo := FColorDisabledTo; + GradColorMirror := FColorMirrorDisabled; + GradColorMirrorTo := FColorMirrorDisabledTo; + PenColor := BorderColorDisabled; + GradU := GradientDisabled; + GradB := GradientMirrorDisabled; + end + else + begin + end; + end + else if ((State = absDown) {or (FHot and (State = absExclusive))}{ or FDown}) and not ((Style = bsCheck) and (State = absDown)) then + begin + GradColor := FColorDown; + GradColorTo := FColorDownTo; + GradColorMirror := FColorMirrorDown; + GradColorMirrorTo := FColorMirrorDownTo; + PenColor := BorderColorDown; + GradU := GradientDown; + GradB := GradientMirrorDown; + DrawDwLn := True; + end + else + if (State = absExclusive) or ((Style = bsCheck) and (State = absDown)) then + begin + GradColor := FColorChecked; + GradColorTo := FColorCheckedTo; + GradColorMirror := FColorMirrorChecked; + GradColorMirrorTo := FColorMirrorCheckedTo; + PenColor := BorderColorChecked; + GradU := GradientChecked; + GradB := GradientMirrorChecked; + + if Assigned(FTimer) and not (not FMouseInControl and ((Style = bsCheck) or ((GroupIndex > 0) and (State <> absDown)))) then + begin + GradColor := BlendColor(FColorChecked, FColorDown, FStepPush); + GradColorTo := BlendColor(FColorCheckedTo, FColorDownTo, FStepPush); + GradColorMirror := BlendColor(FColorMirrorChecked, FColorMirrorDown, FStepPush); + GradColorMirrorTo := BlendColor(FColorMirrorCheckedTo, FColorMirrorDownTo, FStepPush); + //PenColor := BlendColor(BorderColorChecked, BorderColorDown, FStepPush); + end; + + end + else //if State = absUp then + begin + if FHot then + begin + GradColor := FColorHot; + GradColorTo := FColorHotTo; + GradColorMirror := FColorMirrorHot; + GradColorMirrorTo := FColorMirrorHotTo; + PenColor := BorderColorHot; + GradU := GradientHot; + GradB := GradientMirrorHot; + DrawDwLn := True; + end + else // Normal draw + begin + if (1>0) {Transparent} then + begin + GradColor := FColor; + GradColorTo := FColorTo; + GradColorMirror := FColorMirror; + GradColorMirrorTo := FColorMirrorTo; + PenColor := BorderColor; + GradU := Gradient; + GradB := GradientMirror; + end + else + begin + end; + end; + end; + + { if FHot then + begin + GradColor := FColorHot; + GradColorTo := FColorHotTo; + GradColorMirror := FColorMirrorHot; + GradColorMirrorTo := FColorMirrorHotTo; + PenColor := BorderColorHot; + GradU := GradientHot; + GradB := GradientMirrorHot; + end + else + begin + GradColor := FColor; + GradColorTo := FColorTo; + GradColorMirror := FColorMirror; + GradColorMirrorTo := FColorMirrorTo; + PenColor := BorderColor; + GradU := Gradient; + GradB := GradientMirror; + end; + + if FDown then + begin + PenColor := BorderColorDown; + GradU := GradientDown; + GradB := GradientMirrorDown; + end; + } + + if Assigned(FTimer) then + begin + if not FDown and not Transparent and not ((State = absExclusive) or ((Style = bsCheck) and (State = absDown))) then + begin + GradColor := BlendColor(FColorHot, FColor, FStepHover); + GradColorTo := BlendColor(FColorHotTo, FColorTo, FStepHover); + GradColorMirror := BlendColor(FColorMirrorHot, FColorMirror, FStepHover); + GradColorMirrorTo := BlendColor(FColorMirrorHotTo, FColorMirrorTo, FStepHover); + PenColor := BlendColor(BorderColorHot, BorderColor, FStepHover); + end + else + begin + if (Style = bsCheck) then + begin + if FDown then + begin + GradColor := BlendColor(FColorDown, FColorChecked, FStepPush); + GradColorTo := BlendColor(FColorDownTo, FColorCheckedTo, FStepPush); + GradColorMirror := BlendColor(FColorMirrorDown, FColorMirrorChecked, FStepPush); + GradColorMirrorTo := BlendColor(FColorMirrorDownTo, FColorMirrorCheckedTo, FStepPush); +// PenColor := BlendColor(BorderColorDown, BorderColorChecked, FStepPush); + end + end + else + if FDown and (State <> absExclusive) then + begin + + GradColor := BlendColor(FColorDown, FColorHot, FStepPush); + GradColorTo := BlendColor(FColorDownTo, FColorHotTo, FStepPush); + GradColorMirror := BlendColor(FColorMirrorDown, FColorMirrorHot, FStepPush); + GradColorMirrorTo := BlendColor(FColorMirrorDownTo, FColorMirrorHotTo, FStepPush); + PenColor := BlendColor(BorderColorDown, BorderColorHot, FStepPush); + end; + + end; + end; + + if Enabled or (DisabledImages = nil) then + begin + if FHot and (HotImages <> nil) then + ImgList := HotImages + else + ImgList := Images; + + EnabledImg := Enabled; + end + else + begin + ImgList := DisabledImages; + EnabledImg := True; + end; + + if Enabled or DisabledPicture.Empty then + begin + if FHot and not HotPicture.Empty then + Pic := HotPicture + else + Pic := Picture; + end + else + Pic := DisabledPicture; + + + if (ImgList = nil) then + begin + ImgList := FInternalImages; + EnabledImg := True; + end; + + if ShowCaption then + begin + DCaption := Caption; + DWideCaption := WideCaption; + end + else + begin + DCaption := ''; + DWideCaption := ''; + end; + + if (FMouseInControl or FMouseDown) and DropDownButton then + begin + if FInButton then + BD := bdDropDown + else + BD := bdButton; + end + else + BD := bdNone; + + // do not use special border color for non standalone buttons in mouse hover/down state or checked buttons + if ((Position <> bpStandalone) and FMouseDown) {or ((Style = bsCheck) and (FState = absDown))} then + begin + PenColor := BorderColor; + end; + + if ((State = absDisabled) or not Enabled) and FShowDisabled then + begin + GradColor := FColorDisabled; + GradColorTo := FColorDisabledTo; + GradColorMirror := FColorMirrorDisabled; + GradColorMirrorTo := FColorMirrorDisabledTo; + PenColor := BorderColorDisabled; + GradU := GradientDisabled; + GradB := GradientMirrorDisabled; + end; + + if ((GetFocus = self.Handle) and (FocusType in [ftHot, ftHotBorder])) and not FDown then + begin + GradColor := FColorHot; + GradColorTo := FColorHotTo; + GradColorMirror := FColorMirrorHot; + GradColorMirrorTo := FColorMirrorHotTo; + PenColor := BorderColorHot; + GradU := GradientHot; + GradB := GradientMirrorHot; + DrawDwLn := True; + end; + + DrawFocused := (GetFocus = self.Handle) and (FocusType in [ftBorder, ftHotBorder]); + DrawFocusedHot := (GetFocus = self.Handle) and (FocusType in [ftHot, ftHotBorder]); + + AFont := TFont.Create; + AFont.Assign(Font); + + if (not ParentFont) and Appearance.SystemFont then + begin + if IsVista then + AFont.Name := 'Segoe UI' + else + AFont.Name := 'Tahoma'; + end; + + bmp := TBitmap.Create; + bmp.Width := 1; + bmp.Height := 1; + + GetToolImage(bmp); + + if Assigned(Action) then + begin + begin + if (Action as TCustomAction).ImageIndex >= 0 then + if Assigned((Action as TCustomAction).ActionList) then + if Assigned(TImageList((Action as TCustomAction).ActionList.Images)) then + begin + ImgList := TImageList((Action as TCustomAction).ActionList.Images); + EnabledImg := Enabled; + end; + end; + end; + + PicSize.cx := 0; // no stretch pic + PicSize.cy := 0; + if AutoSize then + begin + if (ButtonSizeState in [bsLabel, bsGlyph]) then + begin + PicSize.cx := 16; + PicSize.cy := 16; + + {if (bmp.Width = 1) then + begin + bmp.Height := Pic.Height; + bmp.Width := Pic.Width; + bmp.Canvas.Draw(0, 0, Pic); + Pic := nil; + end;} + + if Assigned(ImgList) and (ImageIndex >= 0) then + begin + Pic := nil; + end; + end; + + if (ButtonSizeState = bsGlyph) then + begin + DCaption := ''; + DWideCaption := ''; + end; + end; + + if DoAutoSize or (FFirstPaint and AutoSize) then + begin + + sz := DrawVistaButton(Canvas,ClientRect,GradColor, GradColorTo, GradColorMirror, GradColorMirrorTo, + PenColor, GradU, GradB, DCaption, DWideCaption, FDefaultCaptionDrawing, AFont, ImgList, ImageIndex, EnabledImg, Layout, FDropDownButton {and (Style <> bsCheck)}, + DrawDwLn, Enabled, DrawFocused, DropDownPosition, Pic, PicSize, AntiAlias, FDefaultPicDrawing, bmp, BD, Transparent and not (FMouseEnter or DrawFocusedHot or (State = absDown)), FMouseEnter, Position, DropDownSplit, CanDrawBorder, + FOverlappedText, FWordWrap, True, FRounded, FDropDownDirection = ddDown, FSpacing, FTrimming, FNotes, FNotesFont, FDownChecked); + + if AutoSize then + begin + W := sz.cx + Spacing * 3 + 2 + 2 * MarginHorz; + H := sz.cy + Spacing * 2 + 2 * MarginVert; + + if DropDownButton then + begin + if (DropDownPosition = dpBottom) then + H := H + DropDownSectWidth + else + W := W + DropDownSectWidth; + end; + + if Assigned(FOnSetButtonSize) then + FOnSetButtonSize(Self, w, h); + + if (W <> Width) then + Width := W; + if (H <> Height) then + Height := H; + end; + + FFirstPaint := false; + end; + + // transparent border pixels + + sz := DrawVistaButton(Canvas,ClientRect,GradColor, GradColorTo, GradColorMirror, GradColorMirrorTo, + PenColor, GradU, GradB, DCaption, DWideCaption, FDefaultCaptionDrawing, AFont, ImgList, ImageIndex, EnabledImg, Layout, FDropDownButton {and (Style <> bsCheck)}, + DrawDwLn, Enabled, DrawFocused, DropDownPosition, Pic, PicSize, AntiAlias, FDefaultPicDrawing, bmp, BD, Transparent and not (FMouseEnter or DrawFocusedHot or (State = absDown)), FMouseEnter, Position, DropDownSplit, CanDrawBorder, FOverlappedText, FWordWrap, + False, FRounded, FDropDownDirection = ddDown, FSpacing, FTrimming, FNotes, FNotesFont, FDownChecked); + + DrawGlyphCaption; + + gs := gsNormal; + + if FMouseEnter then + gs := gsHot; + + if State = absDown then + gs := gsDown; + + if Assigned(OnDrawButton) then + OnDrawButton(Self, Canvas, ClientRect, gs); + + AFont.Free; + bmp.Free; + + if not Assigned(Parent) then + Exit; + + if not FTransparent or FMouseEnter or (State = absDown) or (FHot) then + begin + R := ClientRect; + + if Position <> bpMiddle then + begin + if (Position in [bpStandalone, bpLeft]) then + begin + rgn1 := CreateRectRgn(0, 0, 1, 1); + end + else + begin + rgn1 := CreateRectRgn(R.Right - 1, 0, R.Right, 1); + end; + + if (Position in [bpStandalone]) then + begin + rgn2 := CreateRectRgn(R.Right - 1, 0, R.Right, 1); + CombineRgn(rgn1, rgn1, rgn2, RGN_OR); + DeleteObject(rgn2); + end; + + if (Position in [bpStandalone, bpLeft]) then + begin + rgn2 := CreateRectRgn(0, R.Bottom - 1, 1, R.Bottom); + CombineRgn(rgn1, rgn1, rgn2, RGN_OR); + DeleteObject(rgn2); + end; + + if (Position in [bpStandalone, bpRight]) then + begin + rgn2 := CreateRectRgn(R.Right - 1, R.Bottom - 1, R.Right, R.Bottom); + CombineRgn(rgn1, rgn1, rgn2, RGN_OR); + DeleteObject(rgn2); + end; + + SelectClipRgn(Canvas.Handle, rgn1); + + i := SaveDC(Canvas.Handle); + p := ClientOrigin; + Windows.ScreenToClient(Parent.Handle, p); + p.x := -p.x; + p.y := -p.y; + MoveWindowOrg(Canvas.Handle, p.x, p.y); + + SendMessage(Parent.Handle, WM_ERASEBKGND, Canvas.Handle, 0); + + // transparency ? + SendMessage(Parent.Handle, WM_PAINT, Canvas.Handle, 0); + if (Parent is TWinCtrl) then + (Parent as TWinCtrl).PaintCtrls(Canvas.Handle, nil); + RestoreDC(Canvas.Handle, i); + + SelectClipRgn(Canvas.Handle, 0); + DeleteObject(rgn1); + end; + end; + end; +end; + +procedure TAdvCustomGlowButton.PictureChanged(Sender: TObject); +begin + PerformResize; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDown(Value: Boolean); +begin + + if (csLoading in ComponentState) then + FInitialDown := Value; + + if (FGroupIndex = 0) and (Style = bsButton) then + Value := False; + + if (Style = bsCheck) then + begin + FDownChecked := Value; + if FDownChecked then + FState := absDown + else + FState := absUp; + Repaint; + Exit; + end; + + if (Value <> FDownChecked) then + begin + if FDownChecked and (not FAllowAllUp) then + Exit; + + FDownChecked := Value; + if Value then + begin + if FState = absUp then Invalidate; + FState := absExclusive + end + else + begin + FState := absUp; + Repaint; + end; + + if Value and not FCheckLinked then UpdateExclusive; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetGroupIndex(const Value: Integer); +begin + if FGroupIndex <> Value then + begin + FGroupIndex := Value; + UpdateExclusive; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetImageIndex(const Value: TImageIndex); +begin + FImageIndex := Value; + PerformResize; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetImages(const Value: TImageList); +begin + FImages := Value; + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDefault(const Value: boolean); +begin + FDefault := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDisabledImages(const Value: TImageList); +begin + FDisabledImages := Value; + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetSpacing(const Value: Integer); +begin + if FSpacing <> Value then + begin + FSpacing := value; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + + +procedure TAdvCustomGlowButton.SetWideCaption(const Value: widestring); +begin + if (FWideCaption <> Value) then + begin + FWideCaption := Value; + + if AutoSize then + begin + DoAutoSize := true; + Repaint; + DoAutoSize := false; + end + else + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetWordWrap(const Value: Boolean); +begin + if FWordWrap <> Value then + begin + FWordWrap := Value; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.PerformResize; +begin + if AutoSize then + begin + DoAutoSize := true; + Repaint; + DoAutoSize := false; + end + else + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetRounded(const Value: Boolean); +begin + if (FRounded <> Value) then + begin + FRounded := Value; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetMarginVert(const Value: Integer); +begin + if FMarginVert <> Value then + begin + FMarginVert := Value; + PerformResize; + end; +end; + +procedure TAdvCustomGlowButton.SetMarginHorz(const Value: Integer); +begin + if FMarginHorz <> Value then + begin + FMarginHorz := Value; + PerformResize; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetAutoSizeEx(const Value: Boolean); +begin + if FAutoSize <> Value then + begin + FAutoSize := Value; + PerformResize; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDisabledPicture(const Value: TGDIPPicture); +begin + FIDisabledPicture.Assign(Value); + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetHotPicture(const Value: TGDIPPicture); +begin + FIHotPicture.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetShowCaption(const Value: Boolean); +begin + FShowCaption := Value; + PerformResize; + Invalidate; +end; + +procedure TAdvCustomGlowButton.SetShowDisabled(const Value: boolean); +begin + FShowDisabled := Value; + Invalidate; +end; + +procedure TAdvCustomGlowButton.SetStyle(const Value: TAdvButtonStyle); +begin + if FStyle <> Value then + begin + FStyle := Value; + //if (Value = bsCheck) and DropDownButton then + // DropDownButton := false; + end; +end; + +procedure TAdvCustomGlowButton.SetVersion(const Value: string); +begin + +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.TimerProc(Sender: TObject); +begin + case GlowState of + gsHover: + begin + FStepHover := FStepHover + FTimeInc; + if ((FStepHover > 100) and (FTimeInc > 0)) + or ((FStepHover < 0) and (FTimeInc < 0)) then + begin + // outputdebugstring(pchar('hover step:'+inttostr(fstephover)+':'+inttostr(ftimeinc))); + if FStepHover > 100 then + FStepHover := 100; + + if FStepHover < 0then + FStepHover := 0; + + GlowState := gsNone; + + FreeAndNil(FTimer); + end + else + Invalidate; + end; + gsPush: + begin + // outputdebugstring(pchar('push step:'+inttostr(fsteppush)+':'+inttostr(ftimeinc))); + + FStepPush := FStepPush + FTimeInc; + + if ((FStepPush > 100) and (FTimeInc > 0)) + or ((FStepPush < 0) and (FTimeInc < 0)) then + begin + if FStepPush > 100 then + FStepPush := 100; + + if FStepPush < 0 then + FStepPush := 0; + + if FTimeInc < 0 then + begin + FDown := false; + FLeftDown := false; + end; + + GlowState := gsNone; + FreeAndNil(FTimer); + end + else + Invalidate; + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.WMSetText(var Message: TWMSetText); +begin + inherited; + + if AutoSize then + begin + PerformResize; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.WMEraseBkGnd(var Message: TWMEraseBkGnd); +const + delta = 3; +{ +var + DC: HDC; + i: THandle; +// rgn1,rgn2: THandle; + p,op: TPoint; + PDC : HDC; +} + +begin + // SetBkMode(Message.DC, Windows.TRANSPARENT ); + Message.Result := 1; + Exit; + + if FTransparent then + begin + if Assigned(Parent) and not (FMouseDown or FMouseInControl) then + begin + { + rgn1 := CreateRectRgn(0, 0, delta, delta); + rgn2 := CreateRectRgn(ClientRect.Right-delta, 0, ClientRect.Right, delta); + CombineRgn(rgn1, rgn1, rgn2, RGN_OR); + rgn2 := CreateRectRgn(0, ClientRect.Bottom - delta, delta, ClientRect.Bottom); + CombineRgn(rgn1, rgn1, rgn2, RGN_OR); + rgn2 := CreateRectRgn(ClientRect.Right - delta, ClientRect.Bottom - delta, ClientRect.Right, ClientRect.Bottom); + CombineRgn(rgn1, rgn1, rgn2, RGN_OR); + SelectClipRgn(Message.DC, rgn1); + } + + (* + DC := Message.DC; + i := SaveDC(DC); + + p := ClientOrigin; + Windows.ScreenToClient(Parent.Handle, p); + p.x := -p.x; + p.y := -p.y; + +// MoveWindowOrg(DC, p.x, p.y); + +// SetMapMode(FBmp.Canvas.Handle,mm_isotropic); + + SetMapMode(FBmp.Canvas.Handle,mm_isotropic); + SetViewPortOrgEx(FBmp.Canvas.Handle,p.x,p.y,@op); + + SendMessage(Parent.Handle, WM_ERASEBKGND, FBmp.Canvas.Handle, 0); + SendMessage(Parent.Handle, WM_PAINT, FBmp.Canvas.Handle, 0); + +// if (Parent is TWinCtrl) then +// (Parent as TWinCtrl).PaintCtrls(FBmp.Canvas.Handle, nil); + + SetViewPortOrgEx(FBmp.Canvas.Handle,op.x,op.y,nil); + RestoreDC(DC, i); + + // SelectClipRgn(Message.DC, 0); + // DeleteObject(rgn1); + *) + end; + end + else + inherited; +end; + + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsAccel(CharCode, Caption) and CanFocus then + begin + if IsMenuButton or (Assigned(DropDownMenu)) then + DoDropDown + else + Click; + Result := 1; + end + else + inherited; +end; + +procedure TAdvCustomGlowButton.CMDialogKey(var Message: TCMDialogKey); +begin + with Message do + if + (((CharCode = VK_RETURN) and FActive) or + ((CharCode = VK_ESCAPE) and FCancel)) and + (KeyDataToShiftState(Message.KeyData) = []) and CanFocus then + begin + //Click; + InternalClick; + Result := 1; + end + else + inherited; +end; + +procedure TAdvCustomGlowButton.CMEnabledChanged(var Message: TMessage); +begin + inherited; + Invalidate; +end; + +procedure TAdvCustomGlowButton.CMFocusChanged(var Message: TCMFocusChanged); +begin + with Message do + if Sender is TAdvCustomGlowButton then + FActive := Sender = Self + else + FActive := FDefault; + //SetButtonStyle(FActive); + inherited; +end; + +//------------------------------------------------------------------------------ + +{$IFNDEF TMSDOTNET} + +procedure TAdvCustomGlowButton.CMButtonPressed(var Message: TMessage); +var + Sender: TAdvGlowButton; +begin + if Message.WParam = FGroupIndex then + begin + Sender := TAdvGlowButton(Message.LParam); + if Sender <> Self then + begin + if Sender.Down and FDownChecked then + begin + FDownChecked := False; + FState := absUp; + { if (Action is TCustomAction) then + TCustomAction(Action).Checked := False; } + Invalidate; + end; + //FAllowAllUp := Sender.AllowAllUp; + end; + end; +end; +{$ENDIF} + +//------------------------------------------------------------------------------ + +{$IFNDEF TMSDOTNET} + +procedure TAdvCustomGlowButton.UpdateExclusive; +var + Msg: TMessage; +begin + if (FGroupIndex <> 0) and (Parent <> nil) then + begin + Msg.Msg := CM_BUTTONPRESSED; + Msg.WParam := FGroupIndex; + Msg.LParam := Longint(Self); + Msg.Result := 0; + Parent.Broadcast(Msg); + {if Assigned(FAdvToolBar) and not (Parent is TAdvCustomToolBar) then + FAdvToolBar.Broadcast(Msg) + else if Assigned(AdvToolBar) and (Parent is TAdvCustomToolBar) and Assigned(AdvToolBar.FOptionWindowPanel) then + FAdvToolBar.FOptionWindowPanel.Broadcast(Msg); } + end; +end; +{$ENDIF} + +//------------------------------------------------------------------------------ + +{$IFDEF TMSDOTNET} +procedure TAdvCustomGlowButton.ButtonPressed(Group: Integer; Button: TAdvGlowButton); +begin + if (Group = FGroupIndex) and (Button <> Self) then + begin + if Button.Down and FDownChecked then + begin + FDownChecked := False; + FState := absUp; + if (Action is TCustomAction) then + TCustomAction(Action).Checked := False; + Invalidate; + end; + //FAllowAllUp := Button.AllowAllUp; + end; +end; + +procedure TAdvCustomGlowButton.UpdateExclusive; +var + I: Integer; +begin + if (FGroupIndex <> 0) and (Parent <> nil) then + begin + for I := 0 to Parent.ControlCount - 1 do + if Parent.Controls[I] is TSpeedButton then + TAdvToolButton(Parent.Controls[I]).ButtonPressed(FGroupIndex, Self); + end; +end; +{$ENDIF} + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.UpdateTracking; +var + P: TPoint; + FNewMouseInControl: boolean; +begin + //if FFlat then + begin + if Enabled then + begin + GetCursorPos(P); + + FNewMouseInControl := not (FindDragTarget(P, True) = Self); + + if FNewMouseInControl <> FMouseInControl then + begin + FMouseInControl := FNewMouseInControl; + if FMouseInControl then + Perform(CM_MOUSELEAVE, 0, 0) + else + Perform(CM_MOUSEENTER, 0, 0); + end; + end; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetAllowAllUp(const Value: Boolean); +begin + if FAllowAllUp <> Value then + begin + FAllowAllUp := Value; + UpdateExclusive; + end; +end; + +procedure TAdvCustomGlowButton.SetAntiAlias(const Value: TAntiAlias); +begin + if (FAntiAlias <> Value) then + begin + FAntiAlias := Value; + Invalidate; + end; +end; + +procedure TAdvCustomGlowButton.SetTrimming(const Value: TStringTrimming); +begin + if (FTrimming <> Value) then + begin + FTrimming := Value; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.MouseMove(Shift: TShiftState; X, Y: Integer); +var + NewState: TAdvButtonState; + FOldInButton: Boolean; +begin + inherited; + + if (csDesigning in ComponentState) then + Exit; + + {$IFNDEF DELPHI2006_LVL} + UpdateTracking; + {$ENDIF} + + FOldInButton := FInButton; + FInButton := false; + + if DropDownButton then + begin + case DropDownPosition of + dpRight: if X > Width - 12 then FInButton := true; + dpBottom: if Y > Height - 12 then FInButton := true; + end; + end; + + if (FInButton <> FOldInButton) then + begin + Invalidate; + end; + + if FDragging then + begin + if (not FDownChecked) then NewState := absUp + else NewState := absExclusive; + + if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then + if FDownChecked then NewState := absExclusive else NewState := absDown; + + if (Style = bsCheck) and FDownChecked then + begin + NewState := absDown; + end; + + if (NewState <> FState) then + begin + FState := NewState; + Invalidate; + end; + end + else + if not FMouseInControl then + UpdateTracking; + +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetLayout(const Value: TButtonLayout); +begin + FLayout := Value; + Invalidate; +end; + +procedure TAdvCustomGlowButton.SetOfficeHint(const Value: TAdvHintInfo); +begin + FOfficeHint.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetPicture(const Value: TGDIPPicture); +begin + FIPicture.Assign(Value); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetTransparent(const Value: Boolean); +begin + FTransparent := Value; +// ReCreateWnd; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDropDownButton(const Value: Boolean); +begin + if FDropDownButton <> Value then + begin + //if (Value and not (Style = bsCheck)) or not Value then + FDropDownButton := Value; + AdjustSize; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDropDownDirection(const Value: TDropDownDirection); +begin + if FDropDownDirection <> Value then + begin + //if (Value and not (Style = bsCheck)) or not Value then + FDropDownDirection := Value; + Invalidate; + end; +end; + + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.PopupBtnDown; +begin + if Assigned(FOnDropDown) then + FOnDropDown(self); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetDropDownPosition( + const Value: TDropDownPosition); +begin + if FDropDownPosition <> Value then + begin + FDropDownPosition := Value; + if FDropDownButton then + AdjustSize; + Invalidate; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.OnAppearanceChanged(Sender: TObject); +begin + Invalidate; + if Assigned(FShortCutHint) then + begin + FShortCutHint.Color := clWhite; + FShortCutHint.ColorTo := Appearance.Color; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetAppearance( + const Value: TGlowButtonAppearance); +begin + FAppearance.Assign(Value); + if Assigned(FShortCutHint) then + begin + FShortCutHint.Color := clWhite; + FShortCutHint.ColorTo := Appearance.Color; + end; +end; + +procedure TAdvCustomGlowButton.SetBorderStyle(const Value: TBorderStyle); +begin + FBorderStyle := Value; + Invalidate; +end; + +procedure TAdvCustomGlowButton.SetButtonPosition(const Value: TButtonPosition); +begin + FButtonPosition := Value; + Invalidate; +end; + +procedure TAdvCustomGlowButton.SetComponentStyle(AStyle: TTMSStyle); +begin + if (Astyle in [tsOffice2003Blue, tsOffice2003Silver, tsOffice2003Olive, tsWhidbey]) then + begin + Appearance.ColorHot := $EBFDFF; + Appearance.ColorHotTo := $ACECFF; + Appearance.ColorMirrorHot := $59DAFF; + Appearance.ColorMirrorHotTo := $A4E9FF; + Appearance.BorderColorHot := $99CEDB; + Appearance.GradientHot := ggVertical; + Appearance.GradientMirrorHot := ggVertical; + + Appearance.ColorDown := $76AFF1; + Appearance.ColorDownTo := $4190F3; + Appearance.ColorMirrorDown := $0E72F1; + Appearance.ColorMirrorDownTo := $4C9FFD; + Appearance.BorderColorDown := $45667B; + Appearance.GradientDown := ggVertical; + Appearance.GradientMirrorDown := ggVertical; + + Appearance.ColorChecked := $B5DBFB; + Appearance.ColorCheckedTo := $78C7FE; + Appearance.ColorMirrorChecked := $9FEBFD; + Appearance.ColorMirrorCheckedTo := $56B4FE; + Appearance.GradientChecked := ggVertical; + Appearance.GradientMirrorChecked := ggVertical; + + end; + + case AStyle of + tsOffice2003Blue: + begin + Appearance.Color := $EEDBC8; + Appearance.ColorTo := $F6DDC9; + Appearance.ColorMirror := $EDD4C0; + Appearance.ColorMirrorTo := $F7E1D0; + Appearance.BorderColor := $E0B99B; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + end; + tsOffice2003Olive: + begin + Appearance.Color := $CFF0EA; + Appearance.ColorTo := $CFF0EA; + Appearance.ColorMirror := $CFF0EA; + Appearance.ColorMirrorTo := $8CC0B1; + Appearance.BorderColor := $8CC0B1; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + end; + tsOffice2003Silver: + begin + Appearance.Color := $EDD4C0; + Appearance.ColorTo := $00E6D8D8; + Appearance.ColorMirror := $EDD4C0; + Appearance.ColorMirrorTo := $C8B2B3; + Appearance.BorderColor := $927476; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + end; + tsOffice2003Classic: + begin + Appearance.Color := clWhite; + Appearance.ColorTo := $C9D1D5; + Appearance.ColorMirror := clWhite; + Appearance.ColorMirrorTo := $C9D1D5; + Appearance.BorderColor := clBlack; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + + Appearance.ColorHot := $EBFDFF; + Appearance.ColorHotTo := $ACECFF; + Appearance.ColorMirrorHot := $59DAFF; + Appearance.ColorMirrorHotTo := $A4E9FF; + Appearance.BorderColorHot := $99CEDB; + Appearance.GradientHot := ggVertical; + Appearance.GradientMirrorHot := ggVertical; + + Appearance.ColorDown := $76AFF1; + Appearance.ColorDownTo := $4190F3; + Appearance.ColorMirrorDown := $0E72F1; + Appearance.ColorMirrorDownTo := $4C9FFD; + Appearance.BorderColorDown := $45667B; + Appearance.GradientDown := ggVertical; + Appearance.GradientMirrorDown := ggVertical; + + Appearance.ColorChecked := $B5DBFB; + Appearance.ColorCheckedTo := $78C7FE; + Appearance.ColorMirrorChecked := $9FEBFD; + Appearance.ColorMirrorCheckedTo := $56B4FE; + Appearance.GradientChecked := ggVertical; + Appearance.GradientMirrorChecked := ggVertical; + + end; + tsOffice2007Luna: + begin + Appearance.Color := $EEDBC8; + Appearance.ColorTo := $F6DDC9; + Appearance.ColorMirror := $EDD4C0; + Appearance.ColorMirrorTo := $F7E1D0; + Appearance.BorderColor := $E0B99B; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + + Appearance.ColorHot := $EBFDFF; + Appearance.ColorHotTo := $ACECFF; + Appearance.ColorMirrorHot := $59DAFF; + Appearance.ColorMirrorHotTo := $A4E9FF; + Appearance.BorderColorHot := $99CEDB; + Appearance.GradientHot := ggVertical; + Appearance.GradientMirrorHot := ggVertical; + + Appearance.ColorDown := $76AFF1; + Appearance.ColorDownTo := $4190F3; + Appearance.ColorMirrorDown := $0E72F1; + Appearance.ColorMirrorDownTo := $4C9FFD; + Appearance.BorderColorDown := $45667B; + Appearance.GradientDown := ggVertical; + Appearance.GradientMirrorDown := ggVertical; + + Appearance.ColorChecked := $B5DBFB; + Appearance.ColorCheckedTo := $78C7FE; + Appearance.ColorMirrorChecked := $9FEBFD; + Appearance.ColorMirrorCheckedTo := $56B4FE; + Appearance.BorderColorChecked := $45667B; + Appearance.GradientChecked := ggVertical; + Appearance.GradientMirrorChecked := ggVertical; + end; + tsOffice2007Obsidian: + begin + Appearance.Color := $DFDED6; + Appearance.ColorTo := $E4E2DB; + Appearance.ColorMirror := $D7D5CE; + Appearance.ColorMirrorTo := $E7E5E0; + Appearance.BorderColor := $C0BCB2; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + + Appearance.ColorHot := $EBFDFF; + Appearance.ColorHotTo := $ACECFF; + Appearance.ColorMirrorHot := $59DAFF; + Appearance.ColorMirrorHotTo := $A4E9FF; + Appearance.BorderColorHot := $99CEDB; + Appearance.GradientHot := ggVertical; + Appearance.GradientMirrorHot := ggVertical; + + Appearance.ColorDown := $76AFF1; + Appearance.ColorDownTo := $4190F3; + Appearance.ColorMirrorDown := $0E72F1; + Appearance.ColorMirrorDownTo := $4C9FFD; + Appearance.BorderColorDown := $45667B; + Appearance.GradientDown := ggVertical; + Appearance.GradientMirrorDown := ggVertical; + + Appearance.ColorChecked := $B5DBFB; + Appearance.ColorCheckedTo := $78C7FE; + Appearance.ColorMirrorChecked := $9FEBFD; + Appearance.ColorMirrorCheckedTo := $56B4FE; + Appearance.BorderColorChecked := $45667B; + Appearance.GradientChecked := ggVertical; + Appearance.GradientMirrorChecked := ggVertical; + + end; + tsOffice2007Silver: + begin + Appearance.Color := $F3F3F1; + Appearance.ColorTo := $F5F5F3; + Appearance.ColorMirror := $EEEAE7; + Appearance.ColorMirrorTo := $F8F7F6; + Appearance.BorderColor := $CCCAC9; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + + Appearance.ColorHot := $EBFDFF; + Appearance.ColorHotTo := $ACECFF; + Appearance.ColorMirrorHot := $59DAFF; + Appearance.ColorMirrorHotTo := $A4E9FF; + Appearance.BorderColorHot := $99CEDB; + Appearance.GradientHot := ggVertical; + Appearance.GradientMirrorHot := ggVertical; + + Appearance.ColorDown := $76AFF1; + Appearance.ColorDownTo := $4190F3; + Appearance.ColorMirrorDown := $0E72F1; + Appearance.ColorMirrorDownTo := $4C9FFD; + Appearance.BorderColorDown := $45667B; + Appearance.GradientDown := ggVertical; + Appearance.GradientMirrorDown := ggVertical; + + Appearance.ColorChecked := $B5DBFB; + Appearance.ColorCheckedTo := $78C7FE; + Appearance.ColorMirrorChecked := $9FEBFD; + Appearance.ColorMirrorCheckedTo := $56B4FE; + Appearance.BorderColorChecked := $45667B; + Appearance.GradientChecked := ggVertical; + Appearance.GradientMirrorChecked := ggVertical; + end; + tsWindowsXP: + begin + Appearance.Color := clWhite; + Appearance.ColorTo := $B9D8DC; + Appearance.ColorMirror := $B9D8DC; + Appearance.ColorMirrorTo := $B9D8DC; + Appearance.BorderColor := $B9D8DC; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + + Appearance.ColorHot := $EFD3C6; + Appearance.ColorHotTo := $EFD3C6; + Appearance.ColorMirrorHot := $EFD3C6; + Appearance.ColorMirrorHotTo := $EFD3C6; + Appearance.BorderColorHot := clHighlight; + Appearance.GradientHot := ggVertical; + Appearance.GradientMirrorHot := ggVertical; + + Appearance.ColorDown := $B59284; + Appearance.ColorDownTo := $B59284; + Appearance.ColorMirrorDown := $B59284; + Appearance.ColorMirrorDownTo := $B59284; + Appearance.BorderColorDown := clHighlight; + Appearance.GradientDown := ggVertical; + Appearance.GradientMirrorDown := ggVertical; + + + Appearance.ColorChecked := $B9D8DC; + Appearance.ColorCheckedTo := $B9D8DC; + Appearance.ColorMirrorChecked := $B9D8DC; + Appearance.ColorMirrorCheckedTo := $B9D8DC; + Appearance.BorderColorChecked := clBlack; + Appearance.GradientChecked := ggVertical; + Appearance.GradientMirrorChecked := ggVertical; + + end; + tsWhidbey: + begin + Appearance.Color := clWhite; + Appearance.ColorTo := $DFEDF0; + Appearance.ColorMirror := $DFEDF0; + Appearance.ColorMirrorTo := $DFEDF0; + Appearance.BorderColor := $99A8AC; + Appearance.Gradient := ggVertical; + Appearance.GradientMirror := ggVertical; + + end; + tsCustom: + begin + end; + end; + Invalidate; + + if Assigned(FShortCutHint) then + begin + FShortCutHint.Color := clWhite; + FShortCutHint.ColorTo := Appearance.Color; + end; + +end; + + +//------------------------------------------------------------------------------ + +//------------------------------------------------------------------------------ + +{$IFDEF DELPHI6_LVL} + +procedure TAdvCustomGlowButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + inherited ActionChange(Sender, CheckDefaults); + if Sender is TCustomAction then + with TCustomAction(Sender) do + begin + if CheckDefaults or (Self.GroupIndex = 0) then + Self.GroupIndex := GroupIndex; + Self.ImageIndex := ImageIndex; + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGlowButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TAdvGlowButtonActionLink; +end; +{$ENDIF} + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetButtonSizeState( + const Value: TButtonSizeState); +begin + if (FButtonSizeState <> Value) {and AutoSize} then + begin + if (FButtonSizeState = bsLarge) then + begin + FOldLayout := Layout; + FOldDropDownPosition := DropDownPosition; + end; + + FButtonSizeState := Value; + + if (FButtonSizeState = bsLarge) and AutoSize then + begin + Layout := FOldLayout; + DropDownPosition := FOldDropDownPosition; + end + else if AutoSize then + begin + Layout := blGlyphLeft; + DropDownPosition := dpRight; + end; + FFirstPaint := True; + Paint; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetMaxButtonSizeState( + const Value: TButtonSizeState); +begin + if (FMaxButtonSizeState <> Value) {and AutoSize} then + begin + FMaxButtonSizeState := Value; + ButtonSizeState := FMaxButtonSizeState + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGlowButton.GetNotes: TStrings; +begin + Result := TStrings(FNotes); +end; + + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetNotes(const Value: TStrings); +begin + FNotes.Assign(Value); + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetNotesFont(const Value: TFont); +begin + FNotesFont.Assign(Value); + Invalidate; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvCustomGlowButton.SetMinButtonSizeState( + const Value: TButtonSizeState); +begin + if (FMinButtonSizeState <> Value) then + begin + FMinButtonSizeState := Value; + if (FMinButtonSizeState > ButtonSizeState) then + ButtonSizeState := FMinButtonSizeState; + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvCustomGlowButton.GetButtonSize(BtnSizeState: TButtonSizeState): TSize; +var + DCaption: string; + DWideCaption: widestring; + ImgList: TImageList; + Pic: TGDIPPicture; + EnabledImg: Boolean; + BD: TButtonDisplay; + bmp: TBitmap; + DrawFocused, DrawFocusedHot, DrawDwLn: boolean; + PicSize: TSize; + LayOt: TButtonLayout; + DpDwPosition: TDropDownPosition; +begin + if Enabled or (DisabledImages = nil) then + begin + if FHot and (HotImages <> nil) then + ImgList := HotImages + else + ImgList := Images; + + EnabledImg := Enabled; + end + else + begin + ImgList := DisabledImages; + EnabledImg := True; + end; + + if Enabled or DisabledPicture.Empty then + begin + if FHot and not HotPicture.Empty then + Pic := HotPicture + else + Pic := Picture; + end + else + Pic := DisabledPicture; + + + if (ImgList = nil) then + begin + ImgList := FInternalImages; + EnabledImg := True; + end; + + if ShowCaption then + begin + DCaption := Caption; + DWideCaption := WideCaption; + end + else + begin + DCaption := ''; + DWideCaption := ''; + end; + + if (FMouseInControl or FMouseDown) and DropDownButton then + begin + if FInButton then + BD := bdDropDown + else + BD := bdButton; + end + else + BD := bdNone; + + DrawFocused := (GetFocus = self.Handle) and (FocusType in [ftBorder, ftHotBorder]); + DrawFocusedHot := (GetFocus = self.Handle) and (FocusType in [ftHot, ftHotBorder]); + + bmp := TBitmap.Create; + bmp.Width := 1; + bmp.Height := 1; + + GetToolImage(bmp); + + if Assigned(Action) then + begin + begin + if (Action as TCustomAction).ImageIndex >= 0 then + if Assigned((Action as TCustomAction).ActionList) then + if Assigned(TImageList((Action as TCustomAction).ActionList.Images)) then + begin + ImgList := TImageList((Action as TCustomAction).ActionList.Images); + EnabledImg := Enabled; + end; + end; + end; + + LayOt := Layout; + DpDwPosition := DropDownPosition; + + PicSize.cx := 0; // no stretch pic + PicSize.cy := 0; + if AutoSize then + begin + if (BtnSizeState in [bsLabel, bsGlyph]) then + begin + PicSize.cx := 16; + PicSize.cy := 16; + + if (bmp.Width = 1) then + begin + bmp.Height := Pic.Height; + bmp.Width := Pic.Width; + bmp.Canvas.Draw(0, 0, Pic); + Pic := nil; + end; + + if Assigned(ImgList) and (ImageIndex >= 0) then + begin + Pic := nil; + end; + end; + + if (BtnSizeState = bsGlyph) then + begin + DCaption := ''; + DWideCaption := ''; + end; + + if (BtnSizeState = bsLarge) then + begin + LayOt := FOldLayout; + DpDwPosition := FOldDropDownPosition; + end + else + begin + LayOt := blGlyphLeft; + DpDwPosition := dpRight; + end; + end; + + DrawDwLn := False; + + with Appearance do + Result := DrawVistaButton(Canvas,ClientRect,FColor, FColorTo, FColorMirror, FColorMirrorTo, + BorderColor, Gradient, GradientMirror, DCaption, DWideCaption, FDefaultCaptionDrawing, Font, ImgList, ImageIndex, EnabledImg, LayOt, FDropDownButton, + DrawDwLn, Enabled, DrawFocused, DpDwPosition, Pic, PicSize, AntiAlias, FDefaultPicDrawing, bmp, BD, Transparent and not (FMouseEnter or DrawFocusedHot or (State = absDown)), FMouseEnter, Position, DropDownSplit, CanDrawBorder, + FOverlappedText, FWordWrap, True, FRounded, FDropDownDirection = ddDown, FSpacing, FTrimming, FNotes, FNotesFont, FDownChecked); + + Result.cx := Result.cx + Spacing * 3 + 2 + 2 * MarginHorz; + Result.cy := Result.cy + Spacing * 2 + 2 * MarginVert; + if DropDownButton then + begin + if (DpDwPosition = dpBottom) then + Result.cy := Result.cy + DropDownSectWidth + else + Result.cx := Result.cx + DropDownSectWidth; + end; + //if Assigned(FOnSetButtonSize) then + //FOnSetButtonSize(Self, w, h); + + bmp.Free; +end; + +//------------------------------------------------------------------------------ + +{ TGlowButtonAppearance } + +constructor TGlowButtonAppearance.Create; +begin + inherited; + Color := clWhite; + ColorTo := clWhite; + ColorMirror := clSilver; + ColorMirrorTo := clWhite; + + ColorHot := $F5F0E1; + ColorHotTo := $F9D2B2; + ColorMirrorHot := $F5C8AD; + ColorMirrorHotTo := $FFF8F4; + + ColorDown := BrightnessColor($F5F0E1,-10,-10,0); + ColorDownTo := BrightnessColor($F9D2B2, -10,-10,0); + ColorMirrorDown := BrightnessColor($F5C8AD, -10,-10,0); + ColorMirrorDownTo := BrightnessColor($FFF8F4, -10,-10,0); + + ColorChecked := BrightnessColor($F5F0E1,-10,-10,0); + ColorCheckedTo := BrightnessColor($F9D2B2, -10,-10,0); + ColorMirrorChecked := BrightnessColor($F5C8AD, -10,-10,0); + ColorMirrorCheckedTo := BrightnessColor($FFF8F4, -10,-10,0); + + ColorDisabled := BrightnessColor(clWhite,-5,-5,-5); + ColorDisabledTo := BrightnessColor(clWhite, -5,-5,-5); + ColorMirrorDisabled := BrightnessColor(clSilver, -5,-5,-5); + ColorMirrorDisabledTo := BrightnessColor(clWhite, -5,-5,-5); + + BorderColor := clSilver; + BorderColorHot := clBlue; + BorderColorDown := clNavy; + BorderColorChecked := clBlue; + BorderColorDisabled := clGray; + + Gradient := ggVertical; + GradientMirror := ggVertical; + + GradientHot := ggRadial; + GradientMirrorHot := ggRadial; + + GradientDown := ggRadial; + GradientMirrorDown := ggRadial; + + GradientChecked := ggRadial; + GradientMirrorChecked := ggVertical; + + GradientDisabled := ggRadial; + GradientMirrorDisabled := ggRadial; + + FSystemFont := true; +end; + +procedure TGlowButtonAppearance.SetSystemFont(const Value: boolean); +begin + if (FSystemFont <> Value) then + begin + FSystemFont := Value; + Changed; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TGlowButtonAppearance.Assign(Source: TPersistent); +begin + if (Source is TGlowButtonAppearance) then + begin + Color := (Source as TGlowButtonAppearance).Color; + ColorTo := (Source as TGlowButtonAppearance).ColorTo; + ColorMirror := (Source as TGlowButtonAppearance).ColorMirror; + ColorMirrorTo := (Source as TGlowButtonAppearance).ColorMirrorTo; + + ColorHot := (Source as TGlowButtonAppearance).ColorHot; + ColorHotTo := (Source as TGlowButtonAppearance).ColorHotTo; + ColorMirrorHot := (Source as TGlowButtonAppearance).ColorMirrorHot; + ColorMirrorHotTo := (Source as TGlowButtonAppearance).ColorMirrorHotTo; + + ColorDown := (Source as TGlowButtonAppearance).ColorDown; + ColorDownTo := (Source as TGlowButtonAppearance).ColorDownTo; + ColorMirrorDown := (Source as TGlowButtonAppearance).ColorMirrorDown; + ColorMirrorDownTo := (Source as TGlowButtonAppearance).ColorMirrorDownTo; + + ColorChecked := (Source as TGlowButtonAppearance).ColorChecked; + ColorCheckedTo := (Source as TGlowButtonAppearance).ColorCheckedTo; + ColorMirrorChecked := (Source as TGlowButtonAppearance).ColorMirrorChecked; + ColorMirrorCheckedTo := (Source as TGlowButtonAppearance).ColorMirrorCheckedTo; + + ColorDisabled := (Source as TGlowButtonAppearance).ColorDisabled; + ColorDisabledTo := (Source as TGlowButtonAppearance).ColorDisabledTo; + ColorMirrorDisabled := (Source as TGlowButtonAppearance).ColorMirrorDisabled; + ColorMirrorDisabledTo := (Source as TGlowButtonAppearance).ColorMirrorDisabledTo; + + BorderColor := (Source as TGlowButtonAppearance).BorderColor; + BorderColorHot := (Source as TGlowButtonAppearance).BorderColorHot; + BorderColorDown := (Source as TGlowButtonAppearance).BorderColorDown; + BorderColorChecked := (Source as TGlowButtonAppearance).BorderColorChecked; + BorderColorDisabled := (Source as TGlowButtonAppearance).BorderColorDisabled; + + Gradient := (Source as TGlowButtonAppearance).Gradient; + GradientMirror := (Source as TGlowButtonAppearance).GradientMirror; + + GradientHot := (Source as TGlowButtonAppearance).GradientHot; + GradientMirrorHot := (Source as TGlowButtonAppearance).GradientMirrorHot; + + GradientDown := (Source as TGlowButtonAppearance).GradientDown; + GradientMirrorDown := (Source as TGlowButtonAppearance).GradientMirrorDown; + + GradientChecked := (Source as TGlowButtonAppearance).GradientChecked; + GradientMirrorChecked := (Source as TGlowButtonAppearance).GradientMirrorChecked; + + GradientDisabled := (Source as TGlowButtonAppearance).GradientDisabled; + GradientMirrorDisabled := (Source as TGlowButtonAppearance).GradientMirrorDisabled; + + SystemFont := (Source as TGlowButtonAppearance).SystemFont; + end + else + inherited Assign(Source); +end; + +//------------------------------------------------------------------------------ + +procedure TGlowButtonAppearance.Changed; +begin + if Assigned(FOnChange) then + FOnChange(Self); +end; + +//------------------------------------------------------------------------------ + +{$IFNDEF TMS_STD} + +{ TDBATBButtonDataLink } + +constructor TDBGlowButtonDataLink.Create; +begin + inherited Create; + FOnEditingChanged := nil; + FOnDataSetChanged := nil; + FOnActiveChanged := nil; +end; + +//------------------------------------------------------------------------------ + +procedure TDBGlowButtonDataLink.ActiveChanged; +begin + if Assigned(FOnActiveChanged) then FOnActiveChanged(Self); +end; + +//------------------------------------------------------------------------------ + +procedure TDBGlowButtonDataLink.DataSetChanged; +begin + if Assigned(FOnDataSetChanged) then FOnDataSetChanged(Self); +end; + +//------------------------------------------------------------------------------ + +procedure TDBGlowButtonDataLink.EditingChanged; +begin + if Assigned(FOnEditingChanged) then FOnEditingChanged(Self); +end; + +//------------------------------------------------------------------------------ + +{ TDBAdvToolBarButton } + +constructor TDBAdvGlowButton.Create(AOwner: TComponent); +begin + inherited; + FAutoDisable := True; + FDBButtonType := dbCustom; + FDisableControls := []; + FDataLink := TDBGlowButtonDataLink.Create; + with FDataLink do + begin + OnEditingChanged := OnDataSetEvents; + OnDataSetChanged := OnDataSetEvents; + OnActiveChanged := OnDataSetEvents; + end; + FConfirmActionString := ''; +end; + +//------------------------------------------------------------------------------ + +destructor TDBAdvGlowButton.Destroy; +begin + FDataLink.Free; + FDataLink := nil; + if (FInternalImages <> nil) then + FInternalImages.Free; + inherited; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.CalcDisableReasons; +begin + case FDBButtonType of + dbPrior: FDisableControls := [drBOF, drEditing, drEmpty]; + dbNext: FDisableControls := [drEOF, drEditing, drEmpty]; + dbFirst: FDisableControls := [drBOF, drEditing, drEmpty]; + dbLast: FDisableControls := [drEOF, drEditing, drEmpty]; + dbInsert, + dbAppend: FDisableControls := [drReadonly, drEditing]; + dbEdit: FDisableControls := [drReadonly, drEditing, drEmpty]; + dbCancel: FDisableControls := [drNotEditing]; + dbPost: FDisableControls := [drNotEditing]; + dbRefresh: FDisableControls := [drEditing]; + dbDelete: FDisableControls := [drReadonly, drEditing, drEmpty]; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.Click; +begin + inherited; + DoAction; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.CMEnabledChanged(var Message: TMessage); +begin + inherited; + if (not FInProcUpdateEnabled) and + (not (csLoading in ComponentState)) and + (not (csDestroying in ComponentState)) then + begin + UpdateEnabled; + end; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.DoAction; +var + DoAction: Boolean; + ShowException: Boolean; +begin + if not DoConfirmAction then + Exit; + + DoAction := (FDBButtonType <> dbCustom); + try + DoBeforeAction(DoAction); + if DoAction and (DataSource <> nil) and (DataSource.State <> dsInactive) then + begin + with DataSource.DataSet do + begin + case FDBButtonType of + dbPrior: Prior; + dbNext: Next; + dbFirst: First; + dbLast: Last; + dbInsert: Insert; + dbAppend: Append; + dbEdit: Edit; + dbCancel: Cancel; + dbPost: Post; + dbRefresh:Refresh; + dbDelete: Delete; + end; + end; + end; + ShowException := false; + except + ShowException := true; + if Assigned(FOnAfterAction) then + FOnAfterAction(self, ShowException); + if ShowException then + raise; + ShowException := true; + end; + if not ShowException and DoAction and Assigned(FOnAfterAction) then + FOnAfterAction(self, ShowException); +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.DoBeforeAction(var DoAction: Boolean); +begin + if (not (csDesigning in ComponentState)) and Assigned(FOnBeforeAction) then + FOnBeforeAction(self, DoAction); +end; + +//------------------------------------------------------------------------------ + +function TDBAdvGlowButton.DoConfirmAction: Boolean; +var + Question: string; + QuestionButtons: TMsgDlgButtons; + QuestionHelpCtx: Longint; + QuestionResult: Longint; +begin + DoGetQuestion(Question, QuestionButtons, QuestionHelpCtx); + if (Question <> '') then + begin + QuestionResult := MessageDlg(Question, mtConfirmation, QuestionButtons, QuestionHelpCtx); + Result := (QuestionResult = idOk) or (QuestionResult = idYes); + end + else + Result := true; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.DoGetQuestion(var Question: string; + var Buttons: TMsgDlgButtons; var HelpCtx: Integer); +begin + Question := ''; + if FConfirmAction then + begin + Question := FConfirmActionString; + Buttons := mbOKCancel; + HelpCtx := 0; + if Assigned(FOnGetConfirm) then + FOnGetConfirm(self, Question, Buttons, HelpCtx); + end; +end; + +//------------------------------------------------------------------------------ + +function TDBAdvGlowButton.GetDataSource: TDataSource; +begin + Result := FDataLink.DataSource; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.Notification(AComponent: TComponent; + AOperation: TOperation); +begin + inherited; + if (AOperation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then + DataSource := nil; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.SetDataSource(const Value: TDataSource); +begin + FDataLink.DataSource := Value; + if not (csLoading in ComponentState) then + UpdateEnabled; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.SetDBButtonType(const Value: TDBGlowButtonType); +begin + if (Value = FDBButtonType) then + Exit; + + if (Value = dbDelete) and (FConfirmActionString = ''){and ConfirmAction} then + FConfirmActionString := SDeleteRecordQuestion; //'Delete Record?'; + + if (csReading in ComponentState) or (csLoading in ComponentState) then + begin + FDBButtonType := Value; + CalcDisableReasons; + exit; + end; + + FDBButtonType := Value; + LoadGlyph; + CalcDisableReasons; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.UpdateEnabled; +var + PossibleDisableReasons: TDBBDisableControls; + GetEnable: Boolean; + WasEnabled: Boolean; +begin + if (csDesigning in ComponentState) or (csDestroying in ComponentState) or not FAutoDisable then + Exit; + + FInProcUpdateEnabled := true; + try + WasEnabled := Enabled; + if FDataLink.Active then + begin + PossibleDisableReasons := []; + if FDataLink.DataSet.BOF then + Include(PossibleDisableReasons, drBOF); + if FDataLink.DataSet.EOF then + Include(PossibleDisableReasons, drEOF); + if not FDataLink.DataSet.CanModify then + Include(PossibleDisableReasons, drReadonly); + if FDataLink.DataSet.BOF and FDataLink.DataSet.EOF then + Include(PossibleDisableReasons, drEmpty); + if FDataLink.Editing then + Include(PossibleDisableReasons, drEditing) + else + Include(PossibleDisableReasons, drNotEditing); + + GetEnable := ((FDisableControls - [drEvent])* PossibleDisableReasons = []); + if (drEvent in FDisableControls) and (Assigned(FOnGetEnabled)) then + FOnGetEnabled(Self, GetEnable); + Enabled := GetEnable; + end + else + Enabled := false; + + if (WasEnabled <> Enabled) and Assigned(FOnEnabledChanged) then + FOnEnabledChanged(self); + finally + FInProcUpdateEnabled := false; + end; + LoadGlyph; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.Loaded; +begin + inherited; + //if not Assigned(Images) then + LoadGlyph; + + UpdateEnabled; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.OnDataSetEvents(Sender: TObject); +begin + UpdateEnabled; +end; + +//------------------------------------------------------------------------------ + +procedure TDBAdvGlowButton.LoadGlyph; +var + Glyph: TBitMap; +begin + if (csLoading in ComponentState) or Assigned(Images) or (not Enabled and Assigned(DisabledImages)) then + Exit; + + if (FDBButtonType = dbCustom) then + Exit; + + if (FInternalImages = nil) then + FInternalImages := TImageList.Create(self); + + FInternalImages.Clear; + Glyph := TBitMap.Create; + Glyph.Width := 16; + Glyph.Height := 16; + Glyph.Transparent := True; + + case FDBButtonType of + dbPrior: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGPRIOR') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGPRIORD'); + end; + dbNext: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGNEXT') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGNEXTD'); + end; + dbFirst: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGFIRST') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGFIRSTD'); + end; + dbLast: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGLAST') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGLASTD'); + end; + dbInsert: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGINSERT') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGINSERTD'); + end; + dbAppend: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGINSERT') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGINSERTD'); + end; + dbEdit: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGEDIT') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGEDITD'); + end; + dbCancel: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGCANCEL') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGCANCELD'); + end; + dbPost: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGPOST') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGPOSTD'); + end; + dbRefresh: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGREFRESH') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGREFRESHD'); + end; + dbDelete: + begin + if Enabled then + Glyph.LoadFromResourceName(HInstance, 'DBIMGDELETE') + else + Glyph.LoadFromResourceName(HInstance, 'DBIMGDELETED'); + end; + end; + + FInternalImages.DrawingStyle := dsTransparent; + FInternalImages.Masked := true; + FInternalImages.AddMasked(Glyph, clFuchsia); + FImageIndex := 0; + Glyph.Free; + Invalidate; +end; + +//------------------------------------------------------------------------------ + + +procedure TDBAdvGlowButton.SetConfirmActionString(const Value: String); +begin + if FConfirmActionString <> Value then + begin + FConfirmActionString := Value; + end; +end; + +{$ENDIF} + +//------------------------------------------------------------------------------ + +{$IFDEF DELPHI6_LVL} + +{ TAdvGlowButtonActionLink } + +procedure TAdvGlowButtonActionLink.AssignClient(AClient: TObject); +begin + inherited AssignClient(AClient); + FClient := AClient as TAdvCustomGlowButton; +end; + +//------------------------------------------------------------------------------ + +function TAdvGlowButtonActionLink.IsCheckedLinked: Boolean; +begin + Result := inherited IsCheckedLinked {and (FClient.GroupIndex <> 0) and + FClient.AllowAllUp} and (FClient.Down = (Action as TCustomAction).Checked); + + FClient.CheckLinked := Result; +end; + +//------------------------------------------------------------------------------ + +function TAdvGlowButtonActionLink.IsGroupIndexLinked: Boolean; +begin + Result := (FClient is TAdvCustomGlowButton) and + (TAdvCustomGlowButton(FClient).GroupIndex = (Action as TCustomAction).GroupIndex); + + FClient.GroupIndexLinked := Result; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvGlowButtonActionLink.SetImageIndex(Value: Integer); +begin + if IsGroupIndexLinked then + begin + FImageIndex := Value; + TAdvCustomGlowButton(FClient).ImageIndex := Value; + end; +end; + +//------------------------------------------------------------------------------ + +function TAdvGlowButtonActionLink.IsImageIndexLinked: boolean; +begin + Result := inherited IsImageIndexLinked and + (FImageIndex = (Action as TCustomAction).ImageIndex); +end; + +//------------------------------------------------------------------------------ + +procedure TAdvGlowButtonActionLink.SetChecked(Value: Boolean); +begin + if IsCheckedLinked then + TAdvCustomGlowButton(FClient).Down := Value; +end; + +//------------------------------------------------------------------------------ + +procedure TAdvGlowButtonActionLink.SetGroupIndex(Value: Integer); +begin + if IsGroupIndexLinked then + TAdvCustomGlowButton(FClient).GroupIndex := Value; +end; + +{$ENDIF} + +{ TShortCutHintWindow } + +procedure TShortCutHintWindow.CreateParams(var Params: TCreateParams); +begin + inherited; + Params.Style := Params.Style and not WS_BORDER; +end; + +procedure TShortCutHintWindow.Paint; +var + r: TRect; +begin + r := ClientRect; + DrawGradient(Canvas, Color, ColorTo, 16, r, false); + Canvas.Brush.Style := bsClear; + Canvas.Font.Assign(self.Font); + + DrawText(Canvas.Handle,PChar(Caption),Length(Caption),r, DT_CENTER or DT_SINGLELINE or DT_VCENTER); + + Canvas.Pen.Color := clGray; + RoundRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom, 3,3); +end; + + +procedure TShortCutHintWindow.Resize; +var + ow: integer; +begin + inherited; + ow := Canvas.TextWidth('O') + 8; + if Width < ow then + Width := ow; +end; + +procedure TShortCutHintWindow.WMEraseBkGnd(var Message: TWMEraseBkGnd); +begin + Message.Result := 1; +end; + + + +function TAdvCustomGlowButton.CanDrawBorder: Boolean; +begin + Result := (BorderStyle = bsSingle); +end; + +function TAdvCustomGlowButton.CanDrawFocused: Boolean; +begin + Result := (GetFocus = self.Handle) and (FocusType in [ftBorder, ftHotBorder]); +end; + +{$IFDEF FREEWARE} +{$I TRIAL.INC} +{$ENDIF} + + + + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/advglowbuttondb.res b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advglowbuttondb.res new file mode 100644 index 0000000..5a25528 Binary files /dev/null and b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advglowbuttondb.res differ diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/advhintinfo.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advhintinfo.pas new file mode 100644 index 0000000..864f1f7 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advhintinfo.pas @@ -0,0 +1,92 @@ +{***************************************************************************} +{ TAdvHintInfo component } +{ for Delphi & C++Builder } +{ version 1.0 } +{ } +{ written by TMS Software } +{ copyright © 2006 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit AdvHintInfo; + +interface + +uses + Classes, GDIPicture; + +type + TAdvHintInfo = class(TPersistent) + private + FPicture: TGDIPPicture; + FShowHelp: boolean; + FNotes: TStrings; + FTitle: string; + FWideTitle: widestring; + FWideNotes: widestring; + procedure SetNotes(const Value: TStrings); + procedure SetPicture(const Value: TGDIPPicture); + public + constructor Create; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + property WideTitle: widestring read FWideTitle write FWideTitle; + property WideNotes: widestring read FWideNotes write FWideNotes; + published + property Title: string read FTitle write FTitle; + property Notes: TStrings read FNotes write SetNotes; + property Picture: TGDIPPicture read FPicture write SetPicture; + property ShowHelp: boolean read FShowHelp write FShowHelp default false; + end; + +implementation + +{ TAdvHintInfo } + +procedure TAdvHintInfo.Assign(Source: TPersistent); +begin + if (Source is TAdvHintInfo) then + begin + Title := (Source as TAdvHintInfo).Title; + Notes.Assign((Source as TAdvHintInfo).Notes); + ShowHelp := (Source as TAdvHintInfo).ShowHelp; + Picture.Assign((Source as TAdvHintInfo).Picture); + WideTitle := (Source as TAdvHintInfo).WideTitle; + WideNotes := (Source as TAdvHintInfo).WideNotes; + end; +end; + +constructor TAdvHintInfo.Create; +begin + inherited; + FNotes := TStringList.Create; + FPicture := TGDIPPicture.Create; +end; + +destructor TAdvHintInfo.Destroy; +begin + FNotes.Free; + FPicture.Free; + inherited; +end; + +procedure TAdvHintInfo.SetNotes(const Value: TStrings); +begin + FNotes.Assign(Value); +end; + +procedure TAdvHintInfo.SetPicture(const Value: TGDIPPicture); +begin + FPicture.Assign(Value); +end; + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/advstyleif.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advstyleif.pas new file mode 100644 index 0000000..8a5fbad --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/advstyleif.pas @@ -0,0 +1,62 @@ +{***************************************************************************} +{ TAdvStyleIF interface } +{ for Delphi & C++Builder } +{ } +{ written by TMS Software } +{ copyright © 2006 - 2007 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit AdvStyleIF; + +interface + +uses + Classes; + +type + TTMSStyle = (tsOffice2003Blue, tsOffice2003Silver, tsOffice2003Olive, tsOffice2003Classic, + tsOffice2007Luna, tsOffice2007Obsidian, tsWindowsXP, tsWhidbey, tsCustom, tsOffice2007Silver); + + // + // ['{E1199D64-5AF9-4DB7-B363-FABE5D1EEE0F}'] + // function GetComponentStyle: TTMSStyle; + + ITMSStyle = interface + ['{11AC2DDC-C087-4298-AB6E-EA1B5017511B}'] + procedure SetComponentStyle(AStyle: TTMSStyle); + end; + +function IsVista: boolean; + +implementation + +uses + Windows; + +//------------------------------------------------------------------------------ + +function IsVista: boolean; +var + hKernel32: HMODULE; +begin + hKernel32 := GetModuleHandle('kernel32'); + if (hKernel32 > 0) then + begin + Result := GetProcAddress(hKernel32, 'GetLocaleInfoEx') <> nil; + end + else + Result := false; +end; + + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/gdipicture.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/gdipicture.pas new file mode 100644 index 0000000..7f33d59 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/gdipicture.pas @@ -0,0 +1,384 @@ +{***************************************************************************} +{ TGDIPPicture class } +{ for Delphi & C++Builder } +{ version 1.0 } +{ } +{ written by TMS Software } +{ copyright © 2006 - 2007 } +{ Email : info@tmssoftware.com } +{ Web : http://www.tmssoftware.com } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{***************************************************************************} + +unit GDIPicture; + +interface + +uses + Windows, Classes, Graphics, Controls , SysUtils, AdvGDIP, ComObj, ActiveX; + +{$I TMSDEFS.INC} + +type + + TGDIPPicture = class(TGraphic) + private + { Private declarations } + FDatastream: TMemoryStream; + FIsEmpty: Boolean; + FWidth, FHeight: Integer; + FDoubleBuffered: Boolean; + FBackgroundColor: TColor; + FOnClear: TNotifyEvent; + protected + { Protected declarations } + function GetEmpty: Boolean; override; + function GetHeight: Integer; override; + function GetWidth: Integer; override; + procedure SetHeight(Value: Integer); override; + procedure SetWidth(Value: Integer); override; + procedure ReadData(Stream: TStream); override; + procedure WriteData(Stream: TStream); override; + public + { Public declarations } + constructor Create; override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + procedure Draw(ACanvas: TCanvas; const Rect: TRect); override; + procedure LoadFromFile(const FileName: string); override; + procedure LoadFromStream(Stream: TStream); override; + procedure SaveToStream(Stream: TStream); override; + procedure LoadFromResourceName(Instance: THandle; const ResName: String); + procedure LoadFromResourceID(Instance: THandle; ResID: Integer); + procedure LoadFromURL(url:string); + procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; + APalette: HPALETTE); override; + procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; + var APalette: HPALETTE); override; + property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered; + property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor; + function GetImageSizes: boolean; + published + { Published declarations } + property OnClear: TNotifyEvent read FOnClear write FOnClear; + end; + + +implementation + + +{ TGDIPPicture } + +procedure TGDIPPicture.Assign(Source: TPersistent); +var + st: TMemoryStream; +begin + FIsEmpty := True; + if Source = nil then + begin + FDataStream.Clear; + FIsEmpty := true; + if Assigned(OnChange) then + OnChange(Self); + if Assigned(OnClear) then + OnClear(self); + end + else + begin + if Source is TGDIPPicture then + begin + FDataStream.LoadFromStream(TGDIPPicture(Source).FDataStream); + FIsEmpty := False; + if Assigned(OnChange) then + OnChange(self); + end + else + if Source is TBitmap then + begin + st := TMemoryStream.Create; + (Source as TBitmap).SaveToStream(st); + st.Position := 0; + FDataStream.LoadFromStream(st); + st.Free; + FIsEmpty := false; + if Assigned(OnChange) then + OnChange(self); + end + else + if (Source is TPicture) then + begin + st := TMemoryStream.Create; + (Source as TPicture).Graphic.SaveToStream(st); + st.Position := 0; + FDataStream.LoadFromStream(st); + st.Free; + FIsEmpty := false; + if Assigned(OnChange) then + OnChange(self); + end; + + GetImageSizes; + end; +end; + +constructor TGDIPPicture.Create; +begin + inherited; + FDataStream := TMemoryStream.Create; + FIsEmpty := True; +end; + +destructor TGDIPPicture.Destroy; +begin + FDataStream.Free; + inherited; +end; + +procedure TGDIPPicture.Draw(ACanvas: TCanvas; const Rect: TRect); +var + dc: HDC; + multi: TGPImage; + graphic: TGPgraphics; + pstm: IStream; + hGlobal: THandle; + pcbWrite: Longint; + bmp: tbitmap; + +begin + if Empty then + Exit; + + if FDataStream.Size = 0 then + Exit; + + hGlobal := GlobalAlloc(GMEM_MOVEABLE, FDataStream.Size); + if (hGlobal = 0) then + raise Exception.Create('Could not allocate memory for image'); + + try + pstm := nil; + + // Create IStream* from global memory + CreateStreamOnHGlobal(hGlobal, TRUE, pstm); + pstm.Write(FDataStream.Memory, FDataStream.Size,@pcbWrite); + + dc := ACanvas.Handle; + graphic:= TGPgraphics.Create(dc); + multi := TGPImage.Create(pstm); + + if multi.GetFormat = ifBMP then + begin // use this alternative for easy bitmap auto transparent drawing + bmp := TBitmap.Create; + FDataStream.Position := 0; + bmp.LoadFromStream(FDataStream); + bmp.TransparentMode := tmAuto; + bmp.Transparent := true; + ACanvas.Draw(Rect.Left,Rect.Top, bmp); + bmp.Free; + end + else + begin + FWidth := multi.GetWidth; + FHeight := multi.GetHeight; + graphic.DrawImageRect(multi, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top); + end; + + multi.Free; + graphic.Free; + finally + GlobalFree(hGlobal); + end; + +end; + +function TGDIPPicture.GetImageSizes: boolean; +var + multi: TGPImage; + pstm: IStream; + hGlobal: THandle; + pcbWrite: Longint; + +begin + Result := false; + + if Empty then + Exit; + + if FDataStream.Size = 0 then + Exit; + + hGlobal := GlobalAlloc(GMEM_MOVEABLE, FDataStream.Size); + if (hGlobal = 0) then + raise Exception.Create('Could not allocate memory for image'); + + try + pstm := nil; + // Create IStream* from global memory + CreateStreamOnHGlobal(hGlobal, TRUE, pstm); + pstm.Write(FDataStream.Memory, FDataStream.Size,@pcbWrite); + multi := TGPImage.Create(pstm); + + FWidth := multi.GetWidth; + FHeight := multi.GetHeight; + + Result := true; + + multi.Free; + finally + GlobalFree(hGlobal); + end; + +end; + +function TGDIPPicture.GetEmpty: Boolean; +begin + Result := FIsEmpty; +end; + +function TGDIPPicture.GetHeight: Integer; +begin + Result := FHeight; +end; + +function TGDIPPicture.GetWidth: Integer; +begin + Result := FWidth; +end; + +procedure TGDIPPicture.LoadFromFile(const FileName: string); +begin + try + FDataStream.LoadFromFile(Filename); + + FIsEmpty := False; + + if Assigned(OnClear) then + OnClear(self); + + GetImageSizes; + + if Assigned(OnChange) then + OnChange(self); + + + except + FIsEmpty:=true; + end; +end; + +procedure TGDIPPicture.LoadFromStream(Stream: TStream); +begin + if Assigned(Stream) then + begin + FDataStream.LoadFromStream(Stream); + FIsEmpty := False; + + GetImageSizes; + + if Assigned(OnChange) then + OnChange(self); + end; +end; + +procedure TGDIPPicture.ReadData(Stream: TStream); +begin + if Assigned(Stream) then + begin + FDataStream.LoadFromStream(stream); + FIsEmpty := False; + end; +end; + +procedure TGDIPPicture.SaveToStream(Stream: TStream); +begin + if Assigned(Stream) then + FDataStream.SaveToStream(Stream); +end; + + +procedure TGDIPPicture.SetHeight(Value: Integer); +begin + {$IFDEF DELPHI6_LVL} + inherited; + {$ENDIF} +end; + +procedure TGDIPPicture.SetWidth(Value: Integer); +begin + {$IFDEF DELPHI6_LVL} + inherited; + {$ENDIF} +end; + +procedure TGDIPPicture.LoadFromResourceName(Instance: THandle; const ResName: string); +var + Stream: TCustomMemoryStream; +begin + if FindResource(Instance,PChar(ResName),RT_RCDATA) <> 0 then + begin + Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; + end; +end; + +procedure TGDIPPicture.LoadFromResourceID(Instance: THandle; ResID: Integer); +var + Stream: TCustomMemoryStream; +begin + Stream := TResourceStream.CreateFromID(Instance, ResID, RT_RCDATA); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TGDIPPicture.WriteData(Stream: TStream); +begin + if Assigned(Stream) then + begin + FDataStream.SaveToStream(stream); + end; +end; + +procedure TGDIPPicture.LoadFromURL(url: string); +begin + if (pos('RES://',UpperCase(url))=1) then + begin + Delete(url,1,6); + if (url<>'') then + LoadFromResourceName(hinstance,url); + Exit; + end; + + if (pos('FILE://',uppercase(url))=1) then + begin + Delete(url,1,7); + if (url<>'') + then LoadFromFile(url); + end; +end; + +procedure TGDIPPicture.LoadFromClipboardFormat(AFormat: Word; + AData: THandle; APalette: HPALETTE); +begin +end; + +procedure TGDIPPicture.SaveToClipboardFormat(var AFormat: Word; + var AData: THandle; var APalette: HPALETTE); +begin +end; + + +end. diff --git a/TAdvTaskDialog/internal/1.5.0.2/1/Source/htmlengo.pas b/TAdvTaskDialog/internal/1.5.0.2/1/Source/htmlengo.pas new file mode 100644 index 0000000..5968bf5 --- /dev/null +++ b/TAdvTaskDialog/internal/1.5.0.2/1/Source/htmlengo.pas @@ -0,0 +1,2357 @@ +{**************************************************************************} +{ Mini HTML rendering engine } +{ for Delphi & C++Builder } +{ version 1.9 } +{ } +{ written by TMS Software } +{ copyright © 1999-2006 } +{ Email : info@tmssoftware.com } +{ Website : http://www.tmssoftware.com/ } +{ } +{ The source code is given as is. The author is not responsible } +{ for any possible damage done due to the use of this code. } +{ The component can be freely used in any application. The complete } +{ source code remains property of the author and may not be distributed, } +{ published, given or sold in any form as such. No parts of the source } +{ code can be included in any other component or application without } +{ written authorization of the author. } +{**************************************************************************} + +{$I TMSDEFS.INC} + +{$IFNDEF TMSDOTNET} +procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap); +var + BitmapHeader: pBitmapInfo; + BitmapImage : POINTER; + HeaderSize : DWORD; + ImageSize : DWORD; +begin + GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize); + GetMem(BitmapHeader, HeaderSize); + GetMem(BitmapImage, ImageSize); + try + GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^); + StretchDIBits(Canvas.Handle, + DestRect.Left, DestRect.Top, // Destination Origin + DestRect.Right - DestRect.Left, // Destination Width + DestRect.Bottom - DestRect.Top, // Destination Height + 0, 0, // Source Origin + Bitmap.Width, Bitmap.Height, // Source Width & Height + BitmapImage, + TBitmapInfo(BitmapHeader^), + DIB_RGB_COLORS, + SRCCOPY) + finally + FreeMem(BitmapHeader); + FreeMem(BitmapImage) + end; +end; +{$ENDIF} + +{$IFDEF TMSDOTNET} +procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap); +var + BitmapHeader: TBitmapInfo; + HeaderSize : DWORD; + ImageSize : DWORD; + Bits: HBITMAP; + Image: TBytes; + Info: IntPtr; + +begin + Bits := Bitmap.Handle; + + GetDIBSizes(Bits, HeaderSize, ImageSize); + + + Info := System.Runtime.InteropServices.Marshal.AllocHGlobal(HeaderSize); + + try + SetLength(Image, ImageSize); + GetDIB(Bits, 0, Info, Image); + + BitmapHeader := TBitmapInfo(System.Runtime.InteropServices.Marshal.PtrToStructure(Info, TypeOf(TBitmapInfo))); + + StretchDIBits(Canvas.Handle, + DestRect.Left, DestRect.Top, // Destination Origin + DestRect.Right - DestRect.Left, // Destination Width + DestRect.Bottom - DestRect.Top, // Destination Height + 0, 0, // Source Origin + Bitmap.Width, Bitmap.Height, // Source Width & Height + Image, + Info, + DIB_RGB_COLORS, + SRCCOPY) + finally + System.Runtime.InteropServices.Marshal.FreeHGlobal(Info); + end; +end; +{$ENDIF} + +function DirExists(const Name: string): Boolean; +var + Code: Integer; +begin + {$IFNDEF TMSDOTNET} + Code := GetFileAttributes(PChar(Name)); + {$ENDIF} + {$IFDEF TMSDOTNET} + Code := GetFileAttributes(Name); + {$ENDIF} + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; + +function SysImage(Canvas: TCanvas;x,y:Integer;APath:string;large,draw,print:boolean;resfactor:double):TPoint; +var + SFI: TSHFileInfo; + i,Err: Integer; + imglsthandle: THandle; + rx,ry: Integer; + bmp: TBitmap; + r: TRect; +begin + Val(APath,i,Err); + + {$IFNDEF TMSDOTNET} + FillChar(SFI,Sizeof(SFI),0); + {$ENDIF} + + {$IFNDEF TMSDOTNET} + if (APath <> '') and (Err <> 0) then + begin + if FileExists(APath) or DirExists(APath) then + // If the file or directory exists, just let Windows figure out it's attrs. + SHGetFileInfo(PChar(APath), 0, SFI, SizeOf(TSHFileInfo), + SHGFI_SYSICONINDEX {or OPEN_FLAG[Open] or SELECTED_FLAG[Selected]}) + else + // File doesn't exist, so Windows doesn't know what to do with it. We have + // to tell it by passing the attributes we want, and specifying the + // SHGFI_USEFILEATTRIBUTES flag so that the function knows to use them. + SHGetFileInfo(PChar(APath), 0, SFI, SizeOf(TSHFileInfo), + SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES {or OPEN_FLAG[Open] or SELECTED_FLAG[Selected]}); + i := SFI.iIcon; + end; + + if Large then + imglsthandle := SHGetFileInfo('', 0, SFI, SizeOf(SFI), + SHGFI_SYSICONINDEX or SHGFI_LARGEICON) + else + imglsthandle := SHGetFileInfo('', 0, SFI, SizeOf(SFI), + SHGFI_SYSICONINDEX or SHGFI_SMALLICON); + {$ENDIF} + {$IFDEF TMSDOTNET} + if (APath <> '') and (Err <> 0) then + begin + if FileExists(APath) or DirExists(APath) then + // If the file or directory exists, just let Windows figure out it's attrs. + SHGetFileInfo(APath, 0, SFI, System.Runtime.interopservices.marshal.SizeOf(TypeOf(TSHFileInfo)), + SHGFI_SYSICONINDEX {or OPEN_FLAG[Open] or SELECTED_FLAG[Selected]}) + else + // File doesn't exist, so Windows doesn't know what to do with it. We have + // to tell it by passing the attributes we want, and specifying the + // SHGFI_USEFILEATTRIBUTES flag so that the function knows to use them. + SHGetFileInfo(APath, 0, SFI, System.Runtime.interopservices.Marshal.SizeOf(TypeOf(TSHFileInfo)), + SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES {or OPEN_FLAG[Open] or SELECTED_FLAG[Selected]}); + i := SFI.iIcon; + end; + + if Large then + imglsthandle := SHGetFileInfo('', 0, SFI, System.Runtime.interopservices.Marshal.SizeOf(TypeOf(SFI)), + SHGFI_SYSICONINDEX or SHGFI_LARGEICON) + else + imglsthandle := SHGetFileInfo('', 0, SFI, System.Runtime.interopservices.Marshal.SizeOf(TypeOf(SFI)), + SHGFI_SYSICONINDEX or SHGFI_SMALLICON); + {$ENDIF} + + + ImageList_GetIconSize(imglsthandle,rx,ry); + + {$IFNDEF TMSDOTNET} + Result := Point(rx,ry); + {$ENDIF} + {$IFDEF TMSDOTNET} + Result := Borland.Vcl.Types.Point(rx,ry); + {$ENDIF} + + if Draw and not Print then + ImageList_Draw(imglsthandle,i,Canvas.Handle,x,y, ILD_TRANSPARENT); + + if Draw and Print then + begin + bmp := TBitmap.Create; + bmp.Width := rx; + bmp.Height := ry; + ImageList_Draw(imglsthandle,i,bmp.Canvas.handle,0,0,ILD_NORMAL); + r.left := x; + r.top := y; + r.right := x + Round(rx * ResFactor); + r.bottom := y + Round(ry * ResFactor); + PrintBitmap(Canvas,r,bmp); + bmp.Free; + end; +end; + +procedure DrawHTMLGradient(Canvas: TCanvas; FromColor,ToColor,BorderColor: TColor; Steps: Integer;R:TRect; Direction: Boolean); +var + diffr,startr,endr: Integer; + diffg,startg,endg: Integer; + diffb,startb,endb: Integer; + iend: Integer; + rstepr,rstepg,rstepb,rstepw: Real; + i,stepw: Word; +begin + if Steps = 0 then + Steps := 1; + + FromColor := ColorToRGB(FromColor); + ToColor := ColorToRGB(ToColor); + + startr := (FromColor and $0000FF); + startg := (FromColor and $00FF00) shr 8; + startb := (FromColor and $FF0000) shr 16; + endr := (ToColor and $0000FF); + endg := (ToColor and $00FF00) shr 8; + endb := (ToColor and $FF0000) shr 16; + + diffr := endr - startr; + diffg := endg - startg; + diffb := endb - startb; + + rstepr := diffr / steps; + rstepg := diffg / steps; + rstepb := diffb / steps; + + if Direction then + rstepw := (R.Right - R.Left) / Steps + else + rstepw := (R.Bottom - R.Top) / Steps; + + with Canvas do + begin + for i := 0 to Steps - 1 do + begin + endr := startr + Round(rstepr*i); + endg := startg + Round(rstepg*i); + endb := startb + Round(rstepb*i); + stepw := Round(i*rstepw); + Pen.Color := endr + (endg shl 8) + (endb shl 16); + Brush.Color := Pen.Color; + if Direction then + begin + iend := R.Left + stepw + Trunc(rstepw) + 1; + if iend > R.Right then + iend := R.Right; + Rectangle(R.Left + stepw,R.Top,iend,R.Bottom) + end + else + begin + iend := R.Top + stepw + Trunc(rstepw)+1; + if iend > r.Bottom then + iend := r.Bottom; + Rectangle(R.Left,R.Top + stepw,R.Right,iend); + end; + end; + + if BorderColor <> clNone then + begin + Brush.Style := bsClear; + Pen.Color := BorderColor; + Rectangle(R.Left,R.Top,R.Right,R.Bottom); + end; + end; +end; + +{ +procedure DrawHTMLGradient(Canvas: TCanvas; FromColor,ToColor: TColor; Steps: Integer;R:TRect; Direction: Boolean); +var + diffr,startr,endr: Integer; + diffg,startg,endg: Integer; + diffb,startb,endb: Integer; + iend: Integer; + rstepr,rstepg,rstepb,rstepw: Real; + i,stepw: Word; + +begin + if Steps = 0 then + Steps := 1; + + FromColor := ColorToRGB(FromColor); + ToColor := ColorToRGB(ToColor); + + startr := (FromColor and $0000FF); + startg := (FromColor and $00FF00) shr 8; + startb := (FromColor and $FF0000) shr 16; + endr := (ToColor and $0000FF); + endg := (ToColor and $00FF00) shr 8; + endb := (ToColor and $FF0000) shr 16; + + diffr := endr - startr; + diffg := endg - startg; + diffb := endb - startb; + + rstepr := diffr / steps; + rstepg := diffg / steps; + rstepb := diffb / steps; + + if Direction then + rstepw := (R.Right - R.Left) / Steps + else + rstepw := (R.Bottom - R.Top) / Steps; + + with Canvas do + begin + for i := 0 to Steps - 1 do + begin + endr := startr + Round(rstepr*i); + endg := startg + Round(rstepg*i); + endb := startb + Round(rstepb*i); + stepw := Round(i*rstepw); + Pen.Color := endr + (endg shl 8) + (endb shl 16); + Brush.Color := Pen.Color; + if Direction then + begin + iend := R.Left + stepw + Trunc(rstepw) + 1; + if iend > R.Right then + iend := R.Right; + Rectangle(R.Left + stepw,R.Top,iend,R.Bottom) + end + else + begin + iend := R.Top + stepw + Trunc(rstepw)+1; + if iend > r.Bottom then + iend := r.Bottom; + Rectangle(R.Left,R.Top + stepw,R.Right,iend); + end; + end; + end; +end; +} + +function Text2Color(s:string):tcolor; +begin + Result := clBlack; + + if (s='clred') then result:=clred else + if (s='clblack') then result:=clblack else + if (s='clblue') then result:=clblue else + if (s='clgreen') then result:=clgreen else + if (s='claqua') then result:=claqua else + if (s='clyellow') then result:=clyellow else + if (s='clfuchsia') then result:=clfuchsia else + if (s='clwhite') then result:=clwhite else + if (s='cllime') then result:=cllime else + if (s='clsilver') then result:=clsilver else + if (s='clgray') then result:=clgray else + if (s='clolive') then result:=clolive else + if (s='clnavy') then result:=clnavy else + if (s='clpurple') then result:=clpurple else + if (s='clteal') then result:=clteal else + if (s='clmaroon') then result:=clmaroon; + + if Result <> clBlack then Exit; + + if (s='clbackground') then result:=clbackground else + if (s='clactivecaption') then result:=clactivecaption else + if (s='clinactivecaption') then result:=clinactivecaption else + if (s='clmenu') then result:=clmenu else + if (s='clwindow') then result:=clwindow else + if (s='clwindowframe') then result:=clwindowframe else + if (s='clmenutext') then result:=clmenutext else + if (s='clwindowtext') then result:=clwindowtext else + if (s='clcaptiontext') then result:=clcaptiontext else + if (s='clactiveborder') then result:=clactiveborder else + if (s='clinactiveborder') then result:=clinactiveborder else + if (s='clappworkspace') then result:=clappworkspace else + if (s='clhighlight') then result:=clhighlight else + if (s='clhighlighttext') then result:=clhighlighttext else + if (s='clbtnface') then result:=clbtnface else + if (s='clbtnshadow') then result:=clbtnshadow else + if (s='clgraytext') then result:=clgraytext else + if (s='clbtntext') then result:=clbtntext else + if (s='clinactivecaptiontext') then result:=clinactivecaptiontext else + if (s='clbtnhighlight') then result:=clbtnhighlight else + if (s='cl3ddkshadow') then result:=clgraytext else + if (s='cl3dlight') then result:=cl3dlight else + if (s='clinfotext') then result:=clinfotext else + if (s='clinfobk') then result:=clinfobk; +end; + +function HexVal(s:string): Integer; +var + i,j: Integer; +begin + if Length(s) < 2 then + begin + Result := 0; + Exit; + end; + + if s[1] >= 'A' then + i := ord(s[1]) - ord('A') + 10 + else + i := ord(s[1]) - ord('0'); + + if s[2] >= 'A' then + j := ord(s[2]) - ord('A') + 10 + else + j := ord(s[2]) - ord('0'); + + Result := i shl 4 + j; +end; + +function Hex2Color(s:string): TColor; +var + r,g,b: Integer; +begin + r := Hexval(Copy(s,2,2)); + g := Hexval(Copy(s,4,2)) shl 8; + b := Hexval(Copy(s,6,2)) shl 16; + Result := TColor(b + g + r); +end; + +function IPos(su,s:string):Integer; +begin + Result := Pos(UpperCase(su),UpperCase(s)); +end; + +function IStrToInt(s:string):Integer; +var + Err,Res: Integer; +begin + Val(s,Res,Err); + Result := Res; +end; + +function DBTagStrip(s:string):string; +var + i,j: Integer; +begin + i := Pos('<#',s); + if i > 0 then + begin + Result := Copy(s,1,i - 1); + Delete(s,1,i); + j := Pos('>',s); + if j > 0 then + Delete(s,j,1); + Result := Result + s; + end + else + Result := s; +end; + +function CRLFStrip(s:string;break:boolean):string; +var + i: Integer; +begin + Result := ''; + for i := 1 to Length(s) do + begin + if not (s[i] in [#13,#10]) then + Result := Result + s[i] + else + if (s[i] = #13) and break then + Result := Result + '
'; + end; +end; + +function VarPos(su,s:string;var Res:Integer):Integer; +begin + Res := Pos(su,s); + Result := Res; +end; + +function TagReplaceString(const Srch,Repl:string;var Dest:string):Boolean; +var + i: Integer; +begin + i := IPos(srch,dest); + if i > 0 then + begin + Result := True; + Delete(Dest,i,Length(Srch)); + Dest := Copy(Dest,1,i-1) + Repl + Copy(Dest,i,Length(Dest)); + end + else + Result := False; +end; + +{$WARNINGS OFF} +function HTMLDrawEx(Canvas:TCanvas; s:string; fr:TRect; + FImages: TImageList; + XPos,YPos,FocusLink,HoverLink,ShadowOffset: Integer; + CheckHotSpot,CheckHeight,Print,Selected,Blink,HoverStyle,WordWrap: Boolean; + ResFactor:Double; + URLColor,HoverColor,HoverFontColor,ShadowColor:TColor; + var AnchorVal,StripVal,FocusAnchor: string; + var XSize,YSize,HyperLinks,MouseLink: Integer; + var HoverRect:TRect;ic: THTMLPictureCache; pc: TPictureContainer;LineSpacing: Integer): Boolean; +var + su: string; + r,dr,hr,rr,er: TRect; + htmlwidth,htmlheight,txtheight: Integer; + Align: TAlignment; + PIndent: Integer; + OldFont: TFont; + CalcFont: TFont; + DrawFont: TFont; + OldCalcFont: TFont; + OldDrawFont: TFont; + Hotspot, ImageHotspot: Boolean; + Anchor,OldAnchor,MouseInAnchor,Error: Boolean; + bgcolor,paracolor,hvrcolor,hvrfntcolor,pencolor,blnkcolor,hifcol,hibcol: TColor; + LastAnchor,OldAnchorVal: string; + IMGSize: TPoint; + isSup,isSub,isPara,isShad: Boolean; + subh,suph,imgali,srchpos,hlcount,licount: Integer; + hrgn,holdfont: THandle; + ListIndex: Integer; + dtp: TDrawTextParams; + Invisible: Boolean; + FoundTag: Boolean; + {new for editing} + nnFit: Integer; + nnSize: TSize; + inspoint: Integer; + {$IFNDEF TMSDOTNET} + nndx: Pointer; + {$ENDIF} + AltImg,ImgIdx,OldImgIdx: Integer; + DrawStyle: DWord; + Col1,Col2: TColor; + ofsx,newofsx: integer; + + procedure StartRotated(Canvas:TCanvas;Angle: Integer); + var + LFont:TLogFont; + begin + {$IFNDEF TMSDOTNET} + GetObject(Canvas.Font.Handle,SizeOf(LFont),Addr(LFont)); + {$ENDIF} + + {$IFDEF TMSDOTNET} + GetObject(Canvas.Font.Handle,System.Runtime.InteropServices.Marshal.SizeOf(TypeOf(LFont)),LFont); + {$ENDIF} + + LFont.lfEscapement := Angle * 10; + LFont.lfOrientation := Angle * 10; + hOldFont:=SelectObject(Canvas.Handle,CreateFontIndirect(LFont)); + end; + + procedure EndRotated(Canvas:TCanvas); + begin + DeleteObject(SelectObject(Canvas.Handle,hOldFont)); + end; + + function HTMLDrawLine(Canvas: TCanvas;var s:string;r: TRect;Calc:Boolean; + var w,h,subh,suph,imgali:Integer;var Align:TAlignment; var PIndent: Integer; + XPos,YPos:Integer;var Hotspot,ImageHotSpot:Boolean;OffsetX: integer; var NewOffsetX: integer):string; + var + su,Res,TagProp,Prop,AltProp,Tagp,LineText:string; + cr: TRect; + linebreak,imgbreak,linkbreak: Boolean; + th,sw,indent,err,bmpx,bmpy,oldh: Integer; + TagPos,SpacePos,o,l: Integer; + bmp: THTMLPicture; + ABitmap: TBitmap; + NewColor,NewColorTo: TColor; + TagWidth,TagHeight,WordLen,WordLenEx,WordWidth: Integer; + TagChar: Char; + LengthFits, SpaceBreak: Boolean; + + begin + Result := ''; + LineText := ''; + r.Bottom := r.Bottom - Subh; + + w := 0; + sw := 0; + + LineBreak := False; + ImgBreak := False; + LinkBreak := False; + HotSpot := False; + ImageHotSpot := False; + +// r.Left := r.Left + offsetX; + + cr := r; + res := ''; + + if not Calc then + cr.Left := cr.Left + OffsetX; + + if isPara and not Calc then + begin + Pencolor := Canvas.Pen.Color; + Canvas.Pen.color := Canvas.Brush.Color; + Canvas.Rectangle(fr.Left,r.Top,fr.Right,r.Top + h); + end; + + while (Length(s) > 0) and not LineBreak and not ImgBreak do + begin + // get next word or till next HTML tag + TagPos := Pos('<',s); + + if WordWrap then + SpacePos := Pos(' ',s) + else + SpacePos := 0; + + if (Tagpos > 0) and ((SpacePos > TagPos) or (SpacePos = 0)) then + begin + su := Copy(s,1,TagPos - 1); + end + else + begin + if SpacePos > 0 then + su := Copy(s,1,SpacePos) + else + su := s; + end; + + {$IFDEF TMSDEBUG} + DbgMsg(su+ '.'); + {$ENDIF} + + WordLen := Length(su); + + while Pos(' ',su) > 0 do + begin + TagReplacestring(' ',' ',su); + end; + + while Pos('<',su) > 0 do + begin + TagReplacestring('<','<',su); + end; + + while Pos('>',su) > 0 do + begin + TagReplacestring('>','>',su); + end; + + WordLenEx := Length(su); + + if WordLen > 0 then + begin + th := Canvas.TextHeight(su); + + if isSub and (subh < (th shr 2)) then subh := th shr 2; + if isSup and (suph < (th shr 2)) then suph := th shr 2; + + if th > h then + h := th; + + StripVal := StripVal + su; + + if Invisible then + Delete(s,1,WordLen); + + if not Invisible then + begin + // draw mode + if not Calc then + begin + if isSup then + cr.Bottom := cr.Bottom - suph; + if isSub then + cr.Bottom := cr.Bottom + subh; + + cr.Bottom := cr.Bottom - imgali; + + if isShad then + begin + OffsetRect(cr,ShadowOffset,ShadowOffset); + NewColor := Canvas.Font.Color; + Canvas.Font.Color := ShadowColor; + {$IFNDEF TMSDOTNET} + DrawTextEx(Canvas.Handle,PChar(su),WordLenEx,cr,DrawStyle and not DT_EXTERNALLEADING,nil); + {$ENDIF} + {$IFDEF TMSDOTNET} + DrawTextEx(Canvas.Handle,su,WordLenEx,cr,DrawStyle and not DT_EXTERNALLEADING,nil); + {$ENDIF} + Offsetrect(cr,-ShadowOffset,-ShadowOffset); + Canvas.Font.Color := NewColor; + end; + + {$IFNDEF TMSDOTNET} + DrawTextEx(Canvas.Handle,PChar(su),WordLenEx,cr,DrawStyle and not DT_EXTERNALLEADING,nil); + DrawTextEx(Canvas.Handle,PChar(su),WordLenEx,cr,DrawStyle or DT_CALCRECT,nil); + {$ENDIF} + + {$IFDEF TMSDOTNET} + DrawTextEx(Canvas.Handle,su,WordLenEx,cr,DrawStyle and not DT_EXTERNALLEADING,nil); + DrawTextEx(Canvas.Handle,su,WordLenEx,cr,DrawStyle or DT_CALCRECT,nil); + {$ENDIF} + + if Anchor and (Hyperlinks - 1 = FocusLink) then + FocusAnchor := LastAnchor; + + {$IFDEF TMSDEBUG} + if Anchor then + OutputDebugString(pchar('drawrect for '+anchorval+' = ['+inttostr(cr.Left)+':'+inttostr(cr.Top)+'] ['+inttostr(cr.right)+':'+inttostr(cr.bottom)+'] @ ['+inttostr(xpos)+':'+inttostr(ypos))); + {$ENDIF} + + if Error then + begin + Canvas.Pen.Color := clRed; + Canvas.Pen.Width := 1; + + l := (cr.Left div 2) * 2; + if (l mod 4)=0 then o := 2 else o := 0; + + Canvas.MoveTo(l,r.Bottom + o - 1); + while l < cr.Right do + begin + if o = 2 then o := 0 else o := 2; + Canvas.LineTo(l + 2,r.bottom + o - 1); + Inc(l,2); + end; + // if o = 2 then o := 0 else o := 2; + // Canvas.LineTo(l + 2,r.Bottom + o - 1); + end; + + cr.Left := cr.Right; + cr.Right := r.Right; + cr.Bottom := r.Bottom; + cr.Top := r.Top; + end + else + begin + cr := r; //reinitialized each time ! + {$IFNDEF TMSDOTNET} + DrawTextEx(Canvas.Handle,PChar(su),WordLenEx,cr,DrawStyle or DT_CALCRECT,nil); + {$ENDIF} + + {$IFDEF TMSDOTNET} + DrawTextEx(Canvas.Handle,su,WordLenEx,cr,DrawStyle or DT_CALCRECT,nil); + {$ENDIF} + + // preparations for editing purposes + if (ypos > cr.Top) and (ypos < cr.bottom) and (xpos > w) then {scan charpos here} + begin + {$IFNDEF TMSDOTNET} + er := rect(w,cr.top,xpos,cr.bottom); + Fillchar(dtp,sizeof(dtp),0); + {$ENDIF} + + {$IFDEF TMSDOTNET} + er := Borland.Vcl.Types.rect(w,cr.top,xpos,cr.bottom); + {$ENDIF} + dtp.cbSize:=sizeof(dtp); + + {$IFDEF DELPHI4_LVL} + {$IFNDEF TMSDOTNET} + GetTextExtentExPoint(Canvas.Handle,pChar(su),WordLenEx,xpos-w,@nnfit,nil,nnSize); + {$ENDIF} + {$IFDEF TMSDOTNET} + GetTextExtentExPoint(Canvas.Handle,su,WordLenEx,xpos-w,nnfit,nil,nnSize); + {$ENDIF} + {$ELSE} + {$IFNDEF TMSDOTNET} + nndx := nil; {fix for declaration error in Delphi 3 WINDOWS.PAS} + GetTextExtentExPoint(Canvas.Handle,pChar(su),WordLenEx,xpos - w,nnfit,integer(nndx^),nnSize); + {$ENDIF} + {$IFDEF TMSDOTNET} + GetTextExtentExPoint(Canvas.Handle,su,WordLenEx,xpos - w,nnfit,nil,nnSize); + {$ENDIF} + {$ENDIF} + + {this will get the character pos of the insertion point} + if nnfit = WordLen then + InsPoint := InsPoint + WordLen + else + InsPoint := InsPoint + nnfit; + end; + {end of preparations for editing purposes} + + { Calculated text width } + WordWidth := cr.Right - cr.Left; + w := w + WordWidth; + + if (XPos - cr.Left >= w - WordWidth) and (XPos - cr.Left <= w) and Anchor then + begin + HotSpot := True; + if (YPos > cr.Top){ and (YPos < cr.Bottom)} then + begin + Anchorval := LastAnchor; + MouseInAnchor := True; + end; + end; + end; + + LengthFits := (w < r.Right - r.Left - OfsX) or (r.Right - r.Left - OfsX <= WordWidth); + + if not LengthFits and + ((Length(LineText) > 0) and (LineText[Length(LineText)] <> ' ')) then + LengthFits := True; + + LineText := LineText + su; + + if LengthFits or not WordWrap then + begin + Res := Res + Copy(s,1,WordLen); + + //if not LengthFits and Calc and (LineText <> su) then + // s := ''; + + Delete(s,1,WordLen); + + if Length(su) >= WordLen then + begin + {$IFNDEF TMSDOTNET} + if System.Copy(su, WordLen, 1) = ' ' then + {$ENDIF} + {$IFDEF TMSDOTNET} + if Copy(su, WordLen, 1) = ' ' then + {$ENDIF} + sw := Canvas.TextWidth(' ') + else + sw := 0; + end + else + sw := 0; + end + else + begin + LineBreak := True; + w := w - WordWidth; + end; + end; + end; + + TagPos := Pos('<',s); + + if (TagPos = 1) and (Length(s) <= 2) then + s := ''; + + if not LineBreak and (TagPos = 1) and (Length(s) > 2) then + begin + if (s[2] = '/') and (Length(s) > 3) then + begin + case UpCase(s[3]) of + 'A':begin + if (not HoverStyle or (Hoverlink = Hyperlinks)) and not Calc then + begin + Canvas.Font.Style := Canvas.Font.Style - [fsUnderline]; + if Hovercolor <> clNone then + begin + Canvas.Brush.Color := HvrColor; + if HvrColor = clNone then + Canvas.Brush.Style := bsClear; + end; + if HoverFontColor <> clNone then + Canvas.Font.Color := HoverFontColor; + end; + + if not Selected then + Canvas.Font.Color := Oldfont.Color; + + Anchor := False; + + if MouseInAnchor then + begin + hr.Bottom := r.Bottom; + hr.Right := r.Left + w; + if r.Top <> hr.Top then + begin + hr.Left := r.Left; + hr.Top := r.Top; + end; + + HoverRect := hr; + MouseLink := HyperLinks; + {$IFDEF TMSDEBUG} + DbgRect('hotspot anchor '+lastanchor,hr); + {$ENDIF} + MouseInAnchor := False; + end; + + if Focuslink = Hyperlinks - 1 then + begin + rr.Right := cr.Left; + rr.Bottom := cr.Bottom - ImgAli; + rr.Top := rr.Bottom - Canvas.TextHeight('gh'); + InflateRect(rr,1,0); + if not Calc then Canvas.DrawFocusRect(rr); + end; + end; + 'E':begin + if not Calc then + Error := False; + end; + 'B':begin + if s[4] <> '>' then + Canvas.Font.Color := OldFont.Color + else + Canvas.Font.Style := Canvas.Font.Style - [fsBold]; + end; + 'S':begin + TagChar := UpCase(s[4]); + + if (TagChar = 'U') then + begin + isSup := False; + isSub := False; + end + else + if (TagChar = 'H') then + isShad := False + else + Canvas.Font.Style := Canvas.Font.Style - [fsStrikeOut]; + end; + 'F':begin + Canvas.Font.Name := OldFont.Name; + Canvas.Font.Size := OldFont.Size; + if not Calc and not Selected then + begin + Canvas.Font.Color := OldFont.Color; + Canvas.Brush.Color := BGColor; + if BGColor = clNone then + begin + Canvas.Brush.Style := bsClear; + end; + end; + end; + 'H':begin + if not Calc then + begin + Canvas.Font.Color := hifCol; + Canvas.Brush.Color := hibCol; + if hibCol = clNone then + Canvas.Brush.Style := bsClear; + end; + end; + 'I':begin + Canvas.Font.Style := Canvas.Font.Style - [fsItalic]; + end; + 'L':begin + LineBreak := True; + end; + 'O':begin + NewOffsetX := 0; + end; + 'P':begin + LineBreak := True; + if not Calc then + begin + Canvas.Brush.Color := ParaColor; + if ParaColor = clNone then Canvas.Brush.Style := bsClear; + isPara := false; + end; + end; + 'U':begin + if (s[4] <> '>') and (ListIndex > 0) then + Dec(Listindex) + else + Canvas.Font.Style := Canvas.Font.Style - [fsUnderline]; + end; + 'R':begin + EndRotated(Canvas); + end; + 'Z':Invisible := False; + end; + end + else + begin + case Upcase(s[2]) of + 'A':begin + { only do this when at hover position in xpos,ypos } + if (FocusLink = HyperLinks) and not Calc then + begin + rr.Left := cr.Left; + rr.Top := cr.Top; + end; + + Inc(HyperLinks); + if (not HoverStyle or (Hoverlink = HyperLinks)) and not Calc then + begin + Canvas.Font.Style := Canvas.Font.Style + [fsUnderline]; + if (Hovercolor <> clNone) and not Calc then + begin + HvrColor := Canvas.Brush.Color; + + if Canvas.Brush.Style = bsClear then + HvrColor := clNone; + Canvas.Brush.Color := HoverColor; + end; + + if HoverFontColor <> clNone then + begin + hvrfntcolor := Canvas.Font.Color; + Canvas.Font.Color := HoverFontColor; + end; + end; + + if not Selected and ((HoverFontColor = clNone) or (HoverLink <> HyperLinks) or not HoverStyle) then + Canvas.Font.Color := URLColor; + + TagProp := Copy(s,3,Pos('>',s) - 1); // + Prop := Copy(TagProp,Pos('"',TagProp) + 1,Length(TagProp)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + LastAnchor := Prop; + Anchor := True; + + hr.Left := w; + hr.Top := r.Top; + end; + 'B':begin + TagChar := Upcase(s[3]); + case TagChar of + '>': Canvas.Font.Style := Canvas.Font.Style + [fsBold]; // tag + 'R': //
tag + begin + LineBreak := true; + StripVal := StripVal + #13; + end; + 'L': if not Blink then + Canvas.Font.Color := BlnkColor; // tag + 'O': + begin + Res := Res + Copy(s,1,pos('>',s)); + if not Calc and not Selected then + begin + TagProp := Uppercase(Copy(s,6,pos('>',s)-1)); + + if (Pos('BACKGROUND',TagProp) > 0) then + begin + Prop := Copy(TagProp,Pos('BACKGROUND',TagProp)+10,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop)+1,Length(prop)); + Prop := Copy(Prop,1,Pos('"',Prop)-1); + bmp := nil; + + if Pos('IDX:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 4); + if Assigned(FImages) and (IStrToInt(Prop) < FImages.Count) then + begin + IMGSize.X := MulDiv(FImages.Width, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(FImages.Height, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + + if not Calc and not Print then +{$IFDEF DELPHI4_LVL} + FImages.Draw(Canvas, CR.Left, CR.Top, IStrToInt(Prop), True); +{$ELSE} + FImages.Draw(Canvas, CR.Left, CR.Top, IStrToInt(Prop)); +{$ENDIF} + + if not Calc and Print then + begin + CR.Right := CR.Left + Round(resfactor * FImages.Width); + CR.Bottom := CR.Top + Round(resfactor * FImages.Height); + + ABitmap := TBitmap.Create; + FImages.GetBitmap(IStrToInt(Prop), ABitmap); + PrintBitmap(Canvas, CR, ABitmap); + ABitmap.Free; + CR := r; + end; + end; + end; + + if Pos('SSYS:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 5); + IMGSize := SysImage(Canvas, CR.Left, CR.Top, Prop, False, not Calc, Print, resfactor); + + IMGSize.X := MulDiv(IMGSize.X, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(IMGSize.Y, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + end; + + if Pos('LSYS:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 5); + IMGSize := SysImage(Canvas, CR.Left, CR.Top, Prop, True, not Calc, Print, resfactor); + + IMGSize.X := MulDiv(IMGSize.X, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(IMGSize.Y, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + end; + + bmp := nil; + + if (Pos(':',Prop) = 0) and Assigned(pc) then + begin + bmp := pc.FindPicture(Prop); + end; + + if (Pos('://',Prop) > 0) and Assigned(ic) then + begin + if ic.FindPicture(Prop) = nil then + with ic.AddPicture do + begin + Asynch := False; + LoadFromURL(Prop); + end; + bmp := ic.FindPicture(Prop); + end; + + if bmp <> nil then + begin + if not bmp.Empty and (bmp.Width > 0) and (bmp.Height > 0) then + begin + // do the tiling here + bmpy := 0; + hrgn := CreateRectRgn(fr.left, fr.top, fr.right,fr.bottom); + SelectClipRgn(Canvas.Handle, hrgn); + while (bmpy < fr.bottom-fr.top) do + begin + bmpx := 0; + while (bmpx < fr.right - fr.left) do + begin + Canvas.Draw(fr.left+bmpx,fr.top+bmpy,bmp); + bmpx := bmpx + bmp.width; + end; + bmpy := bmpy + bmp.height; + end; + SelectClipRgn(Canvas.handle, 0); + DeleteObject(hrgn); + end; + end; //end of bmp <> nil + end; //end of background + + if (Pos('BGTOPLEFT', TagProp) > 0) then + begin + Prop := Copy(TagProp, Pos('BGTOPLEFT', TagProp) + 10, Length(TagProp)); + Prop := Copy(Prop, Pos('"', Prop) + 1, Length(Prop)); + Prop := Copy(Prop, 1, Pos('"', Prop) - 1); + bmp := nil; + + if Pos('IDX:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 4); + if Assigned(FImages) and (IStrToInt(Prop) < FImages.Count) then + begin + IMGSize.X := MulDiv(FImages.Width, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(FImages.Height, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + + if not Calc and not Print then +{$IFDEF DELPHI4_LVL} + FImages.Draw(Canvas, CR.Left, CR.Top, IStrToInt(Prop), True); +{$ELSE} + FImages.Draw(Canvas, CR.Left, CR.Top, IStrToInt(Prop)); +{$ENDIF} + + if not Calc and Print then + begin + CR.Right := CR.Left + Round(resfactor * FImages.Width); + CR.Bottom := CR.Top + Round(resfactor * FImages.Height); + + ABitmap := TBitmap.Create; + FImages.GetBitmap(IStrToInt(Prop), ABitmap); + PrintBitmap(Canvas, CR, ABitmap); + ABitmap.Free; + CR := r; + end; + end; + end; + + if Pos('SSYS:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 5); + IMGSize := SysImage(Canvas, CR.Left, CR.Top, Prop, False, not Calc, Print, resfactor); + + IMGSize.X := MulDiv(IMGSize.X, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(IMGSize.Y, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + end; + + if Pos('LSYS:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 5); + IMGSize := SysImage(Canvas, CR.Left, CR.Top, Prop, True, not Calc, Print, resfactor); + + IMGSize.X := MulDiv(IMGSize.X, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(IMGSize.Y, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + end; + + bmp := nil; + + if (Pos(':', Prop) = 0) and Assigned(pc) then + begin + bmp := pc.FindPicture(Prop); + end; + + if (Pos('://', Prop) > 0) and Assigned(iC) then + begin + if iC.FindPicture(Prop) = nil then + with iC.AddPicture do + begin + ASYNCH := False; + LoadFromURL(Prop); + end; + bmp := iC.FindPicture(Prop); + end; + + if bmp <> nil then + begin + if not bmp.Empty and (bmp.Width > 0) and (bmp.Height > 0) then + begin + // do the tiling here + bmpy := 0; + HRgn := CreateRectRgn(fr.Left, fr.Top, fr.Right, fr.Bottom); + SelectClipRgn(Canvas.Handle, HRgn); + if (bmpy < fr.Bottom - fr.Top) then + begin + bmpx := 0; + if (bmpx < fr.Right - fr.Left) then + begin + Canvas.Draw(fr.Left + bmpx, fr.Top + bmpy, bmp); + bmpx := bmpx + bmp.Width; + end; + bmpy := bmpy + bmp.Height; + end; + SelectClipRgn(Canvas.Handle, 0); + DeleteObject(HRgn); + end; + end; //end of bmp <> nil + end; //end of bgtopleft + + if (Pos('BGTOPRIGHT', TagProp) > 0) then + begin + Prop := Copy(TagProp, Pos('BGTOPRIGHT', TagProp) + 10, Length(TagProp)); + Prop := Copy(Prop, Pos('"', Prop) + 1, Length(Prop)); + Prop := Copy(Prop, 1, Pos('"', Prop) - 1); + bmp := nil; + + if Pos('IDX:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 4); + if Assigned(FImages) and (IStrToInt(Prop) < FImages.Count) then + begin + IMGSize.X := MulDiv(FImages.Width, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(FImages.Height, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + + if not Calc and not Print then +{$IFDEF DELPHI4_LVL} + FImages.Draw(Canvas, CR.Right - FImages.Width, CR.Top, IStrToInt(Prop), True); +{$ELSE} + FImages.Draw(Canvas, CR.Right - FImages.Width, CR.Top, IStrToInt(Prop)); +{$ENDIF} + + if not Calc and Print then + begin + CR.Right := CR.Left + Round(resfactor * FImages.Width); + CR.Bottom := CR.Top + Round(resfactor * FImages.Height); + + ABitmap := TBitmap.Create; + FImages.GetBitmap(IStrToInt(Prop), ABitmap); + PrintBitmap(Canvas, CR, ABitmap); + ABitmap.Free; + CR := r; + end; + end; + end; + + if Pos('SSYS:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 5); + IMGSize := SysImage(Canvas, CR.Right - FImages.Width, CR.Top, Prop, False, not Calc, Print, resfactor); + + IMGSize.X := MulDiv(IMGSize.X, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(IMGSize.Y, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + end; + + if Pos('LSYS:', UpperCase(Prop)) > 0 then + begin + Delete(Prop, 1, 5); + IMGSize := SysImage(Canvas, CR.Right - FImages.Width, CR.Top, Prop, True, not Calc, Print, resfactor); + + IMGSize.X := MulDiv(IMGSize.X, GetDeviceCaps(Canvas.Handle, LOGPIXELSX), 96); + IMGSize.Y := MulDiv(IMGSize.Y, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 96); + end; + + bmp := nil; + + if (Pos(':', Prop) = 0) and Assigned(pc) then + begin + bmp := pc.FindPicture(Prop); + end; + + if (Pos('://', Prop) > 0) and Assigned(iC) then + begin + if iC.FindPicture(Prop) = nil then + with iC.AddPicture do + begin + ASYNCH := False; + LoadFromURL(Prop); + end; + bmp := iC.FindPicture(Prop); + end; + + if bmp <> nil then + begin + if not bmp.Empty and (bmp.Width > 0) and (bmp.Height > 0) then + begin + // do the printing here + bmpy := 0; + HRgn := CreateRectRgn(fr.Left, fr.Top, fr.Right, fr.Bottom); + SelectClipRgn(Canvas.Handle, HRgn); + if (bmpy < fr.Bottom - fr.Top) then + begin + bmpx := 0; + if (bmpx < fr.Right - fr.Left) then + begin + Canvas.Draw(fr.Right - bmp.Width, fr.Top + bmpy, bmp); + bmpx := bmpx + bmp.Width; + end; + bmpy := bmpy + bmp.Height; + end; + SelectClipRgn(Canvas.Handle, 0); + DeleteObject(HRgn); + end; + end; //end of bmp <> nil + end; //end of bgtopright + + if VarPos('BGCOLOR',TagProp,TagPos) > 0 then + begin + Prop := Copy(TagProp,TagPos + 5,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + + NewColor := clNone; + + if Length(Prop) > 0 then + begin + if Prop[1] = '#' then + NewColor := Hex2Color(Prop) + else + NewColor := Text2Color(AnsiLowerCase(prop)); + end; + + if VarPos('BGCOLORTO',TagProp,TagPos) > 0 then + begin + Prop := Copy(TagProp,TagPos + 5,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + NewColorTo := clNone; + + if Length(Prop) > 0 then + begin + if Prop[1] = '#' then + NewColorTo := Hex2Color(Prop) + else + NewColorTo := Text2Color(AnsiLowerCase(prop)); + end; + + Prop := 'H'; + if VarPos('DIR',TagProp,TagPos) > 0 then + begin + Prop := Copy(TagProp,TagPos + 3,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + end; + + Canvas.Pen.Color := Newcolor; + {$IFNDEF TMSDOTNET} + DrawHTMLGradient(Canvas,NewColor,NewColorTo,clNone,64,Rect(fr.left,fr.top,fr.right,fr.bottom),Prop = 'H'); + {$ENDIF} + {$IFDEF TMSDOTNET} + DrawHTMLGradient(Canvas,NewColor,NewColorTo,clNone,64,Borland.Vcl.Types.Rect(fr.left,fr.top,fr.right,fr.bottom),Prop = 'H'); + {$ENDIF} + Canvas.Brush.Style := bsClear + end + else + begin + BGColor := Canvas.Brush.Color; + Canvas.Brush.color := NewColor; + PenColor:=Canvas.Pen.Color; + Canvas.Pen.Color := Newcolor; + Canvas.Rectangle(fr.left - 2,fr.top,fr.right,fr.bottom); + Canvas.Pen.Color := PenColor; + end; + end; + end; + end; + end; + end; + 'E':begin + if not Calc then + Error := True; + end; + 'H':begin + case Upcase(s[3]) of + 'R': + begin + LineBreak := True; + if not Calc then + begin + Pencolor := Canvas.Pen.color; + Canvas.Pen.color:=clblack; + Canvas.MoveTo(r.left,cr.bottom+1); + Canvas.Lineto(r.right,cr.bottom+1); + Canvas.pen.color:=pencolor; + end; + end; + 'I': + begin + if not Calc then + begin + hifCol := Canvas.Font.Color; + hibCol := Canvas.Brush.Color; + if Canvas.Brush.Style = bsClear then + hibCol := clNone; + + Canvas.Brush.Color := clHighLight; + Canvas.Font.Color := clHighLightText; + end; + end; + end; + end; + 'I':begin + TagChar := Upcase(s[3]); + + if TagChar = '>' then // tag + Canvas.Font.Style := Canvas.Font.Style + [fsItalic] + else + if TagChar = 'N' then // tag + begin + TagProp := Copy(s,3,pos('>',s) - 1); + + Prop := Copy(TagProp,ipos('x',TagProp) + 2,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + + val(Prop,indent,err); + if err = 0 then + begin + if indent > w then + begin + w := Indent; + cr.left := fr.left + Indent; + end; + end; + end + else + if TagChar = 'M' then + begin + inc(ImgIdx); + + TagProp := Copy(s,3,Pos('>',s) - 1); + Prop := Copy(TagProp,Pos('SRC',Uppercase(TagProp)) + 4,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + + TagProp := Uppercase(TagProp); + + if (Pos('ALT',TagProp) > 0) and (AltImg = ImgIdx) then + begin + Prop := Copy(TagProp,Pos('ALT',TagProp) + 4,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + end; + + TagWidth := 0; + TagHeight := 0; + + if Pos('WIDTH',TagProp) > 0 then + begin + Tagp := Copy(TagProp,Pos('WIDTH',TagProp) + 6,Length(TagProp)); + Tagp := Copy(Tagp,Pos('"',tagp) + 1,Length(Tagp)); + Tagp := Copy(Tagp,1,Pos('"',tagp) - 1); + Val(Tagp,TagWidth,Err); + end; + + if Pos('HEIGHT',TagProp) > 0 then + begin + Tagp := Copy(TagProp,ipos('HEIGHT',TagProp) + 7,Length(TagProp)); + Tagp := Copy(Tagp,pos('"',Tagp) + 1,Length(Tagp)); + Tagp := Copy(Tagp,1,pos('"',Tagp) - 1); + Val(Tagp,TagHeight,Err); + end; + + IMGSize.x := 0; + IMGSize.y := 0; + + if Pos('IDX:',Uppercase(Prop)) > 0 then + begin + Delete(Prop,1,4); + if Assigned(FImages) and (IStrToInt(Prop) < FImages.Count) then + begin + IMGSize.x := MulDiv(FImages.Width,GetDeviceCaps(Canvas.Handle,LOGPIXELSX),96); + IMGSize.y := MulDiv(FImages.Height,GetDeviceCaps(Canvas.Handle,LOGPIXELSY),96); + + if not Calc and not Print then + {$IFDEF DELPHI4_LVL} + FImages.Draw(Canvas,cr.Left,cr.Top,IStrToInt(Prop),True); + {$ELSE} + FImages.Draw(Canvas,cr.Left,cr.Top,IStrToInt(Prop)); + {$ENDIF} + + if not Calc and Print then + begin + cr.Right := cr.Left + Round(ResFactor * FImages.Width); + cr.Bottom := cr.Top + Round(ResFactor * FImages.Height); + + ABitmap := TBitmap.Create; + FImages.GetBitmap(IStrToInt(Prop),ABitmap); + PrintBitmap(Canvas,cr,ABitmap); + ABitmap.Free; + cr := r; + end; + end; + end; + + if Pos('SSYS:',Uppercase(Prop)) > 0 then + begin + Delete(Prop,1,5); + IMGSize := SysImage(Canvas,cr.Left,cr.Top,Prop,False,not Calc,Print,ResFactor); + + IMGSize.x := MulDiv(IMGSize.X,GetDeviceCaps(Canvas.Handle,LOGPIXELSX),96); + IMGSize.y := MulDiv(IMGSize.Y,GetDeviceCaps(Canvas.Handle,LOGPIXELSY),96); + end; + + if Pos('LSYS:',Uppercase(Prop)) > 0 then + begin + Delete(Prop,1,5); + IMGsize := SysImage(Canvas,cr.Left,cr.Top,Prop,True,not Calc,Print,ResFactor); + + IMGSize.x := MulDiv(IMGSize.X,GetDeviceCaps(Canvas.Handle,LOGPIXELSX),96); + IMGSize.y := MulDiv(IMGSize.Y,GetDeviceCaps(Canvas.Handle,LOGPIXELSY),96); + end; + + bmp := nil; + + if (Pos(':',Prop) = 0) and Assigned(pc) then + begin + bmp := pc.FindPicture(Prop); + end; + + if (Pos('://',Prop) > 0) and Assigned(ic) then + begin + if ic.FindPicture(Prop) = nil then + with ic.AddPicture do + begin + Asynch := False; + LoadFromURL(Prop); + end; + + bmp := ic.FindPicture(Prop); + end; + + if bmp <> nil then + begin + if not bmp.Empty then + begin + if not Calc {and not Print} then + begin + if (TagWidth > 0) and (TagHeight > 0) then + begin + bmp.Stretch := True; + {$IFNDEF TMSDOTNET} + Canvas.StretchDraw(Rect(cr.Left,cr.Top,cr.Left + TagWidth,cr.Top + TagHeight),bmp) + {$ENDIF} + {$IFDEF TMSDOTNET} + Canvas.StretchDraw(Borland.Vcl.Types.Rect(cr.Left,cr.Top,cr.Left + TagWidth,cr.Top + TagHeight),bmp) + {$ENDIF} + end + else + begin + + // need for animation - redraw background + if bmp.FrameCount > 1 then + begin + //Canvas.Pen.Color := BlnkColor; + //Canvas.Brush.Color := BlnkColor; + //Canvas.Rectangle(cr.Left,cr.Top,cr.Left + bmp.MaxWidth,cr.Top+bmp.MaxHeight); + end; + + Canvas.Draw(cr.Left + bmp.FrameXPos,cr.Top + bmp.FrameYPos,bmp); + end; + end; + + if (TagWidth > 0) and (TagHeight > 0) then + begin + IMGSize.x := MulDiv(TagWidth,GetDeviceCaps(Canvas.Handle,LOGPIXELSX),96); + IMGSize.y := MulDiv(TagHeight,GetDeviceCaps(Canvas.Handle,LOGPIXELSY),96); + end + else + begin + IMGSize.x := MulDiv(bmp.MaxWidth,GetDeviceCaps(Canvas.Handle,LOGPIXELSX),96); + IMGSize.y := MulDiv(bmp.MaxHeight,GetDeviceCaps(Canvas.Handle,LOGPIXELSY),96); + end; + end; + end; + + if (XPos - r.Left > w) and (XPos - r.Left < w + IMGSize.x) and + (YPos > cr.Top) and (YPos < cr.Top + IMGSize.Y) and Anchor then + begin + ImageHotSpot := True; + AnchorVal := LastAnchor; + AltImg := ImgIdx; + end; + + if Print then + begin + //IMGSize.x := Round(IMGSize.x * ResFactor); + //IMGSize.y := Round(IMGSize.y * ResFactor); + {$IFDEF TMSDEBUG} + DbgPoint('bmp : ',point(IMGSize.x,IMGSize.y)); + {$ENDIF} + end; + + oldh := h; + + if (w + IMGSize.x > r.Right-r.Left) and + (IMGSize.x < r.Right - r.Left) then + begin + ImgBreak := True; + end + else + begin + w := w + IMGSize.x; + cr.left := cr.left + IMGSize.x; + if IMGSize.y > h then + h := IMGSize.y; + end; + + if Pos('ALIGN',TagProp) > 0 then + begin + if Pos('"TOP',TagProp) > 0 then + begin + ImgAli := h - Canvas.TextHeight('gh'); + end + else + begin + if Pos('"MIDDLE',TagProp) > 0 then + ImgAli := (h - Canvas.TextHeight('gh')) shr 1; + end; + end; + + if (Pos('WRAP',TagProp) > 0) then + begin + h := Canvas.TextHeight('gh'); + ImgAli := 0; + end; + end; + end; + 'L':begin + w := w + 12 * ListIndex; + if Linkbreak then + Imgbreak := True else Linkbreak := True; + + cr.left := cr.left + 12 * (ListIndex - 1); + if not calc and not Invisible then + begin + Prop := Canvas.Font.Name; + Canvas.Font.Name := 'Symbol'; + + if Odd(ListIndex) then + DrawText(Canvas.Handle,'·',1,cr,0) + else + DrawText(Canvas.Handle,'o',1,cr,0); + + Canvas.Font.Name := prop; + end; + cr.Left := cr.Left + 12; + end; + 'U':begin + if s[3] <> '>' then + begin + Inc(ListIndex); + LineBreak := true; + end + else + Canvas.Font.Style := Canvas.Font.Style + [fsUnderline]; + end; + 'O':begin + TagChar := Upcase(s[3]); + if TagChar = 'F' then // tag + begin + TagProp := Copy(s,3,pos('>',s) - 1); + Prop := Copy(TagProp,ipos('x',TagProp) + 2,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + val(Prop,NewOffsetX,err); + cr.Left := NewOffsetX; + w := NewOffsetX; + end + end; + 'P':begin + if (VarPos('>',s,TagPos)>0) then + begin + TagProp := Uppercase(Copy(s,3,TagPos-1)); + + if VarPos('ALIGN',TagProp,TagPos) > 0 then + begin + Prop := Copy(TagProp,TagPos+5,Length(TagProp)); + Prop := Copy(Prop,Pos('"',prop)+1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',prop)-1); + + if Pos('RIGHT',Prop) > 0 then Align := taRightJustify; + if Pos('LEFT',Prop) > 0 then Align := taLeftJustify; + if Pos('CENTER',Prop) > 0 then Align := taCenter; + end; + + if VarPos('INDENT',TagProp,TagPos) > 0 then + begin + Prop := Copy(TagProp,TagPos+6,Length(TagProp)); + Prop := Copy(Prop,Pos('"',prop)+1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',prop)-1); + PIndent := IStrToInt(Prop); + end; + + if VarPos('BGCOLOR',TagProp,TagPos) > 0 then + begin + Prop := Copy(TagProp,TagPos + 5,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + + NewColor := clNone; + + if Length(Prop) > 0 then + begin + if Prop[1] = '#' then + NewColor := Hex2Color(Prop) + else + NewColor := Text2Color(AnsiLowerCase(prop)); + end; + + if VarPos('BGCOLORTO',TagProp,TagPos) > 0 then + begin + Prop := Copy(TagProp,TagPos + 5,Length(TagProp)); + Prop := Copy(Prop,Pos('"',Prop) + 1,Length(Prop)); + Prop := Copy(Prop,1,Pos('"',Prop) - 1); + NewColorTo := clNone; + + if Length(Prop) > 0 then + begin + if Prop[1] = '#' then + NewColorTo := Hex2Color(Prop) + else + NewColorTo := Text2Color(AnsiLowerCase(prop)); + end; + if not Calc then + begin + isPara := True; + Canvas.Pen.Color := Newcolor; + {$IFNDEF TMSDOTNET} + DrawHTMLGradient(Canvas,NewColor,NewColorTo,clNone,64,Rect(fr.left,r.top,fr.right,r.bottom+2),true); + {$ENDIF} + {$IFDEF TMSDOTNET} + DrawHTMLGradient(Canvas,NewColor,NewColorTo,clNone,64,Borland.Vcl.Types.Rect(fr.left,r.top,fr.right,r.bottom+2),true); + {$ENDIF} + Canvas.Brush.Style := bsClear + end; + end + else + begin + if not Calc then + begin + isPara := True; + paracolor := Canvas.Brush.Color; + if Canvas.Brush.Style = bsClear then ParaColor := clNone; + Canvas.Brush.color := NewColor; + PenColor:=Canvas.Pen.Color; + Canvas.Pen.Color := Newcolor; + Canvas.Rectangle(fr.left,r.top,fr.right,r.bottom); + end; + end; + end; + end; + end; + 'F':begin + if (VarPos('>',s,TagPos)>0) then + begin + TagProp := UpperCase(Copy(s,6,TagPos-6)); + + if (VarPos('FACE',TagProp,TagPos) > 0) then + begin + Prop := Copy(TagProp,TagPos+4,Length(TagProp)); + Prop := Copy(prop,pos('"',prop)+1,Length(prop)); + Prop := Copy(prop,1,pos('"',prop)-1); + Canvas.Font.Name := Prop; + end; + + if (VarPos(' COLOR',TagProp,TagPos) > 0) and not Selected then + begin + Prop := Copy(TagProp,TagPos+6,Length(TagProp)); + Prop := Copy(Prop,Pos('"',prop)+1,Length(prop)); + Prop := Copy(Prop,1,Pos('"',prop)-1); + //oldfont.color:=Canvas.font.color; + + if Length(Prop) > 0 then + begin + if Prop[1] = '#' then + Canvas.font.color := Hex2Color(Prop) + else + Canvas.Font.Color := Text2Color(AnsiLowerCase(prop)); + end; + + end; + + if (VarPos('BGCOLOR',TagProp,TagPos)>0) and not Calc and not Selected then + begin + Prop := Copy(TagProp,TagPos+7,Length(TagProp)); + Prop := Copy(prop,pos('"',prop)+1,Length(prop)); + Prop := Copy(prop,1,pos('"',prop)-1); + BGColor := Canvas.Brush.Color; + + if Canvas.Brush.Style = bsClear then + bgcolor := clNone; + + if Length(Prop) > 0 then + begin + if Prop[1] = '#' then + Canvas.Brush.Color := Hex2Color(Prop) + else + Canvas.Brush.Color := Text2Color(AnsiLowerCase(prop)); + end; + + end; + + if (VarPos('SIZE',TagProp,TagPos)>0) then + begin + Prop := Copy(TagProp,TagPos+4,Length(TagProp)); + Prop := Copy(Prop,Pos('=',Prop)+1,Length(Prop)); + Prop := Copy(Prop,Pos('"',Prop)+1,Length(Prop)); + + case IStrToInt(Prop) of + 1:Canvas.Font.Size := 8; + 2:Canvas.Font.Size := 10; + 3:Canvas.Font.Size := 12; + 4:Canvas.Font.Size := 14; + 5:Canvas.Font.Size := 16; + else + Canvas.Font.Size := IStrToInt(Prop); + end; + + end; + end; + end; + 'S':begin + TagChar := Upcase(s[3]); + + if TagChar = '>' then + Canvas.Font.Style := Canvas.font.Style + [fsStrikeOut] + else + begin + if TagChar = 'H' then + isShad := True + else + begin + if ipos('',s)=1 then + isSub := True + else + if ipos('',s)=1 then + isSup := True; + end; + end; + end; + 'R':begin + TagProp := Copy(s,3,pos('>',s)-1); + prop := Copy(TagProp,ipos('a',TagProp)+2,Length(TagProp)); + prop := Copy(prop,pos('"',prop)+1,Length(prop)); + prop := Copy(prop,1,pos('"',prop)-1); + Val(prop,Indent,err); + StartRotated(Canvas,indent); + end; + 'Z':Invisible := True; + end; + end; + + if (VarPos('>',s,TagPos)>0) and not ImgBreak then + begin + Res := Res + Copy(s,1,TagPos); + Delete(s,1,TagPos); + end + else + if not Imgbreak then + Delete(s,1,Length(s)); + end; + end; + + w := w - sw; + + if w > xsize then + xsize := w + 2; + + if (FocusLink = Hyperlinks - 1) and Anchor and not Calc then + begin + rr.Right := cr.Left; + rr.Bottom := cr.Bottom; + InflateRect(rr,1,0); + if not Calc then + Canvas.DrawFocusRect(rr); + rr.Left := r.Left + 1; + rr.Top := rr.Bottom; + end; + + Result := Res; + end; + + +begin + Anchor := False; + Error := False; + OldFont := TFont.Create; + OldFont.Assign(Canvas.Font); + DrawFont := TFont.Create; + DrawFont.Assign(Canvas.Font); + CalcFont := TFont.Create; + CalcFont.Assign(Canvas.Font); + OldDrawfont := TFont.Create; + OldDrawFont.Assign(Canvas.Font); + OldCalcFont := TFont.Create; + OldCalcFont.Assign(Canvas.Font); + BlnkColor := Canvas.Brush.color; + Canvas.Brush.Color := clNone; + BGColor := clNone; + ParaColor := clNone; + isPara := False; + isShad := False; + Invisible := False; + + OfsX := 0; + NewOfsX := 0; + + Result := False; + + r := fr; + r.Left := r.Left + 1; {required to add offset for DrawText problem with first capital W letter} + + Align := taLeftJustify; + PIndent := 0; + + XSize := 0; + YSize := 0; + HyperLinks := 0; + HlCount := 0; + ListIndex := 0; + LiCount := 0; + StripVal := ''; + FocusAnchor := ''; + MouseLink := -1; + MouseInAnchor := False; + + ImgIdx := 0; + AltImg := -1; + + SetBKMode(Canvas.Handle,TRANSPARENT); + + DrawStyle := DT_LEFT or DT_SINGLELINE or DT_EXTERNALLEADING or DT_BOTTOM or DT_EXPANDTABS; // or DT_NOPREFIX; + + if Pos(' & ',s) > 0 then + DrawStyle := DrawStyle or DT_NOPREFIX; + + + if not WordWrap then + DrawStyle := DrawStyle or DT_END_ELLIPSIS; + + if Pos('&',s) > 0 then + begin + repeat + Foundtag := False; + //if TagReplacestring('<','<',s) then Foundtag := True; + //if TagReplacestring('>','>',s) then Foundtag := True; + + if TagReplacestring('&','&&',s) then Foundtag := True; + if TagReplacestring('"','"',s) then Foundtag := True; + + if TagReplacestring('§','§',s) then Foundtag := True; + if TagReplacestring('‰','®‰',s) then Foundtag := True; + if TagReplacestring('®','®',s) then Foundtag := True; + + if TagReplacestring('©','©',s) then Foundtag := True; + if TagReplacestring('¶','¶',s) then Foundtag := True; + + if TagReplacestring('™','™',s) then Foundtag := True; + if TagReplacestring('€','€',s) then Foundtag := True; + + until not Foundtag; + end; + + s := DBTagStrip(s); + s := CRLFStrip(s,True); + + InsPoint := 0; + + while Length(s) > 0 do + begin + {calculate part of the HTML text fitting on the next line} + Oldfont.Assign(OldCalcFont); + Canvas.Font.Assign(CalcFont); + Oldanchor := Anchor; + OldAnchorVal := LastAnchor; + suph := 0; + subh := 0; + imgali := 0; + isSup := False; + isSub := False; + + HtmlHeight := Canvas.TextHeight('gh'); + txtHeight := HtmlHeight; + + OldImgIdx := ImgIdx; + + su := HTMLDrawLine(Canvas,s,r,True,HtmlWidth,HtmlHeight,subh,suph,imgali,Align,PIndent,XPos,YPos,HotSpot,ImageHotSpot,ofsx,newofsx); + + Anchor := OldAnchor; + LastAnchor := OldAnchorVal; + + CalcFont.Assign(Canvas.Font); + OldCalcFont.Assign(OldFont); + + HTMLHeight := HTMLHeight + LineSpacing; + + dr := r; + + case Align of + taCenter:if (r.right - r.left - htmlwidth > 0) then + dr.left := r.left+((r.right - r.left - htmlwidth) shr 1); + taRightJustify:if r.right - htmlwidth > r.left then + dr.left := r.right - htmlwidth; + end; + + dr.Left := dr.Left + PIndent; + + dr.Bottom := dr.Top + HtmlHeight + Subh + Suph; + + if not CheckHeight then + begin + OldFont.Assign(OldDrawFont); + Canvas.Font.Assign(DrawFont); + + HyperLinks := HlCount; + ListIndex := LiCount; + ImgIdx := OldImgIdx; + + HTMLDrawLine(Canvas,su,dr,CheckHotSpot,HtmlWidth,HtmlHeight,subh,suph,ImgAli,Align,PIndent,XPos,YPos,HotSpot,ImageHotspot,ofsx,newofsx); + + HlCount := HyperLinks; + LiCount := ListIndex; + + if (HotSpot and + (YPos > dr.Bottom - ImgAli - Canvas.TextHeight('gh')) and + (YPos < dr.Bottom - ImgAli)) or ImageHotSpot then + begin + Result := True; + end; + + ofsx := newofsx; + + DrawFont.Assign(Canvas.Font); + OldDrawFont.Assign(OldFont); + end; + + r.top := r.top + HtmlHeight + subh + suph; + ysize := ysize + HtmlHeight + subh + suph; + + {do not draw below bottom} + if (r.top + TxtHeight > r.bottom) and not CheckHeight then + s := ''; + end; + + if (ysize = 0) then + ysize := Canvas.TextHeight('gh'); + + //ysize := ysize + 2; + + InsPoint := InsPoint shr 1; + + Canvas.Brush.Color := BlnkColor; + Canvas.Font.Assign(OldFont); + OldFont.Free; + DrawFont.Free; + CalcFont.Free; + OldDrawfont.Free; + OldCalcfont.Free; +end; +{$WARNINGS ON} + +{$IFNDEF REMOVEDRAW} +function HTMLDraw(Canvas:TCanvas;s:string;fr:trect; + FImages:TImageList; + xpos,ypos:integer; + checkhotspot,checkheight,print,selected,blink:boolean; + resfactor:double; + URLColor:tcolor; + var Anchorval,StripVal:string; + var XSize,YSize:integer):boolean; +var + HyperLinks,MouseLink: Integer; + Focusanchor: string; + r: TRect; +begin + Result := HTMLDrawEx(Canvas,s,fr,FImages,xpos,ypos,-1,-1,1,checkhotspot,checkheight,print,selected,blink,false, + False,resfactor,URLColor,clNone,clNone,clGray,anchorval,stripval,focusanchor,xsize,ysize,HyperLinks,MouseLink,r,nil,nil,0); +end; + +{$IFNDEF REMOVEIPOSFROM} +function IPosFrom(su,s:string;frm:integer):Integer; +var + i:Integer; +begin + i := Pos(UpperCase(su),UpperCase(s)); + if i > frm then + Result := i + else + Result := 0; +end; +{$ENDIF} + +{$ENDIF} + + +{$IFNDEF DELPHI4_LVL} +function StringReplace(const S, OldPattern, NewPattern: string): string; +var + SearchStr, Patt, NewStr: string; + Offset: Integer; +begin + SearchStr := S; + Patt := OldPattern; + + NewStr := S; + Result := ''; + while SearchStr <> '' do + begin + {$IFDEF DELPHI3_LVL} + Offset := AnsiPos(Patt, SearchStr); + {$ELSE} + Offset := Pos(Patt, SearchStr); + {$ENDIF} + + if Offset = 0 then + begin + Result := Result + NewStr; + Break; + end; + Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; + NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); + Result := Result + NewStr; + Break; + end; +end; +{$ENDIF} + +{$IFNDEF REMOVESTRIP} + +function HTMLStrip(s:string):string; +var + TagPos: integer; +begin + Result := ''; + // replace line breaks by linefeeds + {$IFNDEF DELPHI4_LVL} + while (pos('
',uppercase(s))>0) do s := StringReplace(s,'
',chr(13)+chr(10)); + while (pos('
',uppercase(s))>0) do s := StringReplace(s,'
',chr(13)+chr(10)); + while (pos('
',uppercase(s))>0) do s := StringReplace(s,'
',chr(13)+chr(10)); + while (pos('
',uppercase(s))>0) do s := StringReplace(s,'
',chr(13)+chr(10)); + {$ELSE} + while (pos('
',uppercase(s))>0) do s := StringReplace(s,'
',chr(13)+chr(10),[rfIgnoreCase]); + while (pos('
',uppercase(s))>0) do s := StringReplace(s,'
',chr(13)+chr(10),[rfIgnoreCase]); + {$ENDIF} + + while (VarPos('',s,TagPos) > 0) do + begin + Result := Result + Copy(s,1,TagPos - 1); // copy till Z tag + if (VarPos('',s,TagPos) > 0) then + Delete(s,1,TagPos + 3) + else + Break; + end; + + while (VarPos('',s,TagPos) > 0) do + begin + Result := Result + Copy(s,1,TagPos - 1); // copy till Z tag + if (VarPos('',s,TagPos) > 0) then + Delete(s,1,TagPos + 3) + else + Break; + end; + + + // remove all other tags + while (VarPos('<',s,TagPos) > 0) do + begin + Result := Result + Copy(s,1,TagPos - 1); + if (VarPos('>',s,TagPos)>0) then + Delete(s,1,TagPos) + else + Break; + end; + Result := Result + s; +end; +{$ENDIF} + +{$IFDEF HILIGHT} + +function HTMLStripAll(s:string):string; +var + TagPos: integer; +begin + Result := ''; + + // remove all tags + while (VarPos('<',s,TagPos)>0) do + begin + Result := Result + Copy(s,1,TagPos-1); + if (VarPos('>',s,TagPos)>0) then + Delete(s,1,TagPos); + end; + Result := Result + s; +end; + +function StripPos2HTMLPos(s:string; i: Integer): Integer; +var + j,k: Integer; + Skip: Boolean; +begin + Result := 0; + k := 1; + Skip := False; + + for j := 1 to Length(s) do + begin + if s[j] = '<' then + Skip := True; + + if k = i then + begin + Result := j; + Exit; + end; + + if not Skip then + Inc(k); + + if s[j] = '>' then + Skip := False; + + end; + + if k = i then + begin + Result := Length(s) + 1; + end; +end; + + +function PosFrom(su,s:string; h: Integer;DoCase: boolean; var Res: Integer): Integer; +var + r: Integer; +begin + Result := 0; + Res := 0; + + if h > 0 then + Delete(s,1,h); + + if DoCase then + r := Pos(su,s) + else + r := Pos(UpperCase(su),UpperCase(s)); + + if r > 0 then + begin + Res := h + r; + Result := Res; + end; +end; + +function HiLight(s,h,tag:string;DoCase:boolean):string; +var + hs: string; + l,k: Integer; +begin + hs := HTMLStripAll(s); + + l := 0; + + while PosFrom(h,hs,l,DoCase,k) > 0 do + begin + l := k + Length(h); + Insert('<'+tag+'>',s,StripPos2HTMLPos(s,k)); + Insert('',s,StripPos2HTMLPos(s,l)); + end; + + Result := s; +end; + +function UnHiLight(s,tag:string):string; +begin + Result := ''; + // replace line breaks by linefeeds + {$IFNDEF DELPHI4_LVL} + while Pos('<'+tag+'>',s) > 0 do s := StringReplace(s,'<'+tag+'>',''); + while Pos('',s) > 0 do s := StringReplace(s,'',''); + tag := Uppercase(tag); + while Pos('<'+tag+'>',s) > 0 do s := StringReplace(s,'<'+tag+'>',''); + while Pos('',s) > 0 do s := StringReplace(s,'',''); + {$ELSE} + tag := Uppercase(tag); + while Pos('<'+tag+'>',Uppercase(s)) > 0 do s := StringReplace(s,'<'+tag+'>','',[rfIgnoreCase]); + while Pos('',Uppercase(s)) > 0 do s := StringReplace(s,'','',[rfIgnoreCase]); + {$ENDIF} + Result := s; +end; + +{$ENDIF} + +{$IFDEF PARAMS} + +function IPosv(su,s:string;var vp:integer):integer; +begin + vp := pos(UpperCase(su),UpperCase(s)); + Result := vp; +end; + + +function GetHREFValue(html,href:string;var value:string):boolean; +var + lp: Integer; +begin + Result := False; + while IPosv('href="',html,lp) > 0 do + begin + Delete(html,1,lp+5); {delete all before} + if IPosv('"',html,lp) > 0 then + begin + if CompareText(href,copy(html,1,lp-1))=0 then + begin + {href match - get the value now} + Delete(html,1,lp); + if (iposv('>',html,lp)>0) then + begin + Delete(html,1,lp); + if (iposv('<',html,lp)>0) then + begin + Value := Copy(html,1,lp-1); + Result := True; + Break; + end; + end; + end; + end; + end; +end; + + +function SetHREFValue(var html:string;href,value:string):boolean; +var + h:string; + p:string; +begin + {get current value and do a stringreplace} + + Result := False; + if GetHREFValue(html,href,h) then + begin + p := Copy(html,pos('href="' + href,html),Length(html)); + + {$IFNDEF DELPHI4_LVL} + p := StringReplace(p,'>' + h + '' + value + '' + h + '' + value + ' 0) then + begin + //manipulate the stream here for animated GIF ? + Gifstream := TMemoryStream.Create; + + ImgIdx := 1; + SkipImg := False; + + FDataStream.Position := 6; + FDataStream.Read(FAnimMaxX,2); + FDataStream.Read(FAnimMaxY,2); + + for i := 1 to FDataStream.Size do + begin + FDataStream.Position := i - 1; + FDataStream.Read(b,1); + + if (b = $21) and (i + 8 < FDataStream.Size) then + begin + FDataStream.Read(c,1); + FDataStream.Read(d,1); + FDataStream.Position := FDataStream.Position + 5; + + FDataStream.Read(e,1); + if (c = $F9) and (d = $4) and (e = $2C) then + begin + if imgidx = FFrame then + begin + FDataStream.Read(FFrameXPos,2); + FDataStream.Read(FFrameYPos,2); + FDataStream.Read(FFrameXSize,2); + FDataStream.Read(FFrameYSize,2); + end; + + Inc(ImgIdx); + if ImgIdx <= FFrame then + SkipImg := True + else + SkipImg := False; + end; + end; + if not SkipImg then GifStream.Write(b,1); + end; + GifStream.Position := 0; + GifStream.ReadBuffer(pvData^,GifStream.Size); + GifStream.Free; + end + else + begin + FDataStream.ReadBuffer(pvData^,fDataStream.Size); + end; + + GlobalUnlock(hGlobal); + + pstm := nil; + + // Create IStream* from global memory + hr := CreateStreamOnHGlobal(hGlobal, TRUE, pstm); + + if (not hr=S_OK) then + raise Exception.Create('Could not create image stream') + else + if (pstm = nil) then + raise Exception.Create('Empty image stream created'); + + // Create IPicture from image file + hr := OleLoadPicture(pstm, FDataStream.Size,FALSE,IID_IPicture,gpPicture); + + if not (hr = S_OK) then + raise Exception.Create('Could not load image. Invalid format') + else + if gpPicture = nil then + raise Exception.Create('Could not load image'); + + finally + GlobalFree(hGlobal); + end; + {$ENDIF} +end; + +procedure THTMLPicture.Draw(ACanvas: TCanvas; const Rect: TRect); +var + hmWidth:integer; + hmHeight:integer; + nPixX,nPixY:integer; + pnWidth,pnHeight:integer; + +begin + if Empty then Exit; + + if gpPicture = nil then Exit; + + hmWidth := 0; + hmHeight := 0; + gpPicture.get_Width(hmWidth); + gpPicture.get_Height(hmHeight); + + + if FStretched then + begin + gpPicture.Render(ACanvas.Handle,Rect.Left,Rect.Bottom,Rect.Right - Rect.Left,-(Rect.Bottom - Rect.Top),0,0, + hmWidth,hmHeight, Rect); + end + else + begin + nPixX := GetDeviceCaps(ACanvas.Handle,LOGPIXELSX); + nPixY := GetDeviceCaps(ACanvas.Handle,LOGPIXELSY); + //Convert to device units + pnWidth := MulDiv(hmWidth, nPixX, HIMETRIC_INCH); + pnHeight := MulDiv(hmHeight, nPixY, HIMETRIC_INCH); + + //gpPicture.Render(ACanvas.Handle,Rect.Left,Rect.Top + pnHeight,pnWidth,-pnHeight,0,0, + // hmWidth,hmHeight, Rect); + gpPicture.Render(ACanvas.Handle,Rect.Left,Rect.Top, + pnWidth,pnHeight,0,hmHeight, hmWidth,-hmHeight, Rect); + end; + +end; + +function THTMLPicture.GetEmpty: Boolean; +begin + Result := FIsEmpty; +end; + +function THTMLPicture.GetHeight: integer; +var + hmHeight:integer; +begin + if gpPicture = nil then + Result := 0 + else + begin + gpPicture.get_Height(hmHeight); + Result := MulDiv(hmHeight, FLogPixY, HIMETRIC_INCH); + end; +end; + +function THTMLPicture.GetWidth: Integer; +var + hmWidth: Integer; +begin + if gpPicture = nil then + Result := 0 + else + begin + gpPicture.get_Width(hmWidth); + Result := MulDiv(hmWidth, FLogPixX, HIMETRIC_INCH); + end; +end; + +procedure THTMLPicture.LoadFromFile(const FileName: string); +begin + try + FDataStream.LoadFromFile(Filename); + FIsEmpty:=false; + LoadPicture; + if Assigned(OnChange) then + OnChange(self); + except + FIsEmpty:=true; + end; +end; + +procedure THTMLPicture.LoadFromStream(Stream: TStream); +begin + if Assigned(Stream) then + begin + FDataStream.LoadFromStream(Stream); + FIsEmpty := False; + LoadPicture; + if Assigned(OnChange) then + OnChange(self); + end; +end; + +procedure THTMLPicture.ReadData(Stream: TStream); +begin + + if assigned(Stream) then + begin + fDataStream.LoadFromStream(stream); + fIsEmpty:=false; + LoadPicture; + end; +end; + +procedure THTMLPicture.SaveToStream(Stream: TStream); +begin + if Assigned(Stream) then fDataStream.SaveToStream(Stream); +end; + +procedure THTMLPicture.LoadFromResourceName(Instance: THandle; const ResName: string); +var + Stream: TCustomMemoryStream; +begin + {$IFNDEF TMSDOTNET} + if FindResource(Instance,pchar(ResName),RT_RCDATA)<>0 then + {$ENDIF} + {$IFDEF TMSDOTNET} + if FindResource(Instance,ResName,RT_RCDATA)<>0 then + {$ENDIF} + begin + Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; + end; +end; + +procedure THTMLPicture.LoadFromResourceID(Instance: THandle; ResID: Integer); +var + Stream: TCustomMemoryStream; +begin + Stream := TResourceStream.CreateFromID(Instance, ResID, RT_RCDATA); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + + +procedure THTMLPicture.SetHeight(Value: integer); +begin + +end; + +procedure THTMLPicture.SetWidth(Value: integer); +begin + +end; + +procedure THTMLPicture.WriteData(Stream: TStream); +begin + if Assigned(Stream) then + begin + FDataStream.savetostream(stream); + end; +end; + +procedure THTMLPicture.LoadFromURL(url: string); +var + UUrl: string; +begin + UUrl := UpperCase(url); + + if Pos('RES://',UUrl) = 1 then + begin + ID := url; + Delete(url,1,6); + if url <> '' then + LoadFromResourceName(hinstance,url); + Exit; + end; + + if Pos('FILE://',Uurl) = 1 then + begin + ID := url; + Delete(url,1,7); + if url <> '' then + LoadFromFile(url); + Exit; + end; + + if FAsynch then + begin + if FThreadBusy then + Exit; + FURL := url; + FThreadBusy := True; + TDownLoadThread.Create(self); + end + else + begin + FURL := url; + ID := url; + {$IFDEF USEWININET} + DownLoad; + {$ENDIF} + end; +end; + +{$IFDEF USEWININET} +procedure THTMLPicture.DownLoad; +var + RBSIZE:dword; + httpstatus,httpsize,err:integer; + dwIdx:dword; + dwBufSize:dword; + ms:TMemoryStream; + len:dword; + cbuf:array[0..255] of char; + rb:array[0..4095] of byte; + + FISession:hinternet; + FIHttp:hinternet; + Cancel:boolean; + +begin + fISession:=InternetOpen('HTMLImage',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0); + if (fISession=nil) then + begin + DownLoadError('Cannot open internet session'); + fThreadBusy:=false; + Exit; + end; + + fIHttp:=InternetOpenURL(fISession,pchar(furl),nil,0, + INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_RELOAD,0); + + if (fIHttp=nil) then + begin + InternetCloseHandle(fISession); + DownLoadError('Cannot open http connection'); + fThreadBusy:=false; + Exit; + end; + + dwBufSize := SizeOf(cbuf); + dwidx := 0; + HttpQueryInfo(fIHttp,HTTP_QUERY_STATUS_CODE,@cbuf,dwBufSize,dwIdx); + + val(cbuf,httpstatus,err); + if (httpstatus <> 200) or (err <> 0) then + begin + InternetCloseHandle(fISession); + InternetCloseHandle(fIHttp); + DownLoadError('Cannot open URL '+furl); + FThreadBusy:=false; + Exit; + end; + + dwBufSize := SizeOf(cbuf); + dwidx := 0; + HttpQueryInfo(fIHttp,HTTP_QUERY_CONTENT_TYPE,@cbuf,dwBufSize,dwIdx); + + if Pos('IMAGE',UpperCase(StrPas(cbuf))) = 0 then + begin + InternetCloseHandle(fISession); + InternetCloseHandle(fIHttp); + DownLoadError('Resource is not of image type : ' + FUrl); + fThreadBusy := false; + Exit; + end; + + dwBufSize := SizeOf(cbuf); + dwidx := 0; + HttpQueryInfo(fIHttp,HTTP_QUERY_CONTENT_LENGTH,@cbuf,dwBufSize,dwIdx); + + val(cbuf,httpsize,err); + if (httpsize = 0) or (err <> 0) then + begin + InternetCloseHandle(fISession); + InternetCloseHandle(fIHttp); + DownLoadError('Image size is 0'); + fThreadBusy:=false; + Exit; + end; + + DownLoadProgress(0,httpsize); + + len := 4096; + RBSIZE := 4096; + + ms := TMemoryStream.Create; + + cancel:=false; + + while (len=RBSIZE) and not Cancel do + begin + InternetReadFile(fIHttp,@rb,RBSIZE,len); + if len>0 then ms.WriteBuffer(rb,len); + DownLoadProgress(ms.Size,httpsize); + DownLoadCancel(cancel); + end; + + if not cancel then + begin + ms.Position := 0; + LoadFromStream(ms); + end; + + ms.Free; + + InternetCloseHandle(fIHttp); + InternetCloseHandle(fISession); + FThreadBusy:=false; +end; +{$ENDIF} + +procedure THTMLPicture.DownLoadCancel(var cancel: boolean); +begin + if assigned(FOnDownLoadCancel) then + FOnDownLoadCancel(self,cancel); +end; + +procedure THTMLPicture.DownLoadComplete; +begin + if Assigned(FOnDownLoadComplete) then + FOnDownLoadComplete(self); +end; + +procedure THTMLPicture.DownLoadError(err: string); +begin + if Assigned(fOnDownloadError) then + FOnDownLoadError(self,err); +end; + +procedure THTMLPicture.DownLoadProgress(dwSize, dwTotSize: dword); +begin + if Assigned(FOnDownLoadProgress) then + FOnDownLoadProgress(self,dwSize,dwTotSize); +end; + + +procedure THTMLPicture.LoadFromClipboardFormat(AFormat: Word; + AData: THandle; APalette: HPALETTE); +begin +end; + +procedure THTMLPicture.SaveToClipboardFormat(var AFormat: Word; + var AData: THandle; var APalette: HPALETTE); +begin +end; + +function THTMLPicture.GetFrameCount: Integer; +var + i: Integer; + b,c,d,e: Byte; + Res: Integer; +begin + Result := -1; + + if FFrameCount <> -1 then + Result := FFrameCount + else + if IsGIFFile then + begin + Res := 0; + for i := 1 to FDataStream.Size do + begin + FDataStream.Position := i - 1; + FDataStream.Read(b,1); + if (b = $21) and (i + 8 < FDataStream.Size) then + begin + FDataStream.Read(c,1); + FDataStream.Read(d,1); + FDataStream.Position := FDataStream.Position+5; + FDataStream.Read(e,1); + if (c = $F9) and (d = $4) and (e = $2C) then Inc(res); + end; + end; + FFrameCount := Res; + Result := Res; + FDataStream.Position := 0; + end; +end; + +function THTMLPicture.IsGIFFile: Boolean; +var + buf: array[0..4] of char; +begin + Result := False; + if FDataStream.Size>4 then + begin + FDataStream.Position := 0; + {$IFNDEF TMSDOTNET} + FDataStream.Read(buf,4); + buf[4] := #0; + Result := Strpas(buf) = 'GIF8'; + {$ENDIF} + FDataStream.Position := 0; + + end; +end; + +function THTMLPicture.GetFrameTime(i: Integer): Integer; +var + j: Integer; + b,c,d,e: Byte; + res: Integer; + ft: Word; + +begin + Result := -1; + + if IsGIFFile then + begin + Res := 0; + for j := 1 to FDataStream.Size do + begin + FDataStream.Position := j-1; + FDataStream.Read(b,1); + if (b = $21) and (i + 8 < FDataStream.Size) then + begin + FDataStream.Read(c,1); + FDataStream.Read(d,1); + FDataStream.Read(b,1); + {transp. flag here} + + FDataStream.Read(ft,2); + FDataStream.Position := FDataStream.Position + 2; + + FDataStream.Read(e,1); + if (c = $F9) and (d = $4) and (e = $2C) then + begin + Inc(res); + if res = i then + begin + Result := ft; + FFrameTransp := b and $01=$01; + FFrameDisposal := (b shr 3) and $7; + end; + end; + end; + end; + end; + FDataStream.Position := 0; +end; + +function THTMLPicture.GetMaxHeight: Integer; +var + hmHeight: Integer; +begin + {$IFNDEF TMSDOTNET} + if gpPicture = nil then + Result := 0 + else + begin + if FAnimMaxY>0 then Result:=FAnimMaxY + else + begin + gpPicture.get_Height(hmHeight); + Result := MulDiv(hmHeight, fLogPixY, HIMETRIC_INCH); + end; + end; + {$ENDIF} +end; + +function THTMLPicture.GetMaxWidth: Integer; +var + hmWidth: Integer; +begin + if gpPicture = nil then + Result := 0 + else + begin + if FAnimMaxX > 0 then + Result := FAnimMaxX + else + begin + gpPicture.get_Width(hmWidth); + Result := MulDiv(hmWidth, fLogPixX, HIMETRIC_INCH); + end; + end; +end; + + +procedure THTMLPicture.SetFrame(const Value: Integer); +begin + FFrame := Value; + if FDataStream.Size > 0 then + begin + LoadPicture; + if Assigned(OnFrameChange) then + OnFrameChange(self); + end; +end; + +procedure THTMLPicture.FrameNext; +begin + if FFrame < FFrameCount then + Inc(FFrame) + else + FFrame := 1; +end; + +function THTMLPicture.Step: Boolean; +begin + Result := False; + if (FFrameCount <= 1) or FIsEmpty then + Exit; + + if FNextCount = -1 then + FrameTime[FFrame]; + + if FTimerCount*10 >= FNextCount then + begin + FrameNext; + LoadPicture; + FNextCount := FNextCount + FrameTime[FFrame]; + Result := True; + end; + + Inc(FTimerCount); +end; + +procedure THTMLPicture.FramePrev; +begin + if FFrame > 1 then + Dec(FFrame) + else + FFrame := FFrameCount; +end; + + +{ THTMLImage } + +constructor THTMLImage.Create(aOwner: TComponent); +begin + inherited; + fHTMLPicture:=THTMLPicture.Create; + fHTMLPicture.OnChange:=PictureChanged; + Width:=100; + Height:=100; + fHTMLPicture.OnDownLoadError:=DownLoadError; + fHTMLPicture.OnDownLoadCancel:=DownLoadCancel; + fHTMLPicture.OnDownLoadProgress:=DownLoadProgress; + fHTMLPicture.OnDownLoadComplete:=DownLoadComplete; +end; + +destructor THTMLImage.Destroy; +begin + fHTMLPicture.Free; + inherited; +end; + +procedure THTMLImage.Loaded; +begin + inherited; + fHTMLPicture.fLogPixX := GetDeviceCaps(canvas.handle,LOGPIXELSX); + fHTMLPicture.fLogPixY := GetDeviceCaps(canvas.handle,LOGPIXELSY); +end; + +procedure THTMLImage.Paint; +var + xo,yo:integer; + + function Max(a,b:integer):integer; + begin + if (a>b) then result:=a else result:=b; + end; + +begin + inherited; + if assigned(fHTMLPicture) then + begin + if not fHTMLPicture.Empty then + case fPicturePosition of + bpTopLeft:Canvas.Draw(0,0,fHTMLPicture); + bpTopRight:Canvas.Draw(Max(0,width-fHTMLPicture.Width),0,fHTMLPicture); + bpBottomLeft:Canvas.Draw(0,Max(0,height-fHTMLPicture.Height),fHTMLPicture); + bpBottomRight:Canvas.Draw(Max(0,width-fHTMLPicture.Width),Max(0,height-fHTMLPicture.Height),fHTMLPicture); + bpCenter:Canvas.Draw(Max(0,width-fHTMLPicture.Width) shr 1,Max(0,height-fHTMLPicture.Height) shr 1,fHTMLPicture); + bpTiled:begin + yo:=0; + while (yo Value) then + begin + fPicturePosition := Value; + Invalidate; + end; +end; + +procedure THTMLImage.DownLoadCancel(Sender: TObject; var cancel: boolean); +begin + if assigned(fOnDownLoadCancel) then fOnDownLoadCancel(self,cancel); +end; + +procedure THTMLImage.DownLoadComplete(Sender: TObject); +begin + if assigned(fOnDownLoadComplete) then fOnDownLoadComplete(self); +end; + +procedure THTMLImage.DownLoadError(Sender: TObject; err: string); +begin + if Assigned(FOnDownloadError) then + FOnDownLoadError(self,err); +end; + +procedure THTMLImage.DownLoadProgress(Sender: TObject; dwSize, + dwTotSize: dword); +begin + if Assigned(FOnDownLoadProgress) then + FOnDownLoadProgress(self,dwSize,dwTotSize); +end; + +{ TDownLoadThread } + +constructor TDownLoadThread.Create(aHTMLPicture: THTMLPicture); +begin + inherited Create(false); + HTMLPicture := aHTMLPicture; + FreeOnTerminate := True; +end; + +procedure TDownLoadThread.Execute; +begin + {$IFDEF USEWININET} + HTMLPicture.DownLoad; + {$ENDIF} +end; + +{ THTMLPictureCache } + +destructor THTMLPictureCache.Destroy; +begin + ClearPictures; + inherited; +end; + +function THTMLPictureCache.AddPicture: THTMLPicture; +begin + Result := THTMLPicture.Create; + {$IFNDEF TMSDOTNET} + Add(pointer(result)); + {$ENDIF} + {$IFDEF TMSDOTNET} + Add(TObject(Result)); + {$ENDIF} +end; + +procedure THTMLPictureCache.ClearPictures; +var + i: Integer; +begin + for i := 1 to Count do + Items[i - 1].Free; + + Clear; + //inherited; +end; + +function THTMLPictureCache.FindPicture(ID: string): THTMLPicture; +var + i: Integer; +begin + Result := nil; + for i := 1 to Count do + begin + if (Items[i - 1].ID = ID) then + begin + Result := Items[i - 1]; + Break; + end; + end; +end; + +function THTMLPictureCache.GetPicture(Index: Integer): THTMLPicture; +begin + Result := THTMLPicture(inherited Items[Index]); +end; + +procedure THTMLPictureCache.SetPicture(Index: Integer; Value: THTMLPicture); +begin + {$IFNDEF TMSDOTNET} + inherited Items[index] := Pointer(Value); + {$ENDIF} + {$IFDEF TMSDOTNET} + inherited Items[index] := Value; + {$ENDIF} +end; + +function THTMLPictureCache.Animate: Boolean; +var + i: Integer; +begin + Result := False; + for i := 1 to Count do + begin + if Items[i - 1].Step then + Result := True; + end; +end;