house of the disappeared《時間外的家》

Delphi 顯示器-縮放與版面配置，影響報表輸出的表單尺寸

 縮放與版面配置  

當Project Options 勾選 Enable High-DPI ，專案的界面會依照縮放比例做調整，Screen.PixelsPerInch會取得與縮放比對應的數值 (Ex: 縮放比125%會取得120)

沒有勾選 Enable High-DPI，Screen.PixelsPerInch會取得 96 (縮放比100%)

Var

  iHorzres, iDesktopHorzres:Integer;

  iScale:Currency;

begin

  iHorzres := GetDeviceCaps(GetDC(0), HORZRES);  //水平像素總數

  iDesktopHorzres := GetDeviceCaps(GetDC(0), DESKTOPHORZRES); // 桌面水平像素總數

  iScale :=  iDesktopHorzres / iHorzres ;

end

影響QuickRep 報表版面配置的處理方式

with QuickRep1 do

begin

  ...

  ...

  ScaleBy(Screen.PixelsPerInch * iScale , Screen.PixelsPerInch);

  Prepare;

  ...

  ...

end;

Delphi Form Position poDesktopCenter & poScreenCenter

 

Delphi 取用系統圖示(Icon)

Uses ShellAPI;
...
  Button1 : TButton;
  ImageList1 : TImageList;
  TListView1 : TListView;
...
...
procedure TForm1.Button1Click(Sender: TObject);
var
  IconIndex: word;
  sFileName:String;
  Buffer: array[0..2048] of char;
  IconHandle: HIcon;

  objIcon:TIcon;
  i, iCount:Integer;
  lvItem:TListItem;
begin

  objIcon := TIcon.Create;
  sFileName := 'Shell32.dll';
  StrCopy(@Buffer, PChar(sFileName));
  iCount := ExtractIcon(HInstance, PChar(sFileName), $FFFFFFFF);
  for i := 0 to iCount-1 do
  begin
    IconIndex := i;
    IconHandle := ExtractAssociatedIcon(HInstance, Buffer, IconIndex);
    if IconHandle <> 0 then
      objIcon.Handle := IconHandle;
    ImageList1.AddIcon(objIcon);
    lvItem := ListView1.Items.Add;
    lvItem.ImageIndex := i;
    lvItem.Caption := IntToStr(i);
  end;
end;

Windows存放系統圖示的文件

shell32.dll：包含許多與 Windows Shell 有關的圖示

imageres.dll： 是一個包含大量 Windows 系統圖示的檔案

user32.dll：包含一些基本的系統圖示 

comctl32.dll：包含一些常用的圖示 

參考:

https://www.tek-tips.com/viewthread.cfm?qid=918978

CharGRT 

Shell32.dll

Imageres.dll

User32.dll

Comctl32.dll

  

Delphi 要如何取得DLL的檔案名稱

 

var
  DLLFileName: array [0..MAX_PATH] of Char;
begin
  GetModuleFileName(HInstance, DLLFileName, Length(DLLFileName));
  ShowMessage(DLLFileName);
end;

CharGPT 的回應

SQL Count Distinct 統計類別數量

Select Field1, Count(Distinct Field2) as Qty
From Table1
Group by Field1

Delphi ClientDataset GetGroupState

GetGroupState

ClientDataset 需先建立IndexDef，GetGroupState代入GroupingLevel，可以取得資料列在Group中所屬的狀態gbFirst、gbMiddle、gbLast

procedure TForm1.FormCreate(Sender: TObject);
var inxIndex:TIndexDef;
  aggAggregate:TAggregate;
begin
  //Create Index
  inxIndex := ClientDataSet1.IndexDefs.AddIndexDef;
  inxIndex.Name := 'Index1';
  inxIndex.Fields := 'Field1;Field2';
  inxIndex.GroupingLevel := 2; //群組的層級，取決於Fields的數量
  ClientDataset1.IndexName := inxIndex.Name;
end;

