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;

穿著Prada的惡魔 (The Devil Wears Prada)

 

擴展QuckReport報表內容

報表內容過多過長， Report礙於報表的設計空間，開發階段不容易將報表元件放置到適當的位置。可以在Form上，放置多個QuickRep報表元件，在不同的QuickRep元件中利用ChildBand來設計，再用程式碼控制將ChildBand併到主報表裡做預覽。

uses QRPrntr;

type TQRPrintableExt=class(TQRPrintable);

procedure TForm1.pr_Reset_ParentReport(AChildBand:TQRChildBand; AParentBand:TQRCustomBand);

var i:Integer;

begin

  AChildBand.Parent := AParentBand.ParentReport;

  AChildBand.ParentBand := AParentBand;

  for i := 0 to AChildBand.ControlCount-1 do

    TQRPrintableExt(AChildBand.Controls[i]).ParentReport := AChildBand.ParentReport;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

  pr_Reset_ParentReport(ChildBand1, DetailBand1);

  pr_Reset_ParentReport(QRChildBand1, ChildBand1);

  QuickRep1.Preview;

end;

輸出結果:

TCategoryPanelGroup - MouseWheel : Not functional ?

 //---------------
//Form MouseWheel
//---------------
procedure TForm.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
  if PtInRect(CategoryPanelGroup1.BoundsRect, ScreenToClient(Mouse.CursorPos)) then
    CategoryPanelGroup1MouseWheel(Sender, Shift, WheelDelta, MousePos, Handled);
end;

//-----------------------------
//CategoryPanelGroup MouseWheel
//-----------------------------
procedure TForm.CategoryPanelGroup1MouseWheel(Sender: TObject;
  Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
  var Handled: Boolean);
var
  msg: Cardinal;
  code: Cardinal;
  i, n: Integer;
begin // Thanks to *Peter Below* for this code (adapted here)
  Handled := true;
  if ssShift in Shift then
    msg := WM_HSCROLL
  else
    msg := WM_VSCROLL;
  if WheelDelta > 0 then
    code := SB_LINEUP
  else
    code := SB_LINEDOWN;
  n:= Mouse.WheelScrollLines;
  for i:= 1 to n do
    CategoryPanelGroup1.Perform(msg, code, 0);
  CategoryPanelGroup1.Perform(msg, SB_ENDSCROLL, 0);
end;

轉貼至:https://codeverge.com/embarcadero.delphi.nativeapi/tcategorypanelgroup-mousewheel-n/1065463

Excel Class Workbook 的 SaveAs 方法失敗

 

操作遠端連線在Terminal主機使用相同的程式，部份使用者在操作Excel匯出時會出現「Class Workbook 的 SaveAs 方法失敗」，需要將使用者的UserProfile刪除，重新登入後讓系統重建就可以正常匯出。

鬼影

 

洞悉真相

 

Contratiempo - 佈局(2017)

 

操作Printers.Printer.PrintIndex 無法變更 QuickReport PrintSetup裡的輸出印表機!?

Uses Printers;

...

Printers.Printer.PrintIndex := 1;  //指定輸出的印表機索引，不會變更預設印表機

...

TPrintDialog會依據PrintIndex的變更指向對應的印表機，

QuickReport PrintSetup沒有因為PrintIndex變更指定輸出的印表機，維持指向預設印表機。

修正QuickReport QRPrnSu.pas文件

Ver. QuickRep506 
File : QRPrnSu.pas
Proceure : GetPrinter

原內容

{ TQRBasePrintDialog }
// HERE the important changes - see dialogs.pas from delphi vcl - source.
// note the Brackets and type casts! It's tricky :-)

procedure TQRBasePrintDialog.GetPrinter(var DeviceMode, DeviceNames: THandle);

var

  DevNames: PDevNames;

  Offset: PChar;

  size : integer;

begin

  FPrinter.GetPrinter(Device, Driver, Port, DeviceMode);

  if DeviceMode <> 0 then

  begin

    size:=SizeOf(TDevNames) +

          (StrLen(Device) + StrLen(Driver) + StrLen(Port) + 3) *Sizeof(Char);

    //DeviceNames := GlobalAlloc(GHND,SizeOf(TDevNames) +

    //               (StrLen(Device) + StrLen(Driver) + StrLen(Port) + 3) *Sizeof(Char));

    //DevNames := PDevNames(GlobalLock(DeviceNames));

    GetMem(DevNames, Size);

    try

      Offset := PChar(PByte(DevNames) + SizeOf(TDevnames));

      with DevNames^ do

      begin

        wDriverOffset := NativeInt(Offset) - NativeInt(DevNames);

        Offset := StrECopy(Offset, Driver) + 1;

        wDeviceOffset := NativeInt(Offset) - NativeInt(DevNames);

        Offset := StrECopy(Offset, Device) + 1;

        wOutputOffset := NativeInt(Offset) - NativeInt(DevNames);;

        StrCopy(Offset, Port);

      end;

    finally

      //GlobalUnlock(DeviceNames);

      FreeMem(DevNames, Size);

    end;

  end;

