Peter's Blog

2023年3月15日星期三

Delphi ForceDirectories 建立資料夾

ForceDirectories 建置到指定的層級目錄

Ex :

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

2023年3月9日星期四

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

Select *
(

Select Field01, Field02, Field03, Field04

From Table1

) a

Pivot

(

Sum(Field05) /*合計值*/

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

) b

2023年3月6日星期一

ScorllBar 系統寬高

ScrollBar High

GetSystemMetrics(SM_CYHSCROLL)

ScrollBar Width

GetSystemMetrics(SM_CXVSCROLL)

2023年2月8日星期三

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;

2023年1月16日星期一

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

2023年1月3日星期二

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

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

[Project] > [Options...]

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

參考:

2022年12月22日星期四

取得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;

----

Uses TypInfo;

procedure TForm1.Button1Click(Sender: TObject);

var sEnumName:String;

begin

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

ShowMessage(sEnumName);

end;

2022年12月21日星期三

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

問題排除方式

Control Panel (控制台)

Region

2022年12月6日星期二

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條碼的部份就可以正確顯示出來了。

2022年11月29日星期二

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

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

2022年10月4日星期二

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;

2022年8月17日星期三

穿著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;

輸出結果:

2022年8月10日星期三

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

2022年8月2日星期二

Excel Class Workbook 的 SaveAs 方法失敗

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

2022年7月27日星期三

鬼影

洞悉真相

2022年7月25日星期一

Contratiempo - 佈局(2017)

2022年6月15日星期三

操作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;

參考備註指定的 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;

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

訂閱：文章 (Atom)

2023年3月15日 星期三

2023年3月9日 星期四

2023年3月6日 星期一

2023年2月8日 星期三

2023年1月16日 星期一

2023年1月3日 星期二

2022年12月22日 星期四

2022年12月21日 星期三

2022年12月6日 星期二

STEP 1: Download Code 128 Font

STEP 2: Apply VBA Code

STEP 3: Use Code 128 Function

STEP 4: Change Font Theme and Size

2022年11月29日 星期二

2022年10月4日 星期二

2022年8月17日 星期三

2022年8月10日 星期三

2022年8月2日 星期二

2022年7月27日 星期三

2022年7月25日 星期一

2022年6月15日 星期三

2023年3月15日星期三

2023年3月9日星期四

2023年3月6日星期一

2023年2月8日星期三

2023年1月16日星期一

2023年1月3日星期二

2022年12月22日星期四

2022年12月21日星期三

2022年12月6日星期二

2022年11月29日星期二

2022年10月4日星期二

2022年8月17日星期三

2022年8月10日星期三

2022年8月2日星期二

2022年7月27日星期三

2022年7月25日星期一

2022年6月15日星期三