procedure TForm1.ClientDataSet1Field1GetText(Sender: TField; var Text: string;
  DisplayText: Boolean);
begin
  //TGroupPosInd = (gbFirst, gbMiddle, gbLast);
  if gbFirst in ClientDataset1.GetGroupState(1) then
    Text := Sender.AsString
  else
    Text := '';
end;

原資料

gbFirst in ClientDataset1.GetGroupState(1)

gbMiddle in ClientDataset1.GetGroupState(1)

gbLast in ClientDataset1.GetGroupState(1)

ClientDataset Methods 說明

Datasnap.DBClient.TClientDataSet Methods

Delphi ClientDataset Aggregates & Index 分組合計

 

procedure TForm1.FormCreate(Sender: TObject);
var inxIndex:TIndexDef;
  aggAggregate:TAggregate;
begin
  with ClientDataSet1 do
  begin
    //Create Dataset
    FieldDefs.Add('Field1', ftString, 20);
    FieldDefs.Add('Field2', ftString, 20);
    FieldDefs.Add('Qty', ftInteger);
    CreateDataSet;
    //Append Data

    AppendRecord(['1', '1', 10]);
    AppendRecord(['1', '1', 30]);
    AppendRecord(['1', '2', 50]);
    AppendRecord(['2', '2', 70]);
    AppendRecord(['2', '1', 90]);
  end;

  //Create Index
  inxIndex := ClientDataSet1.IndexDefs.AddIndexDef;
  inxIndex.Name := 'Index1';
  inxIndex.Fields := 'Field1;Field2';
  inxIndex.GroupingLevel := 2; //群組的層級，取決於Fields的數量
  ClientDataset1.IndexName := inxIndex.Name;

  //Create Aggregates
  aggAggregate := ClientDataset1.Aggregates.Add;
  aggAggregate.AggregateName := 'Aggregate0';
  aggAggregate.Expression := 'Sum(Qty)';

  //針對指定的群組層級做統計. 0:全部, Dataset可以不指定IndexName
  aggAggregate.GroupingLevel := 0;
  aggAggregate.IndexName := inxIndex.Name;
  aggAggregate.Active := True;

  aggAggregate := ClientDataset1.Aggregates.Add;
  aggAggregate.AggregateName := 'Aggregate1';
  aggAggregate.Expression := 'Sum(Qty)';
  //針對指定的群組層級做統計, Ex: Gropup by Field1
  aggAggregate.GroupingLevel := 1;
  aggAggregate.IndexName := inxIndex.Name;
  aggAggregate.Active := True;

  aggAggregate := ClientDataset1.Aggregates.Add;
  aggAggregate.AggregateName := 'Aggregate2';
  aggAggregate.Expression := 'Sum(Qty)';
  //針對指定的群組層級做統計, Ex: Group by Field1, Field2
  aggAggregate.GroupingLevel := 2;
  aggAggregate.IndexName := inxIndex.Name;
  aggAggregate.Active := True;

  aggAggregate := ClientDataset1.Aggregates.Add;
  aggAggregate.AggregateName := 'Aggregate3';
  aggAggregate.Expression := 'Max(Qty)';
  //針對指定的群組層級做統計, Ex: Group by Field1
  aggAggregate.GroupingLevel := 1;
  aggAggregate.IndexName := inxIndex.Name;
  aggAggregate.Active := True;

  Memo1.Clear;
  Memo1.Lines.Add('Aggregate0 (Sum(Qty)) = '+VarToStr(ClientDataSet1.Aggregates.Find('Aggregate0').Value));
  Memo1.Lines.Add('Aggregate1 (Sum(Qty) Group by Field1) = '+VarToStr(ClientDataSet1.Aggregates.Find('Aggregate1').Value));
  Memo1.Lines.Add('Aggregate2 (Sum(Qty) Group by Field1, Field2) = '+VarToStr(ClientDataSet1.Aggregates.Find('Aggregate2').Value));
  Memo1.Lines.Add('Aggregate3 (Max(Qty) Group by Field1) = '+VarToStr(ClientDataSet1.Aggregates.Find('Aggregate3').Value));