end;

參考備註指定的 Dialogs.pas 修正

{ TQRBasePrintDialog }
// HERE the important changes - see dialogs.pas from delphi vcl - source.
// note the Brackets and type casts! It's tricky :-)

procedure TQRBasePrintDialog.GetPrinter(var DeviceMode, DeviceNames: THandle);

var

  DevNames: PDevNames;

  Offset: PChar;

  size : integer;

begin

  FPrinter.GetPrinter(Device, Driver, Port, DeviceMode);

  if DeviceMode <> 0 then

  begin

    //size:=SizeOf(TDevNames) +

    //      (StrLen(Device) + StrLen(Driver) + StrLen(Port) + 3) *Sizeof(Char);

    DeviceNames := GlobalAlloc(GHND, SizeOf(TDevNames) +

                   (StrLen(Device) + StrLen(Driver) + StrLen(Port) + 3) *Sizeof(Char));

    DevNames := PDevNames(GlobalLock(DeviceNames));

    //GetMem(DevNames, Size);

    try

      Offset := PChar(PByte(DevNames) + SizeOf(TDevnames));

      with DevNames^ do

      begin

        wDriverOffset := Offset - PChar(DevNames);

        Offset := StrECopy(Offset, Driver) + 1;

        wDeviceOffset := Offset - PChar(DevNames);

        Offset := StrECopy(Offset, Device) + 1;

        wOutputOffset := Offset - PChar(DevNames);;

        StrCopy(Offset, Port);

      end;

    finally

      GlobalUnlock(DeviceNames);

      //FreeMem(DevNames, Size);

    end;

  end;

end;

QRPrnSu.pas修正後儲存，重新編譯/安裝 QR506DesignDXE10.bpl、QR506RunDXE10.bpl

DLL MDI Form 切換

 procedure pr_PageBtn_OnClick(Sender: TObject);
var
   i, j:integer;
   vhandle,xhandle:Thandle;
   vbuffer: array[0..255] of char;
   apfunc : Pointer;
//   p: PInteger;
begin
   //Dll Form
   vhandle := StrToInt(Copy(TSpeedButton(Sender).Name, 2, Length(TSpeedButton(Sender).Name)-1));
   if vhandle = 0 then
      exit;
   while vhandle <> 0  do
   begin
      GetClassName(vhandle, vbuffer, SizeOf(vbuffer));
      if vhandle = strtoint(copy(TSpeedButton(Sender).Name, 2, length(TSpeedButton(Sender).Name)-1)) then
      begin
         if vhandle > 0 then
         begin
           xhandle := findwindowex(vhandle, 0, 'MDIClient', nil);
           xhandle := getwindow(vhandle, GW_CHILD);
           SendMessage(vhandle, WM_CHILDACTIVATE, 0, 0);
         end
         else begin
            TSpeedButton(Sender).Destroy;
            TSpeedButton(Sender).Free;
            self.Refresh;
         end;
         break;
      end;
   end;
end;

Delphi VFW 操作Web Cam影像輸出，出現黑屏的解決方式

VFW 操作Web Cam影像輸出，換了不同型號的Web Cam出現黑屏，原來是「視訊格式」不同造成。

Code:

    hCapWnd := THandle;

    hCapWnd := capCreateCaptureWindow('Cam. Window',WS_VISIBLE or WS_CHILD, 

      0, 0, Panel1.Width, Panel1.Height, Panel1.Handle, 0);

    capDriverConnect(hCapWnd, 0); 

    capDlgVideoFormat(hCapWnd); //會出現「視訊各式」的視窗

將「像素深度(位元)及壓縮」設置成 YUY2 即可

Excel 操作出現 "外部資料表不是預期的格式"

 

用程式操作開啟Excel文件，出現 "外部資料表不是預期的格式" 

或是用Excel開啟文件，出現檔案格式不相符的訊息

存檔時將文件格式指定為 "一般活頁簿"，可以排除這類的狀況。

