Fast data transfer to MS Excel

Fast data transfer to MS Excel


var
  xls, wb, Range: OLEVariant;
  arrData: Variant;
begin
  {create variant array where we'll copy our data}
  arrData := VarArrayCreate([1, yourStringGrid.RowCount, 1, yourStringGrid.ColCount], varVariant);

  {fill array}
  for i := 1 to yourStringGrid.RowCount do
    for j := 1 to yourStringGrid.ColCount do
      arrData[i, j] := yourStringGrid.Cells[j-1, i-1];

  {initialize an instance of Excel}
  xls := CreateOLEObject('Excel.Application');

  {create workbook}
  wb := xls.Workbooks.Add;

  {retrieve a range where data must be placed}
  Range := wb.WorkSheets[1].Range[wb.WorkSheets[1].Cells[1, 1],
                                  wb.WorkSheets[1].Cells[yourStringGrid.RowCount, yourStringGrid.ColCount]];

  {copy data from allocated variant array}
  Range.Value := arrData;

  {show Excel with our data}
  xls.Visible := True;
end;

轉貼至:http://www.scalabium.com/faq/dct0144.htm

GetEnvironmentVariable 取系統環境變數

GetEnvironmentVariable

ALLUSERSPROFILE：All Users設定檔的資料夾位置。

APPDATA：目前使用者的Application Data資料夾位置。

CD：目前的工作資料夾。

CLIENTNAME：目前使用者的NETBIOS電腦名稱。(連線到Terminal的電腦名稱)

CMDCMDLINE：處理目前命令提示字元視窗命令的cmd.exe的完整路徑。

CMDEXTVERSION：目前Command Processor Extensions的版本。

COMPUTERNAME：電腦名稱。

COMSPEC:：命令提示字元視窗的解譯程式路徑，通常與%CMDCMDLINE%相同。

CommonProgramFiles：Common Files資料夾的路徑。

DATE：目前的系統日期。

ERRORLEVEL：最近執行過的命令的錯誤碼；非零的值表示發生過的錯誤碼。

HOMESHARE：目前使用者共用資料夾的網路路徑。

HomeDrive：使用者目錄的磁碟機。

HomePath：使用者家目錄。

LOGONSEVER：目前使用者所登入的網路控制器名稱。

NUMBER_OF_PROCESSORS：電腦的處理器數量。

OS：作業系統名稱，其值固定為Windows_NT

PATHEXT：作業系統是為執行檔的副檔名。

PROCESSOR_ARCHITECTURE：處理器的架構名稱，例如x86。

PROCESSOR_IDENTFIER：說明處理器的文字（不一定會有此環境變數）。

PROCESSOR_LEVEL：處理器的model number。

PROCESSOR_REVISION：處理器的revision number。

PROMPT：目前解譯程式的命令提示字串。

Path：執行檔的搜尋路徑。

ProgramFiles：應用程式目錄，預設是C:\Program Files。

RANDOM：顯示0到32767之間的十進位整數亂數。

SESSIONNAME：連上終端伺服器的session names。

SystemDirectory：系統目錄，預設是C:\WINNT\System32或C:\WINDOWS\System32。

SystemDrive：系統磁碟機，預設是C:。

SystemRoot：系統根目錄，預設是C:\WINNT或C:\WINDOWS。

TIME：目前的系統時間。

Temp、Tmp：暫存檔目錄。

USERPROFILE：目前使用者的設定檔路徑。Ex: C:\Users\Administrator

UserDomain：包含使用者帳號的網域名稱，或者電腦名稱。

UserName：使用者帳號名稱。

WinDir：Windows目錄，預設是C:\WINNT或C:\WINDOWS。

轉貼至: https://jck11.pixnet.net/blog/post/13459124-windows%E7%B3%BB%E7%B5%B1%E5%85%A7%E5%BB%BA%E7%9A%84%E5%B8%B8%E8%A6%8B%E7%92%B0%E5%A2%83%E8%AE%8A%E6%95%B8

Ex:

  GetEnvironmentVariable('USERPROFILE'); //Ex: c:\users\administrator

填補/移除路徑字串後面的路徑符號(Slash)

IncludeTrailingPathDelimiter('C:\Windows\Temp');  //Ex: C:\Windows\Temp  -> C:\Windows\Temp\

ExcludeTrailingPathDelimiter('C:\Windows\Temp');  //Ex: C:\Windows\Temp\  -> C:\Windows\Temp

Wingdings字型

通过 TStringList 给系列数字倒排序

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{写一个按数字大小倒排序的函数}
function DescCompareInt(List: TStringList; I1, I2: Integer): Integer;
begin
  I1 := StrToIntDef(List[I1], 0);
  I2 := StrToIntDef(List[I2], 0);
  Result := I2 - I1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  List: TStringList;
begin
  List := TStringList.Create;
  List.CommaText := '5,21,4,65,87,1,3';
  List.CustomSort(DescCompareInt); {排序时调用那个函数}
  ShowMessage(List.Text);          {87 65 21 5 4 3 1}
  List.Free;
end;

end.


轉貼至 https://www.cnblogs.com/del/archive/2008/04/07/1141195.html

目錄選取界面

Uses FileCtrl

function SelectDirectory(var Directory: string;
  Options: TSelectDirOpts; HelpCtx: Longint): Boolean; overload;

function SelectDirectory(const Caption: string; const Root: WideString;
  var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): Boolean; overload;

function SelectDirectory(const StartDirectory: string; out Directories: TArray<string>; Options: TSelectDirFileDlgOpts = [];
  const Title: string = ''; const FolderNameLabel: string = ''; const OkButtonLabel: string = ''): Boolean; overload;


TSelectDirOpt = (sdAllowCreate, sdPerformCreate, sdPrompt);
TSelectDirOpts = set of TSelectDirOpt;

TSelectDirExtOpt = (sdNewFolder, sdShowEdit, sdShowShares, sdNewUI, sdShowFiles, sdValidateDir);
TSelectDirExtOpts = set of TSelectDirExtOpt;

TSelectDirFileDlgOpt = (sdHidePinnedPlaces, sdNoDereferenceLinks, sdForceShowHidden, sdAllowMultiselect);
TSelectDirFileDlgOpts = set of TSelectDirFileDlgOpt;

idFTP 檢查FTP目錄是否存在

uses IdFTP, IdGlobal, IdFTPCommon, IdAllFTPListParsers;

function fn_FtpDirectoryExists(AidFTP:TidFTP; ADir:String): Boolean;
var index:Integer;
begin
  Index:=0;
  Result := False;
  try
    AidFTP.List;
    if Assigned(AidFTP.DirectoryListing) and (AidFTP.DirectoryListing.Count>0) then
    begin
      while Index<AidFTP.DirectoryListing.Count do
      begin
        with AidFTP.DirectoryListing.Items[Index] do
        begin
          if (trim(FileName)=trim(ADir)) and (ItemType = ditDirectory) then
          begin
            Result:=true;
            Exit;
          end;
        end;
        Index:=Index+1;
      end;
    end;
  except
    Result := False;
  end;
end;

SQL convert Datetime

Select CONVERT(nvarchar(100), GETDATE(), 0)   -- May 28 2019  8:25AM
Select CONVERT(nvarchar(100), GETDATE(), 1)   -- 05/28/19
Select CONVERT(nvarchar(100), GETDATE(), 2)   -- 19.05.28
Select CONVERT(nvarchar(100), GETDATE(), 3)   -- 28/05/19
Select CONVERT(nvarchar(100), GETDATE(), 4)   -- 28.05.19
Select CONVERT(nvarchar(100), GETDATE(), 5)   -- 28-05-19
Select CONVERT(nvarchar(100), GETDATE(), 6)   -- 28 May 19
Select CONVERT(nvarchar(100), GETDATE(), 7)   -- May 28, 19
Select CONVERT(nvarchar(100), GETDATE(), 8)   -- 08:28:35
Select CONVERT(nvarchar(100), GETDATE(), 9)   -- May 28 2019  8:28:35:360AM
Select CONVERT(nvarchar(100), GETDATE(), 10)  -- 05-28-19
Select CONVERT(nvarchar(100), GETDATE(), 11)  -- 19/05/28
Select CONVERT(nvarchar(100), GETDATE(), 12)  -- 190528
Select CONVERT(nvarchar(100), GETDATE(), 13)  -- 28 May 2019 08:28:53:277
Select CONVERT(nvarchar(100), GETDATE(), 14)  -- 08:28:53:277
Select CONVERT(nvarchar(100), GETDATE(), 20)  -- 2019-05-28 08:29:10
Select CONVERT(nvarchar(100), GETDATE(), 21)  -- 2019-05-28 08:29:10.180
Select CONVERT(nvarchar(100), GETDATE(), 22)  -- 05/28/19  8:29:10 AM
Select CONVERT(nvarchar(100), GETDATE(), 23)  -- 2019-05-28
Select CONVERT(nvarchar(100), GETDATE(), 24)  -- 08:29:27
Select CONVERT(nvarchar(100), GETDATE(), 25)  -- 2019-05-28 08:29:27.490
Select CONVERT(nvarchar(100), GETDATE(), 100) -- May 28 2019  8:29AM
Select CONVERT(nvarchar(100), GETDATE(), 101) -- 05/28/2019
Select CONVERT(nvarchar(100), GETDATE(), 102) -- 2019.05.28
Select CONVERT(nvarchar(100), GETDATE(), 103) -- 28/05/2019
Select CONVERT(nvarchar(100), GETDATE(), 104) -- 28.05.2019
Select CONVERT(nvarchar(100), GETDATE(), 105) -- 28-05-2019
Select CONVERT(nvarchar(100), GETDATE(), 106) -- 28 May 2019
Select CONVERT(nvarchar(100), GETDATE(), 107) -- May 28, 2019
Select CONVERT(nvarchar(100), GETDATE(), 108) -- 08:30:00
Select CONVERT(nvarchar(100), GETDATE(), 109) -- May 28 2019  8:30:00:127AM
Select CONVERT(nvarchar(100), GETDATE(), 110) -- 05-28-2019
Select CONVERT(nvarchar(100), GETDATE(), 111) -- 2019/05/28
Select CONVERT(nvarchar(100), GETDATE(), 112) -- 20190528
Select CONVERT(nvarchar(100), GETDATE(), 113) -- 28 May 2019 08:30:21:373
Select CONVERT(nvarchar(100), GETDATE(), 114) -- 08:30:21:373
Select CONVERT(nvarchar(100), GETDATE(), 120) -- 2019-05-28 08:30:40
Select CONVERT(nvarchar(100), GETDATE(), 121) -- 2019-05-28 08:30:40.233
Select CONVERT(nvarchar(100), GETDATE(), 126) -- 2019-05-28T08:30:40.233
Select CONVERT(nvarchar(100), GETDATE(), 130) -- 24 رمضان 1440  8:30:55:117AM
Select CONVERT(nvarchar(100), GETDATE(), 131) -- 24/09/1440  8:31:01:990AM

不同的wwDBGrid 指向同一個Dataset，表頭只會出現同一組設定

wwDBGrid.UseTFields := False;   //即可各自定義表頭

取得< 使用者>資料夾路徑

GetEnvironmentVariable('USERPROFILE');

Result  C:\Users\Administrator

Delphi 取得桌面資料夾的路徑和取得我的文件的路徑

function GetShellFolders(strDir: string): string;
const
  regPath = '\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
var
  Reg: TRegistry;
  strFolders: string;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(regPath, false) then
    begin
      strFolders := Reg.ReadString(strDir);
    end;
  finally
    Reg.Free;
  end;
  result := strFolders;
end;

Ex:

{獲取桌面}
function GetDeskeptPath: string;
begin
  Result := GetShellFolders('Desktop'); //是取得桌面資料夾的路徑
end;

{獲取我的文件}
function GetMyDoumentpath: string;
begin
  Result := GetShellFolders('Personal'); //我的文件
end;

轉貼至: http://fecbob.pixnet.net/blog/post/38063575-delphi-取得桌面資料夾的路徑和取得我的文件

SynPDF for Delphi

下載 : https://github.com/synopse/SynPDF



Trying to export a report with unicode text to pdf using SynPDF, results in mixed-up text

SynPDF have fixed some unicode issues, but not all of them aparently. The following is a streight forward code for exporting a quickreport to PDF usiny SynPDF:

procedure TForm1.CreatePdf(QuickRep: TCustomQuickRep; const aFileName: TFileName);
var
Pdf: TPdfDocument;
aMeta: TMetaFile;
i: integer;
begin
  Pdf := TPdfDocument.Create;
  Pdf.UseUniscribe := True;
  try
      Pdf.DefaultPaperSize := psA4;
      QuickRep.Prepare;
      for i := 1 to QuickRep.QRPrinter.PageCount do begin
        Pdf.AddPage;
        aMeta := QuickRep.QRPrinter.GetPage(i);
        try
          // draw the page content
          Pdf.Canvas.RenderMetaFile(aMeta,1,0,0);
        finally
          aMeta.Free;
        end;
      end;
      Pdf.SaveToFile(aFileName);
  finally
    Pdf.free;
  end;
end;

轉貼至 https://stackoverflow.com/questions/25910798/trying-to-export-a-report-with-unicode-text-to-pdf-using-synpdf-results-in-mixe

Use Adobe Acrobat (PDF) Files in a Delphi Application

by Zarko Gajic
Updated September 29, 2017

Delphi supports the display of Adobe PDF files from within an application. As long as you've got Adobe Reader installed, your PC will automatically have the relevant ActiveX control you'll need to create a component you can drop into a Delphi form.


Difficulty: Easy

Time Required: 5 minutes

Here's How:

1.Start Delphi and select Component | Import ActiveX Control...

2.Look for the "Acrobat Control for ActiveX (Version x.x)" control and click Install.

3.Select the Component palette location into which the selected library will appear. Click Install.

4.Select a package where the new component must be installed or create a new package for the new
TPdf control.

5.Click OK.

6.Delphi will ask you whether you want to rebuild the modified/new package. Click Yes.

7.After the package is compiled, Delphi will show you a message saying that the new TPdf component was registered and already available as part of the VCL.

8.Close the package detail window, allowing Delphi to save the changes to it.

9.The component is now available in the ActiveX tab (if you didn't change this setting in step 4).

10.Drop the TPdf component onto a form and then select it.

11.Using the object inspector, set the src property to the name of an existing PDF file on your system. Now all you have to do is resize the component and read the PDF file from your Delphi application.

Tips:

The Adobe ActiveX control installs automatically when you install Adobe Reader.
Step 11 can be completed during runtime, so you can open and close files programmatically as well as resize the control.


轉貼至:https://www.thoughtco.com/adobe-acrobat-pdf-files-delphi-applications-1056893

Ex:
  AcroPDF1.src := 'C:\Test.pdf';

StrToDatetime

Ex:

//設定日期時間格式不受系統變化影響
Application.UpdateFormatSettings := False;


var fmt :TFormatSettings ; //建議設成全域變數，日期格式才能全面性

  dtDate:TDateTime; 

  fmt.ShortDateFormat := 'MM/DD/YY';
  fmt.DateSeparator := '/';
  fmt.ShortTimeFormat := 'hh:nn:ss';
  fmt.TimeSeparator := ':';
  fmt.DecimalSeparator := '.';
  dtDate := StrToDateTime('06/10/18', fmt );

TreeView 增加 CheckBox/RadioButton操作選項

Ex1:

Uses CommCtrl;


procedure TForm1.FormCreate(Sender: TObject);
var dw:DWORD;
begin
  dw := GetWindowLong(tvWorkStep.Handle, GWL_STYLE);
  dw := dw or TVS_CHECKBOXES;
  SetWindowLong(tvWorkStep.Handle, GWL_STYLE , dw);
end;


增加2個Function
    function SetTreeViewNodeChecked(ATreeView: TTreeView; ATreeNode: TTreeNode;
Checked: Boolean): Boolean;

    function GetTreeViewNodeChecked(ATreeView: TTreeView; ATreeNode: TTreeNode): Boolean;


function TForm1.SetTreeViewNodeChecked(ATreeView: TTreeView; ATreeNode: TTreeNode; Checked: Boolean): Boolean;
var
  tvItem: TTVItem;
begin
  tvItem.mask := TVIF_HANDLE or TVIF_STATE;
  tvItem.hItem := ATreeNode.ItemId;
  tvItem.stateMask := TVIS_STATEIMAGEMASK;

  (*Image 1 in the tree-view check box image list is the
  unchecked box. Image 2 is the checked box.*)
  if Checked then
    tvItem.state := IndexToStateImageMask(2)
  else
    tvItem.state := IndexToStateImageMask(1);

  Result := TreeView_SetItem(ATreeView.Handle, tvItem);
end;

function TForm1.GetTreeViewNodeChecked(ATreeView: TTreeView; ATreeNode: TTreeNode): Boolean;
var
  tvItem: TTVItem;
begin
  // Prepare to receive the desired information.
  tvItem.mask := TVIF_HANDLE or TVIF_STATE;
  tvItem.hItem := ATreeNode.ItemId;
  tvItem.stateMask := TVIS_STATEIMAGEMASK;

  // Request the information.
  TreeView_GetItem(ATreeView.Handle, tvItem);

  // Return zero if it's not checked, or nonzero otherwise.
  Result := Boolean((tvItem.state shr 12) - 1);
end;

轉貼至 http://www.cnblogs.com/spiritofcloud/p/3976170.html

==================================================================

==================================================================

Ex2:

搭配 TImageList，TreeView.StateImages指向TImageList， 設定 Item.StateIndex 用圖示反應狀態

TImageList

Const

 cFlatUnCheck=1;  

 cFlatChecked=2;

 cFlatRadioUnCheck=3;

 cFlatRadioChecked=4;

//ToggleTreeViewCheckBoxes同時處理CheckBox/RadioButton的圖示

//操作時只需調整 Item.StateIndex 就可以決定呈現方式

Procedure ToggleTreeViewCheckBoxes(

  Node :TTreeNode; cUnChecked, cChecked, cRadioUnchecked, cRadioChecked :integer);

var

 tmp:TTreeNode;

begin

  if Assigned(Node) then

  begin

    if Node.StateIndex = cUnChecked then

      Node.StateIndex := cChecked

    else if Node.StateIndex = cChecked then

      Node.StateIndex := cUnChecked

    else if Node.StateIndex = cRadioUnChecked then

    begin

      tmp := Node.Parent;

      if not Assigned(tmp) then

        tmp := TTreeView(Node.TreeView).Items.getFirstNode

      else

        tmp := tmp.getFirstChild;

      while Assigned(tmp) do

      begin

        if (tmp.StateIndex in [cRadioUnChecked,cRadioChecked]) then

          tmp.StateIndex := cRadioUnChecked;

        tmp := tmp.getNextSibling;

      end;

      Node.StateIndex := cRadioChecked;

    end;

  end;

end;

//TreeView.OnClick

procedure TForm1.TreeView1Click(Sender: TObject);

var

 P:TPoint;

begin

 GetCursorPos(P);

 P := TTreeView(Sender).ScreenToClient(P);

 if (htOnStateIcon in TTreeView(Sender).GetHitTestInfoAt(P.X,P.Y)) then

  ToggleTreeViewCheckBoxes(

    TTreeView(Sender).Selected,

    cFlatUnCheck,

    cFlatChecked,

    cFlatRadioUnCheck,

    cFlatRadioChecked);

end;

//TreeView.KeyDown

procedure TForm1.TreeView1KeyDown(Sender: TObject; var Key: Word;

  Shift: TShiftState);

begin

  if (Key = VK_SPACE) and Assigned(TTreeView(Sender).Selected) then

    ToggleTreeViewCheckBoxes(

      TTreeView(Sender).Selected,

      cFlatUnCheck,

      cFlatChecked,

      cFlatRadioUnCheck,

      cFlatRadioChecked);

end;

轉貼/參考

https://www.thoughtco.com/add-options-to-ttreeview-4077866  

http://www.aspphp.online/bianchen/gengduo/delphi/201701/10175.html

WIN API LockWindowUpdate-封鎖重繪視窗內容

The LockWindowUpdate function disables or reenables drawing in the specified window. Only one window can be locked at a time.

BOOL LockWindowUpdate(

    HWND hWndLock     // handle of window to lock 
   );   


Parameters

hWndLock

Specifies the window in which drawing will be disabled. If this parameter is NULL, drawing in the locked window is enabled.



Return Values

If the function succeeds, the return value is nonzero.
If the function fails, the return value is zero, indicating that an error occurred or another window was already locked.


截錄自 Windows SDK

Ex:
   LockWindowUpdate(Handle);  //封鎖某個視窗重繪
   LockWindowUpdate(0);  //解除

InputBox ComboBox輸入視窗

//ComboBox輸入視窗
//Ex: InputBox('Caption', '血型', 'A;B;O;AB','A型;B型;O型;AB型', Result)

function fn_InputBox(const ACaption, APrompt: WideString; AListValue, AListDesc:WideString; var AResult:String): Boolean; overload; //ComboBox輸入視窗
var
  Form: TForm;
  Prompt:TLabel;
  Combobox: TCombobox;
  DialogUnits: TPoint;
  ButtonTop, ButtonWidth, ButtonHeight: Integer;
  j, iTop, iHeight:Integer;
  DescList, ValueList:TStringList;
  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;
begin
  Result := False;
  ValueList := TStringList.Create;
  DescList := TStringList.Create;
  Form := TForm.Create(Application);
  with Form do
  begin
    try
      Font.Name := 'Arial';
      Font.Size := 12;
      Font.Style := [fsBold];
      Canvas.Font := Font;
      DialogUnits := GetAveCharSize(Canvas);
      BorderStyle := bsDialog;
      Caption := ACaption;
      ClientWidth := MulDiv(180, DialogUnits.X, 4);
      Position := poScreenCenter;

      Prompt := TLabel.Create(Form);
      with Prompt do
      begin
        Parent := Form;
        Caption := APrompt;
        Left := MulDiv(8, DialogUnits.X, 4);
        Top := MulDiv(8, DialogUnits.Y, 8);
        Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4);
        WordWrap := True;
      end;

      Combobox := TCombobox.Create(Form);
      with Combobox do
      begin
        Parent := Form;
        CharCase := ecUpperCase;
        Left := Prompt.Left;
        Top := Prompt.Top + Prompt.Height + 5;
        Width := MulDiv(164, DialogUnits.X, 4);

        ValueList.Assign(fn_SplitStr(';', AListValue));
        DescList.Assign(fn_SplitStr(';', AListDesc));
        Items.Clear;
        for j := 0 to DescList.Count-1 do
        begin
          if j >= ValueList.Count then
            Break;
          if (ValueList[j]+DescList[j])<>'' then
            Items.Add(ValueList[j]+ ' - ' +DescList[j]);
        end;
        ItemIndex := ValueList.IndexOf(AResult);

        iTop := Top;
        iHeight := Height;
      end;

      ButtonTop := iTop + iHeight + 15;
      ButtonWidth := MulDiv(50, DialogUnits.X, 4);
      ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '確定';
        ModalResult := mrOk;
        Default := True;
        SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
      end;

      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '取消';
        ModalResult := mrCancel;
        Cancel := True;
        SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
        Form.ClientHeight := Top + Height + 13;
      end;
      if ShowModal = mrOk then
      begin
        AResult := '';
        if Combobox.ItemIndex<>-1 then
          AResult := ValueList[Combobox.ItemIndex];
        Result := True;
      end;
    finally
      FreeAndNil(ValueList);
      FreeAndNil(DescList);
      Form.Free;
    end;
  end;
end;

InputBox DateTime輸入視窗

//DateTime 輸入視窗
function fn_InputBox(const ACaption, APrompt: WideString;var ADatetime: TDatetime): Boolean;
var
  Form: TForm;
  Prompt: TLabel;
  MonthCalendar:TMonthCalendar;
  DialogUnits: TPoint;
  ButtonTop, ButtonWidth, ButtonHeight: Integer;
  iTop, iHeight:Integer;
  APoint:TPoint;
  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;
begin
  Result := False;
  Form := TForm.Create(Application);
  with Form do
  begin
    try
      Font.Name := 'Arial';
      Font.Size := 12;
      Font.Style := [fsBold];
      Canvas.Font := Font;
      DialogUnits := GetAveCharSize(Canvas);
      BorderStyle := bsDialog;
      Caption := ACaption;
      ClientWidth := MulDiv(180, DialogUnits.X, 4);
      //Position := poScreenCenter;

      APoint := Screen.ActiveControl.ClientToScreen(Point(0, Screen.ActiveControl.ClientHeight));
      Left := APoint.X;
      Top := APoint.Y;
      Position := poDesigned;

      Prompt := TLabel.Create(Form);
      with Prompt do
      begin
        Parent := Form;
        Caption := APrompt;
        Left := MulDiv(8, DialogUnits.X, 4);
        Top := MulDiv(8, DialogUnits.Y, 8);
        Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4);
        WordWrap := True;
      end;

      with TComboBox.Create(Form) do
      begin
        Parent := Form;
        DropDownCount := 9;
        Top := Prompt.Top;
        Left := MulDiv(45, DialogUnits.X, 4);
        Style := StdCtrls.csDropDownList;
        Items.Add('');
        Items.Add('昨日');
        Items.Add('今日');
        Items.Add('上月初');
        Items.Add('上月底');
        Items.Add('月初');
        Items.Add('月底');
        Items.Add('年初');
        Items.Add('年底');
        OnChange := TVirtualClass.pr_ComboBox_OnChange;
      end;

      MonthCalendar := TMonthCalendar.Create(Form);
      with MonthCalendar do
      begin
        Parent := Form;
        AutoSize := False;
        Left := Prompt.Left;
        Top := Prompt.Top + Prompt.Height + 10;
        Width := MulDiv(164, DialogUnits.X, 4);
        Height := 213;
        MonthCalendar.Date := ADatetime;
        iTop := Top;
        iHeight := Height;
      end;

      ButtonTop := iTop + iHeight + 15;
      ButtonWidth := MulDiv(50, DialogUnits.X, 4);
      ButtonHeight := MulDiv(14, DialogUnits.Y, 8);

      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '確定';
        ModalResult := mrOk;
        Default := True;
        SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
      end;

      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '取消';
        ModalResult := mrCancel;
        Cancel := True;
        SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
        Form.ClientHeight := Top + Height + 13;
      end;

      if ShowModal = mrOk then
      begin
        ADatetime := MonthCalendar.Date;
        Result := True;
      end;
    finally
      Form.Free;
    end;
  end;