end;

Delphi ForceDirectories 建立資料夾

 

ForceDirectories     建置到指定的層級目錄 

Ex : 

ForceDirectories ('C:\Temp\Sub1\Sub2');

ForceDirectories ('\\10.10.10.10\Temp\Sub1\Sub2');

 

SQL PIVOT 直向資料內容轉橫向輸出

Select *
  (

    Select Field01, Field02, Field03, Field04

    From Table1

  ) a

Pivot

  ( 

    Sum(Field05) /*合計值*/

    For Field04 in ([Value01], [Value02], [Value03], [Value04])  /*橫向表頭*/

  ) b

ScorllBar 系統寬高

 
ScrollBar High

    GetSystemMetrics(SM_CYHSCROLL)

ScrollBar Width

    GetSystemMetrics(SM_CXVSCROLL)

Delphi TAggregate Row Summary

Ex:

var 

  sFieldName :String;
  fdAggregate:TAggregate;

begin
  cdsTemp := TClientDataset.Create(Self);

  cdsTemp.Aggregates.Clear;

  cdsTemp.AggregatesActive := True;
  cdsTemp.CloneCursor(Master, False, True);

  for i:=0 to Master.FieldCount-1 do
  begin
    sFieldName := Master.Fields[i].FieldName;
    if cdsTemp.FieldByName(sFieldName).DataType in 

      [ftSmallint, ftInteger, ftFloat, ftCurrency, ftLargeint] then
    begin
      fdAggregate := TAggregate.Create(cdsTemp.Aggregates, cdsTemp);
      fdAggregate.AggregateName := 'agg' + sFieldName;
      fdAggregate.Expression := 'sum('+sFieldName+')';
      fdAggregate.Active := True;
    end;
  end;

  //Get Value

  cdsTemp.Aggregates.Find('agg'+sFieldName).Value;

end;

Delphi 編譯時觸發的事件處理設定

 

[dcc32 Fatal Error] ToolsAPI.pas(18): F2613 Unit 'DockForm' not found.

 專案 Uses ToolsAPI 編譯時，Unit ToolsAPI 出現找不到 DockForm的錯誤訊息。

[Project]  >  [Options...] 

在  [Options...] 裡圖中的位置輸入 -LUDesignIDE

參考:

• https://www.cnblogs.com/cb168/p/4380756.html
• http://stackoverflow.com/questions/27699662/how-to-build-delphi-projects-for-win64-when-units-inside-it-uses-designeditors-d

取得Class所有屬性及數值

 
Uses TypInfo;

procedure GetClassProperties(AClass: TComponent; AStrings: TStrings);
var
  PropCount, I: SmallInt;
  PropList: PPropList;
  PropStr, sClass, sName, sValue: string;
begin
  PropCount := GetTypeData(AClass.ClassInfo).PropCount;
  GetPropList(AClass.ClassInfo, PropList);
  for I := 0 to PropCount - 1 do
  begin
    case PropList[I]^.PropType^.Kind of
      tkClass      : PropStr := '[Class] ';
      tkMethod     : PropStr := '[Method]';
      tkSet        : PropStr := '[Set]   ';
      tkEnumeration: PropStr := '[Enum]  ';
    else
      PropStr := '[Field] ';
    end;

    sName := PropList[I]^.Name; //名稱
    sValue := GetPropValue(AClass, sName ); //值

    sClass := PropList[I]^.PropType^.Name; //類別

    PropStr := PropStr + PropList[I]^.Name;
    PropStr := PropStr + ': ' + sClass ;
    PropStr := PropStr + ' Value='+sValue;
    AStrings.Add(PropStr);
  end;
  FreeMem(PropList);
end;

轉貼/改寫至 https://tcoline.com/resource/Delphi/typeinfo/top_delphi_typeinfo_0.htm

enum(枚舉)型態取得對應名稱的簡易作法