excel := CreateOleObject('Excel.Application');

excel.Visible := False;

excel.Workbooks.Add;

workbook := excel.Workbooks[1];

...

...

workbook.SaveAs(OleVariat(filename), -4143);

轉貼自 https://docs.microsoft.com/zh-tw/office/vba/api/excel.xlfileformat

XlFileFormat 列舉 (Excel)

會指定儲存工作表時的檔案格式。

名稱	值	描述	副檔名
xlAddIn	18	Microsoft Excel 97-2003 增益集	*.xla
xlAddIn8	18	Microsoft Excel 97-2003 增益集	*.xla
xlCSV	6	CSV	*.csv
xlCSVMac	22	Macintosh CSV	*.csv
xlCSVMSDOS	24	MSDOS CSV	*.csv
xlCSVUTF8	62	UTF8 CSV	*.csv
xlCSVWindows	至	Windows CSV	*.csv
xlCurrentPlatformText	-4158	目前平台文字	*.txt
xlDBF2	7	Dbase 2 格式	*.dbf
xlDBF3	8	Dbase 3 格式	*.dbf
xlDBF4	11	Dbase 4 格式	*.dbf
xlDIF	9	資料交換格式	*.dif
xlExcel12	50	Excel 二進位活頁簿	*.xlsb
xlExcel2	16	Excel 2.0 版 (1987)	*.xls
xlExcel2FarEast	7	Excel 2.0 遠東版 (1987)	*.xls
xlExcel3	29	Excel 3.0 版 (1990)	*.xls
xlExcel4	33	Excel 4.0 版 (1992)	*.xls
xlExcel4Workbook	35	Excel 4.0 版 活頁簿格式 (1992)	*.xlw
xlExcel5	39	Excel 5.0 版 (1994)	*.xls
xlExcel7	39	Excel 95 (7.0 版)	*.xls
xlExcel8	56	Excel 97-2003 活頁簿	*.xls
xlExcel9795	43	Excel 95 與 97 版	*.xls
xlHtml	44	HTML 格式	.htm；.html
xlIntlAddIn	得到	國際增益集	沒有副檔名
xlIntlMacro	0.25	國際巨集	沒有副檔名
xlOpenDocumentSpreadsheet	60	OpenDocument 試算表	*.ods
xlOpenXMLAddIn	55	開啟 XML 增益集	*.xlam
xlOpenXMLStrictWorkbook	61 (&H3D)	Strict Open XML 檔案	*.xlsx
xlOpenXMLTemplate	54	開啟 XML 範本	*.xltx
xlOpenXMLTemplateMacroEnabled	53	開啟 Open XML 範本巨集啟用	*.xltm
xlOpenXMLWorkbook	51	開啟 XML 活頁簿	*.xlsx
xlOpenXMLWorkbookMacroEnabled	52	開啟 XML 活頁簿巨集啟用	*.xlsm
xlSYLK	第	符號連結格式	*.slk
xlTemplate	17	Excel 範本格式	*.xlt
xlTemplate8	17	範本 8	*.xlt
xlTextMac	19	Macintosh 文字	*.txt
xlTextMSDOS	21	MSDOS 文字	*.txt
xlTextPrinter	36	印表機文字	*.prn
xlTextWindows	共	Windows 文字	*.txt
xlUnicodeText	42	Unicode 文字	沒有副檔名；*.txt
xlWebArchive	45	Web 封存	.mht；.mhtml
xlWJ2WD1	14	日文 1-2-3	*.wj2
xlWJ3	40	日文 1-2-3	*.wj3
xlWJ3FJ3	41	日文 1-2-3 格式	*.wj3
xlWK1	5	Lotus 1-2-3 格式	*.wk1
xlWK1ALL	加	Lotus 1-2-3 格式	*.wk1
xlWK1FMT	大約	Lotus 1-2-3 格式	*.wk1
xlWK3	15	Lotus 1-2-3 格式	*.wk3
xlWK3FM3	32	Lotus 1-2-3 格式	*.wk3
xlWK4	38	Lotus 1-2-3 格式	*.wk4
xlWKS	4	Lotus 1-2-3 格式	*.wks
xlWorkbookDefault	51	預設活頁簿	*.xlsx
xlWorkbookNormal	-4143	一般活頁簿	*.xls
xlWorks2FarEast	日	Microsoft Works 2.0 遠東格式	*.wks
xlWQ1	34	Quattro Pro 格式	*.wq1
xlXMLSpreadsheet	46	XML 試算表	*.xml