end;

InputBox String輸入視窗

//
function fn_InputBox(const ACaption, APrompt: WideString;var AString: String): Boolean;
var
  Form: TForm;
  Prompt: TLabel;
  Edit: TEdit;
  DialogUnits: TPoint;
  ButtonTop, ButtonWidth, ButtonHeight: Integer;
  iTop, iHeight:Integer;
  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;
begin
  Result := False;
  Form := TForm.Create(Application);
  with Form do
  begin
    try
      Font.Name := 'Arial';
      Font.Size := 12;
      Font.Style := [fsBold];
      Canvas.Font := Font;
      DialogUnits := GetAveCharSize(Canvas);
      BorderStyle := bsDialog;
      Caption := ACaption;
      ClientWidth := MulDiv(180, DialogUnits.X, 4);
      Position := poScreenCenter;

      Prompt := TLabel.Create(Form);
      with Prompt do
      begin
        Parent := Form;
        Caption := APrompt;
        Left := MulDiv(8, DialogUnits.X, 4);
        Top := MulDiv(8, DialogUnits.Y, 8);
        Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4);
        WordWrap := True;
      end;

      Edit := TEdit.Create(Form);
      with Edit do
      begin
        Parent := Form;
        CharCase := ecUpperCase;
        Left := Prompt.Left;
        Top := Prompt.Top + Prompt.Height + 5;
        Width := MulDiv(164, DialogUnits.X, 4);
        MaxLength := 255;
        Text := AString;
        iTop := Top;
        iHeight := Height;
        Color := $00F5D8BC;
        SelectAll;
      end;

      ButtonTop := iTop + iHeight + 15;
      ButtonWidth := MulDiv(50, DialogUnits.X, 4);
      ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '確定';
        ModalResult := mrOk;
        Default := True;
        SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
      end;
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := '取消';
        ModalResult := mrCancel;
        Cancel := True;
        SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
        Form.ClientHeight := Top + Height + 13;
      end;
      if ShowModal = mrOk then
      begin
        AString := Edit.Text;
        //
        Result := True;
      end;
    finally
      Form.Free;
    end;
  end;