Const
  QRUnitDesc:Array[TQRUnit] of String=('MM', 'Inches', 'Pixels', 'Characters', 'Native');

procedure TForm1.Button1Click(Sender: TObject);

var iUnit:TQRUnit;

begin

  //Page Units
  ShowMessage(QRUnitDesc[QuickRep1.Page.Units]);

  // List

  for iUnit := Low(QRUnitDesc) to High(QRUnitDesc) do

  begin

    ShowMessage(QRUnitDesc[iUnit]);

  end;

end;

----

Uses TypInfo;

procedure TForm1.Button1Click(Sender: TObject);

var sEnumName:String;

begin

  sEnumName := GetEnumName(TypeInfo(TFieldType), Integer(ftString));

  ShowMessage(sEnumName);

end;

程式在非中文語系的系統中操作中文檔名的文件，中文會變成亂碼 ?????...

程式在非中文語系的系統中操作中文檔名的文件，中文會變成亂碼 ?????... 

問題排除方式

Control Panel (控制台)

Region 

How to Generate Code 128 Barcode Font for Excel (With Easy Steps)

 

轉貼/作法參考: https://www.exceldemy.com/code-128-barcode-font-for-excel/

STEP 1: Download Code 128 Font

• First of all, you need to download Code 128 You can download the font from this link.
• After that, extract the downloaded folder to the C:\Windows\Fonts folder.
• Otherwise, unzip the downloaded folder, copy the Code 128 font and paste it to the C:\Windows\Fonts folder.
• Also, select Continue if the administrator permissions window appears.

下載Code 128條碼字型，必須搭配Code128編碼後的文字使用。

STEP 2: Apply VBA Code

在Excel文件裡建立資料編碼的模組函式。

網頁中內文附的VBA程式碼貼過來使用，會發現之後產生出來的條碼刷不出來。後來發現是Unicode的關係，造成編碼內容錯誤。

VBA程式碼中

Chr() 要修正成 ChrW()

Asc() 要修正成 AscW()

修正後內容如下

Option Explicit
Public Function Code128(SourceString As String)
    Dim Counter As Integer
    Dim CheckSum As Long
    Dim mini As Integer
    Dim dummy As Integer
    Dim UseTableB As Boolean
    Dim Code128_Barcode As String
    If Len(SourceString) > 0 Then
        For Counter = 1 To Len(SourceString)
            Select Case AscW(Mid(SourceString, Counter, 1))
                Case 32 To 126, 203
                Case Else
                    MsgBox "Invalid character in barcode string" & vbCrLf & vbCrLf & "Please only use standard ASCII characters", vbCritical
                    Code128 = ""
                    Exit Function
            End Select
        Next
        Code128_Barcode = ""
        UseTableB = True
        Counter = 1
        Do While Counter <= Len(SourceString)
            If UseTableB Then
                mini = IIf(Counter = 1 Or Counter + 3 = Len(SourceString), 4, 6)
                GoSub testnum
                If mini% < 0 Then
                    If Counter = 1 Then
                        Code128_Barcode = ChrW(205)
                    Else
                        Code128_Barcode = Code128_Barcode & ChrW(199)
                    End If
                    UseTableB = False
                Else
                    If Counter = 1 Then Code128_Barcode = ChrW(204)
                End If
            End If
            If Not UseTableB Then
                mini% = 2
                GoSub testnum
                If mini% < 0 Then
                    dummy% = Val(Mid(SourceString, Counter, 2))
                    dummy% = IIf(dummy% < 95, dummy% + 32, dummy% + 100)
                    Code128_Barcode = Code128_Barcode & ChrW(dummy%)
                    Counter = Counter + 2
                Else
                    Code128_Barcode = Code128_Barcode & ChrW(200)
                    UseTableB = True
                End If
            End If
            If UseTableB Then
                Code128_Barcode = Code128_Barcode & Mid(SourceString, Counter, 1)
                Counter = Counter + 1
            End If
        Loop
        For Counter = 1 To Len(Code128_Barcode)
            dummy% = AscW(Mid(Code128_Barcode, Counter, 1))
            dummy% = IIf(dummy% < 127, dummy% - 32, dummy% - 100)
            If Counter = 1 Then CheckSum& = dummy%
            CheckSum& = (CheckSum& + (Counter - 1) * dummy%) Mod 103
        Next
        CheckSum& = IIf(CheckSum& < 95, CheckSum& + 32, CheckSum& + 100)
        Code128_Barcode = Code128_Barcode & ChrW(CheckSum&) & ChrW$(206)
    End If
    Code128 = Code128_Barcode
    Exit Function
