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;

取檔案日期

function fn_Get_FileDatetime(AFileName:String):TDatetime;
var
  iFileAge:Integer;
begin
  iFileAge := FileAge(AFileName);
  Result := FileDateToDatetime(iFileAge);
end;

檔案文件相關的函式

Uses SysUtils;

//取檔案名稱
//Ex: C:\Test\NoName.txt -> NoName.txt
function ExtractFileName(const FileName: string): string;

//取檔案副檔名
//Ex: C:\Test\NoName.txt -> .txt
function ExtractFileExt(const FileName: string): string;

//取檔案所在磁碟代號
//Ex: C:\Test\NoName.txt -> C:
function ExtractFileDrive(const FileName: string): string;

//取檔案路徑
//Ex: C:\Test\NoName.txt -> C:\Test\
function ExtractFilePath(const FileName: string): string;

//取檔案目錄
//Ex: C:\Test\NoName.txt -> C:\Test
function ExtractFileDir(const FileName: string): string;

//變更副檔案名稱
//Ex: C:\Test\NoName.txt -> C:\Test\NoName.xxx
function ChangeFileExt(const FileName, Extension: string): string;

//取得檔案目錄路徑 (目錄後面加斜線符號)
//Ex: C:\Test -> C:\Test\
function IncludeTrailingPathDelimiter(const S: string): string;
function IncludeTrailingBackslash(const S: string): string;

//取得檔案目錄路徑 (目錄後面去除斜線符號)
//Ex: C:\Test\ -> C:\Test
function ExcludeTrailingPathDelimiter(const S: string): string;
function ExcludeTrailingBackslash(const S: string): string;

//檢查檔案是否存在
function FileExists(const FileName: string): Boolean;

//檢查目錄是否存在
function DirectoryExists(const Directory: string): Boolean;

//產生多層資料夾
//Ex: ForceDirectories('c:\a\b\c')
function ForceDirectories(Dir: string): Boolean;

//檢查檔案是否唯讀
function FileIsReadOnly(const FileName: string): Boolean;

//取得檔案屬性
function FileGetAttr(const FileName: string): Integer;

//設定檔案屬性
function FileSetAttr(const FileName: string; Attr: Integer): Integer;

//設定唯讀檔案
function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean;

//刪除檔案
function DeleteFile(const FileName: string): Boolean;

//變更檔案名稱
function RenameFile(const OldName, NewName: string): Boolean;

//取得磁碟空間
function DiskSize(Drive: Byte): Int64;

//取得目前所在目錄
function GetCurrentDir: string;

//設定目前所在目錄
function SetCurrentDir(const Dir: string): Boolean;

//建立目錄
function CreateDir(const Dir: string): Boolean;

//移除目錄
function RemoveDir(const Dir: string): Boolean;

//----------------------------------------------------------------------------------------------------------------
//取檔案日期
//----------------------------------------------------------------------------------------------------------------
function fn_Get_FileDatetime(AFileName:String):TDatetime;
var
  iFileAag:Integer;
begin
  iFileAag := FileAge(AFileName);
  Result := FileDateToDatetime(iFileAge);
end;

//----------------------------------------------------------------------------------------------------------------
//取檔案清單
//----------------------------------------------------------------------------------------------------------------
function fn_Get_FileList(APath:String; AFullPath:Boolean=False; ASearchSubPath:Boolean=False):TStringList;
var SearchRec: TSearchRec;
  Status: Integer;
  sFileList:TStringList;
  sPath:String;
