加載字型

s := ExtractFilePath( Application.ExeName)+'font2\【華康】POP體w5.TTC';

AddFontResource(pchar(s));


在onformcreate中加入 AddFontResourceex('D:\DoulosSILR.ttf',FR_PRIVATE,nil) ;這個字型不會被其他程序所看見. AddFontResourceex('D:\DoulosSILR.ttf',FR_PRIVATE or FR_NOT_ENUM,nil) ;這個字型不會被其他程序所看見, 也不會出現在screen.fonts中, 只是可以用.

鍵盤模仿

keybd_event function

要做indy server client 端程式測試的時候,不能程式自己client call自己server ,一定要分成兩隻程式執行才會正常

base 64 encode/decode

要做base64 有兩個現成的
如果只是短句子,還是base64.pas方便
如果要做檔案 用UUCode.pas

KTOP裏看到一個數獨程式,把set 特性發揮的真好,先備一份以後可以參考

procedure TfrmMain.Button1Click(Sender: TObject);
var
Sudos: TBytes;
I, K, L, C, R: Byte;
S: array[0..2] of TByteSet;
AreaSet: array[0..8] of TByteSet;//作為比對
iCount:integer;
begin
iCount := 0;
Sudos := nil;
repeat
Done := True;
for I := 0 to 8 do AreaSet[I] := [];
FillChar(ResultTable, SizeOf(ResultTable), $FF);
for I := 0 to 80 do
begin
C := I mod 9;
R := I div 9;
K := (R div 3) * 3 + (C div 3);
S[0] := [0..8] - ColSet(C); //Column Available SudoSet 這種用法真聰明,我看不用set很難做
S[1] := [0..8] - RowSet(R); //Row Available SudoSet
S[2] := [0..8] - AreaSet[K]; //Area Available SudoSet
S[0] := S[0] * S[1] * S[2]; //Intersection: The Available SudoSet 找出集合再用暴力法try
if S[0] = [] then
begin
Done := False ;
inc(iCount);
end
else begin
Sudos := SetToBytes(S[0], 9); //Random Selection
L := Sudos[Random(Length(Sudos))];
AreaSet[K] := AreaSet[K] + [L];
ResultTable[C, R] := L;
end;
end;
until Done;

Repaint;//繪出數讀表
Caption := IntToStr(iCount);

end;

function TfrmMain.SetToBytes(ASet: TByteSet; Range: Integer): TBytes;
var
I, J: Byte;
begin
SetLength(Result, Range);
J := 0;
for I := 0 to Range-1 do
begin
if I in ASet then
begin
Result[J] := I;
ASet := ASet - [I];
Inc(J);
end;
if ASet = [] then Break;
end;
SetLength(Result, J);
end;

function TfrmMain.ColSet(Index: Integer): TByteSet;
var
I: Integer;
begin
Result := [];
for I := 0 to 8 do
if ResultTable[Index, I] <> $FF then
Result := Result + [ResultTable[Index, I]];
end;

function TfrmMain.RowSet(Index: Integer): TByteSet;
var
I: Integer;
begin
Result := [];
for I := 0 to 8 do
if ResultTable[I, Index] <> $FF then
Result := Result + [ResultTable[I, Index]];
end;

有底色的不規則多邊形繞邊,已經實作成功

初始想法是這樣,反正順時針找路徑,第一次碰到從O變X的地方就是要前進的方向,假設是封閉的圖形,一定可以繞回原點,下面是實作程式

function TForm1.CreateRgnByCanvasColorXDiff(Can: TCanvas): HRGN;
var i,j,x,y:integer;
cDefault:TColor;
FirstP,NowPoint:TPoint;
pAry:Array of TPoint;
pCount:Integer;

procedure FindFirstPoint();
var i,j:integer;
begin
for i := 1 to Can.ClipRect.Right-1 do
for j := 1 to Can.ClipRect.Bottom-1 do
if Can.Pixels[i,j] <> cDefault then
begin
FirstP.X := i-1;
FirstP.Y := j-1;
exit;
end;
end;

procedure AddPointAndSetNowPoint(XX,YY:integer);
begin
pAry[pCount].X := xx+1;
pAry[pCount].Y := yy+1;
inc(pCount);
X := XX;
Y := YY;
end;

begin
cDefault := Can.Pixels[1,1]; //選背景色