testnum:
        mini% = mini% - 1
        If Counter + mini% <= Len(SourceString) Then
            Do While mini% >= 0
                If AscW(Mid(SourceString, Counter + mini%, 1)) < 48 Or AscW(Mid(SourceString, Counter + mini%, 1)) > 57 Then Exit Do
            mini% = mini% - 1
            Loop
        End If
        Return
End Function

 

STEP 3: Use Code 128 Function

建立模組函式後，就可以在儲存格中使用。

Ex:

  =Code128("ABCDEFG")

  =Code128(A1)

使用函式後會得到Code128編碼後的字串

STEP 4: Change Font Theme and Size

針對Code128編碼後的文字更換為Code 128的字型(STEP 1下載安裝的字型)。

在字型下拉選項中可能找不到，可以手動輸入 Code 128 字型就會被套用。

進行到這個步驟Code 128條碼的部份就可以正確顯示出來了。

Access violation at address xxxxxxxx in module 'rtl70.bpl'. read of address xxxxxxxx

 

程式中使用到QuickReport物件，機器設備上必須先設定有印表機，如果是網路印表機，必須是已連線的狀態。

CheckListBox 勾選項目用顏色反應，加強可讀性。

 

type
  TForm1 = class(TForm)
    ...
  public
    { Public declarations }
    procedure pr_CheckListBox_OnDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
    procedure pr_CheckListBox_Exit(Sender: TObject);
    procedure pr_Set_Highlight_For_CheckListBox(AOwner:TWinControl);
  end;

CheckListBox.Style := lbOwnerDrawFixed;

//用來覆寫CheckListBox.OnDrawItem事件，對已勾選的項目做文件上的變化

procedure TForm1.pr_CheckListBox_OnDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);

var sStr:String;

begin

  TCheckListBox(Control).Canvas.Font.Color := TCheckListBox(Control).Font.Color;

  TCheckListBox(Control).Canvas.Font.Style := TCheckListBox(Control).Font.Style;

  if (odSelected in State) then

  begin

    TCheckListBox(Control).Canvas.Font.Color := clWhite;

  end;

  if TCheckListBox(Control).Checked[Index] then

  begin

    TCheckListBox(Control).Canvas.Font.Color := clRed;

    TCheckListBox(Control).Canvas.Font.Style := [fsBold];

  end;

  TCheckListBox(Control).Canvas.FillRect(Rect);

  sStr := TCheckListBox(Control).Items[Index];

  TCheckListBox(Control).Canvas.TextRect(Rect, sStr);

end;

//用來覆寫CheckListBox.OnExit事件，選焦點被移開時，取消停佇項目的反色選取

procedure TForm1.pr_CheckListBox_Exit(Sender: TObject);

begin

  TCheckListBox(Sender).ClearSelection;

end;

//執行此函式將畫面上所有的CheckListBox做處理

procedure TForm1.pr_Set_Highlight_For_CheckListBox(AOwner:TWinControl);

var i:Integer;

begin

  for i := 0 to Self.ComponentCount-1 do

  begin

    if Self.Components[i] is TCheckListBox then

    begin

      TCheckListBox(Self.Components[i]).Style := lbOwnerDrawFixed;

      TCheckListBox(Self.Components[i]).OnDrawItem := pr_CheckListBox_OnDrawItem;

      TCheckListBox(Self.Components[i]).OnExit := pr_CheckListBox_Exit;

    end;

  end;

end;