begin
  sPath := '';
  if AFullPath then
    sPath := IncludeTrailingPathDelimiter(APath); // Ex: C:\temp -> C:\temp\
  sFileList := TStringList.Create;
  Status := FindFirst(APath+'\*.*', faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if ((SearchRec.Attr and faHidden)<>faHidden) and //非隱藏檔
        ((SearchRec.Attr and faSysFile)<>faSysFile) and //非系統檔
        (SearchRec.Name <> '.') and
        (SearchRec.Name <> '..') then
      begin
        if ((SearchRec.Attr and faDirectory) = faDirectory) then //目錄
        begin
          if ASearchSubPath then
            sFileList.AddStrings(fn_Get_FileList(APath+'\'+SearchRec.Name, AFullPath, ASearchSubPath))
        end
        else
          sFileList.Add(sPath+SearchRec.Name);
      end;
      Status := FindNext(SearchRec);
    end;
  Finally
    FindClose(SearchRec);
  end;
  Result := sFileList;
end;

//----------------------------------------------------------------------------------------------------------------
//檔案被使用中
//----------------------------------------------------------------------------------------------------------------
function fn_FileInUse(fName: string): boolean;
var
  HFileRes: HFILE;
begin
  Result := false;
  if not FileExists(fName) then
    exit;
  HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  Result := (HFileRes = INVALID_HANDLE_VALUE);
  if not Result then
    CloseHandle(HFileRes);
end;

//----------------------------------------------------------------------------------------------------------------
//建立資料夾
//----------------------------------------------------------------------------------------------------------------
procedure pr_CreateDir(ADir:String);
var sFolderList:TStringList;
  sDrive, sFolder:String;
  i:Integer;
begin
  sFolderList := TStringList.Create;
  ADir := ExcludeTrailingPathDelimiter(ADir); //Ex: C:\Temp\A\1\ -> C:\Temp\A\1
  sDrive := ExtractFileDrive(ADir)+'\'; //Ex: C:\
  //
  sFolderList.Add(ADir);
  sFolder := ADir;
  while True do
  begin
    sFolder := ExtractFileDir(sFolder);
    if sFolder=sDrive then
      Break;
    sFolderList.Insert(0, sFolder);
  end;
  //
  for i:=0 to sFolderList.Count-1 do
  begin
    if not DirectoryExists(sFolderList[i]) then
      CreateDir(sFolderList[i]);
  end;
  FreeAndNil(sFolderList);
end;

//----------------------------------------------------------------------------------------------------------------
//檔案複製/搬移 (含子資料夾)
//----------------------------------------------------------------------------------------------------------------
procedure pr_CopyFile(ASourceFile, ATargetPath:String; ASearchSubPath:Boolean=False; AMoveFile:Boolean=False);
var SearchRec: TSearchRec;
  Status: Integer;
  sSourcePath, sTargetPath, sTargetDir,
  sSearchFileName, sTargetFileName, sFileName:String;
begin
  sFileName := ExtractFileName(ASourceFile);
  sSourcePath := ExtractFilePath(ASourceFile);
  sTargetPath := IncludeTrailingPathDelimiter(ATargetPath);
  sTargetDir := ExcludeTrailingPathDelimiter(ATargetPath);
  if CompareText(sSourcePath, sTargetPath)=0 then
    Exit;
  //
  pr_CreateDir(sTargetDir); //建立目的資料夾
  //
  Status := FindFirst(ASourceFile, faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if ((SearchRec.Attr and faHidden)<>faHidden) and //非隱藏檔
        ((SearchRec.Attr and faSysFile)<>faSysFile) and //非系統檔
        (SearchRec.Name <> '.') and
        (SearchRec.Name <> '..') then
      begin
        sSearchFileName := sSourcePath + SearchRec.Name;
        if ((SearchRec.Attr and faDirectory) = faDirectory) then //目錄
        begin
          if ASearchSubPath then
          begin
            if CompareText(sSearchFileName, sTargetDir)<>0 then
            begin
              pr_CopyFile(sSearchFileName+'\'+sFileName, sTargetPath+SearchRec.Name, ASearchSubPath);
            end;
          end;
        end
        else if not fn_FileInUse(sSearchFileName) then
        begin
          sTargetFileName := sTargetPath + SearchRec.Name;
          if AMoveFile then
            MoveFile(PWideChar(sSearchFileName), PWideChar(sTargetFileName)) //搬移
          else
            CopyFile(PWideChar(sSearchFileName), PWideChar(sTargetFileName), False); //複製
        end;
      end;
      Status := FindNext(SearchRec);
    end;
  Finally
    FindClose(SearchRec);
  end;
end;

//----------------------------------------------------------------------------------------------------------------

//檔案版本 FileVersion

//----------------------------------------------------------------------------------------------------------------

function GetFileVersion(const FileName: string): string;

var

  Size, Handle: DWORD;

  Buffer: Pointer;

  FileInfo: PVSFixedFileInfo;

  FileInfoSize: UINT;

  Major, Minor, Release, Build: WORD;

begin

  Result := '';

  Size := GetFileVersionInfoSize(PChar(FileName), Handle);

  if Size = 0 then Exit;

  GetMem(Buffer, Size);

  try

    if GetFileVersionInfo(PChar(FileName), Handle, Size, Buffer) then

    begin

      if VerQueryValue(Buffer, '\', Pointer(FileInfo), FileInfoSize) then

      begin

        Major := HiWord(FileInfo.dwFileVersionMS);

        Minor := LoWord(FileInfo.dwFileVersionMS);

        Release := HiWord(FileInfo.dwFileVersionLS);

        Build := LoWord(FileInfo.dwFileVersionLS);

        Result := Format('%d.%d.%d.%d', [Major, Minor, Release, Build]);

      end;

    end;

  finally

    FreeMem(Buffer);

  end;

end;

//----------------------------------------------------------------------------------------------------------------

//檔案版本 ProductVersion

//----------------------------------------------------------------------------------------------------------------

function GetProductVersion(const FileName: string): string;

var

  Size, Handle: DWORD;

  Buffer: Pointer;

  FileInfo: PVSFixedFileInfo;

  FileInfoSize: UINT;

  VersionPointer: Pointer;

  VersionSize: UINT;

  VersionStr: string;

begin

  Result := '';

  Size := GetFileVersionInfoSize(PChar(FileName), Handle);

  if Size = 0 then Exit;

  GetMem(Buffer, Size);

  try

    if GetFileVersionInfo(PChar(FileName), Handle, Size, Buffer) then

    begin

      // Get the product version string

      if VerQueryValue(Buffer, '\StringFileInfo\040904E4\ProductVersion', VersionPointer, VersionSize) then

      begin

        SetString(VersionStr, PChar(VersionPointer), VersionSize - 1);

        Result := VersionStr;

      end;

    end;

  finally

    FreeMem(Buffer);

  end;

end;

Runtime error 217 at 004539BD

Delphi 專案

  Project -> Options
  [Link with runtime packages] 設成 False

  一樣還是出現 Runtime error 217 at xxxxxxxx的訊息

  結果發現是專案裡 Uses 了其他的 Unit File，Unit File裡引用了其他資源文件導至錯誤 !