end;

日期相關的函式

Uses SysUtils, DateUtils;

//取得系統日期格式
procedure GetLocaleFormatSettings(LCID: Integer; var FormatSettings: TFormatSettings);

//時間
function Time: TDateTime;

//日期時間
function Now: TDateTime;

//今天
function Today: TDateTime;

//昨天
function Yesterday: TDateTime;

//明天
function Tomorrow: TDateTime;

//目前年份
function CurrentYear: Word;

//取DateTime年份
function YearOf(const AValue: TDateTime): Word;

//取DateTime月份
function MonthOf(const AValue: TDateTime): Word;

//取DateTime週數
function WeekOf(const AValue: TDateTime): Word;                     

//取DateTime日期
function DayOf(const AValue: TDateTime): Word;

//取DateTime小時數
function HourOf(const AValue: TDateTime): Word;

//取DateTime分鐘數
function MinuteOf(const AValue: TDateTime): Word;

//取DateTime秒數
function SecondOf(const AValue: TDateTime): Word;

//月份增減
function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer = 1): TDateTime; 

//年度增減
function IncYear(const AValue: TDateTime;  const ANumberOfYears: Integer = 1): TDateTime;

//週數增減
function IncWeek(const AValue: TDateTime;  const ANumberOfWeeks: Integer = 1): TDateTime;