//繞邊界
//先找到第一個點
FindFirstPoint;
// 依據 田 形狀判斷 最多十二種可能
// 位置 依序是左上,右上,右下,左下 (左上等同原點,右上是X軸+1的點,右下是X+1,Y+1的點,左下是Y+1的點
// +X OOXO OOXX XOXX (第二個是O,第三個是X) O表示原底色,X表示和底不同色
// -X XOOO XXOO XXXO (第四個是O,第一個是X)
// +Y OOOX XOOX XXOX (第三個是O,第四個是X)
// -Y OXOO OXXO OXXX (第一個是O,第二個是X)
//所以簡單說只要判斷四種,
X := FirstP.X;
Y := FirstP.Y;
NowPoint.X := 0;
NowPoint.Y := 0;

SetLength(pAry,10000);
pCount := 0;

repeat

if (Can.Pixels[X+1,Y]=cDefault) and (Can.Pixels[X+1,Y+1] <> cDefault) then
AddPointAndSetNowPoint(X+1,Y)
else
if (Can.Pixels[X,Y+1]=cDefault) and (Can.Pixels[X,Y] <> cDefault) then
AddPointAndSetNowPoint(X-1,Y)
else
if (Can.Pixels[X+1,Y+1]=cDefault) and (Can.Pixels[X,Y+1] <>cDefault) then
AddPointAndSetNowPoint(X,Y+1)
else
if (Can.Pixels[X,Y]=cDefault) and (Can.Pixels[X+1,Y] <>cDefault) then
AddPointAndSetNowPoint(X,Y-1);

until (X = FirstP.X) and (Y = FirstP.Y);

Result := CreatePolygonRgn(pAry[0],pCount,ALTERNATE);

end;



還有幾個漏洞,我把點數設成10000點,沒做例外控制,萬一繞不回原點也沒處理,我也假設只有一個多邊形,多邊形沒碰到圖檔邊界,這些細部應該還可以加強....如果做這麼完美,都可以去當論文 哈

還需要做延邊繞的剪影的多邊形function, 用掃描那個有些鋸齒挖不到

做字型樣式的按鈕

有看到別人用字型做RGN,原來是 API有提供

procedure TForm1.Button2Click(Sender: TObject);
var RGN:HRGN;
begin
BeginPath(Label1.Canvas.Handle);
Label1.Canvas.TextOut(5,5,'中文');
EndPath(Label1.Canvas.Handle);
RGN:=PathToRegion(Label1.Canvas.Handle);

SetWindowRgn(Button1.Handle,RGN,True);
DeleteObject(RGN);
end;

利用Canvas 中圖形色差造多邊形,包成function,感覺不是很快,400*400的圖要0.2秒左右,已經到能感覺出來的程度

function TForm1.CreateRgnByCanvasColorDiff(Can: TCanvas; Diff: Byte): HRGN;
var P:array of TPoint;
i,j,PCount:integer;
RGN:HRGN;
//計算是否有色差
function ColorDiff(ColorA, ColorB: TColor;Diff:Byte): boolean;
var c:TColor;
begin
c := (ColorA xor ColorB);
Result := not ((GetRValue(c) < Diff) and (GetGValue(c) < Diff) and (GetBValue(c) < Diff) );
end;
begin
//逐行掃描 , 如果 [I,J] <> [I,J+1] -->邊界, 算出左邊界 然後 右邊界
SetLength(P,Can.ClipRect.Bottom*2);
PCount := 0;
//取左邊界線
for j := 1 to Can.ClipRect.Bottom-1 do
for i := 1 to Can.ClipRect.Right-1 do
begin
if ColorDiff(Can.Pixels[i,j],Can.Pixels[i,j+1],Diff) then
begin
P[PCount].X := i;
P[PCount].Y := j;
Inc(PCount);
break;
end;
end;

//取右邊界線
for j := Can.ClipRect.Bottom-1 downto 1 do
for i := Can.ClipRect.Right-1 downto 1 do
begin
if ColorDiff(Can.Pixels[i,j],Can.Pixels[i,j-1],Diff) then
begin
//if i < 5 then break;
P[PCount].X := i;
P[PCount].Y := j;
Inc(PCount);
break;
end;
end;
Result := CreatePolygonRgn(P[0],PCount,ALTERNATE);