//日期增減
function IncDay(const AValue: TDateTime;  const ANumberOfDays: Integer = 1): TDateTime;

//時數增減
function IncHour(const AValue: TDateTime;  const ANumberOfHours: Int64 = 1): TDateTime;

//分鐘增減
function IncMinute(const AValue: TDateTime;  const ANumberOfMinutes: Int64 = 1): TDateTime;

//秒數增減
function IncSecond(const AValue: TDateTime;  const ANumberOfSeconds: Int64 = 1): TDateTime;

//是否為潤年
function IsLeapYear(Year: Word): Boolean;

//以指定的日期格式輸出字串
function FormatDateTime(const Format: string; DateTime: TDateTime): string;
function FormatDateTime(const Format: string; DateTime: TDateTime; const FormatSettings: TFormatSettings):

//AM/PM
function IsPM(const AValue: TDateTime): Boolean;

//檢查日期的正確性
function IsValidDate(const AYear, AMonth, ADay: Word): Boolean;

//年度第一天(年初)
function StartOfTheYear(const AValue: TDateTime): TDateTime;
function StartOfAYear(const AYear: Word): TDateTime;

//年度最後一天(年底)
function EndOfTheYear(const AValue: TDateTime): TDateTime;
function EndOfAYear(const AYear: Word): TDateTime;

//月份第一天(月初)
function StartOfTheMonth(const AValue: TDateTime): TDateTime;
function StartOfAMonth(const AYear, AMonth: Word): TDateTime;

//月份最後一天(月底)
function EndOfTheMonth(const AValue: TDateTime): TDateTime;
function EndOfAMonth(const AYear, AMonth: Word): TDateTime;

//週數第一天
function StartOfTheWeek(const AValue: TDateTime): TDateTime;

//週數最後一天
function EndOfTheWeek(const AValue: TDateTime): TDateTime; 

//日期區間的天數
function DaysBetween(const ANow, AThen: TDateTime): Integer;