end;

簡單的顏色比對 , 計算顏色差 RGB各小於Byte的差異

function TForm1.ColorDiff(ColorA, ColorB: TColor;Diff:Byte): boolean;
var c:TColor;
begin
c := (ColorA xor ColorB);
Result := not ((GetRValue(c) < Diff) and (GetGValue(c) < Diff) and (GetBValue(c) < Diff) );
end;

還要做顏色比對

建立多邊形要利用顏色比對,但現在還沒想出怎樣顏色比對
現在用這種做法
Label1.Canvas.Pixels[i,j]<>Label1.Canvas.Pixels[i,j-1]
有缺點,只能比對黑白色圖,要想辦法做 顏色色差比對,要差一定比例才算邊界

用從上到下,從左到右掃描的方式也有漏洞, 當圖形是有內凹的凹的部分會算不到, 比如說五角星還OK,十二角星就不行了,兩星角之間的位置抓不到

當然三角形的按鈕就很容易實作

var
P: array[0..3] of TPoint;
FRegion: HRGN;
begin
P[0] := Point(0,100);
P[1] := Point(100,0);
P[2] := Point(200,100);

FRegion := CreatePolygonRgn(P, 3,ALTERNATE); //<-- 如果是動態陣列,第一個參數要傳P[0]
SetWindowRgn(Button1.Handle, FRegion, True);

多邊形製作,當然Panel,Form...都可以

參考以前一些文章,總是沒人寫很容易懂的範例,自己實作,對LABEL上的圖做比對,算出左右邊界線,變更Panel 的圖形


想法:從上到下從左到右掃描,當點素色Color不同時就當作邊界,要做一個封閉的多邊形,要先從左邊界連下來
再從右邊界往上連回去

procedure TForm1.Button1Click(Sender: TObject);
var PALL:array of TPoint;
i,j,PLCount:integer;
RGN:HRGN;
begin
//逐行掃描 , 如果 [I,J] <> [I,J+1] -->邊界, 算出左邊界 然後 右邊界

SetLength(PALL,Label1.ClientHeight*2);
PLCount := 0;

//取左邊界線
for i := 1 to Label1.ClientHeight-1 do
for j := 1 to Label1.ClientWidth-1 do
begin
if Label1.Canvas.Pixels[i,j]<>Label1.Canvas.Pixels[i,j+1] then
begin
PALL[PLCount].X := i;
PALL[PLCount].Y := j;
Inc(PLCount);
break;
end;
end;

//取右邊界線
for i := Label1.ClientHeight-1 downto 1 do
for j := Label1.ClientWidth-1 downto 1 do
begin
if Label1.Canvas.Pixels[i,j]<>Label1.Canvas.Pixels[i,j-1] then
begin
PALL[PLCount].X := i;
PALL[PLCount].Y := j;
Inc(PLCount);
break;
end;
end;

RGN := CreatePolygonRgn(PALL[0],PLCount,ALTERNATE);//建立一個多邊形區域

SetWindowRgn(Panel1.Handle,RGN,True);// 可以變Panel,當然其他物件也可以


end;

alpha blending 的做法大概就是如此,看wiki的

基本原理是這樣,但這樣算我想應該會很慢....而且也沒這麼好實做到delphi物件上,
因為alphi blending 需要合併上下物件顏色來使上層物件顏色透明,但抓不到下層物件顏色就白說了
delphi把物件PAINT 封裝的太完整,想要切到裡面去改...很麻煩



var t:TColor;
R,G,B:Byte;
begin
R := Round((1-0.5) * GetRValue( Form1.Color) + 0.5 * GetRValue( Label1.Color));
G := Round((1-0.5) * GetGValue( Form1.Color) + 0.5 * GetGValue( Label1.Color));
B := Round((1-0.5) * GetBValue( Form1.Color) + 0.5 * GetBValue( Label1.Color));
Label1.Color := RGB(R,G,B);

不規則按鈕

procedure TForm1.Button3Click(Sender: TObject);
var
Region1 : THandle;
begin
Region1 :=Button1.Handle;
Region1 := CreateEllipticRgn(10,10,Button1.Width-4,Button1.Height-4);
SetWindowRgn(Button1.Handle, Region1, True );//<--重點在可以設定Rgn 我猜不規則多邊形應該也可以
end;