java double buffer 作法

來源
http://www.realapplets.com/tutorial/DoubleBuffering.html

讚

/* Drawing in applets is almost always done with double-buffering.
This means that drawing is first done to an offscreen image, and when all
is done, the offscreen image is drawn on the screen.
This reduces the nasty flickering applets otherwise have.
Above you see:
No Double-buffering : It flickers because everything is draw straight to the screen.
Bad double-buffering: Same as this below but without the update() method
Double Buffering: Example of this source.
*/

import java.applet.*;
import java.awt.event.*;
import java.awt.*;

public class DoubleBuffering extends Applet implements MouseMotionListener
{
// The object we will use to write with instead of the standard screen graphics
Graphics bufferGraphics;
// The image that will contain everything that has been drawn on
// bufferGraphics.
Image offscreen;
// To get the width and height of the applet.
Dimension dim;
int curX, curY;

public void init()
{
// We'll ask the width and height by this
dim = getSize();
// We'll redraw the applet eacht time the mouse has moved.
addMouseMotionListener(this);
setBackground(Color.black);
// Create an offscreen image to draw on
// Make it the size of the applet, this is just perfect larger
// size could slow it down unnecessary.
offscreen = createImage(dim.width,dim.height);
// by doing this everything that is drawn by bufferGraphics
// will be written on the offscreen image.
bufferGraphics = offscreen.getGraphics();
}

public void paint(Graphics g)
{
// Wipe off everything that has been drawn before
// Otherwise previous drawings would also be displayed.
bufferGraphics.clearRect(0,0,dim.width,dim.width);
bufferGraphics.setColor(Color.red);
bufferGraphics.drawString("Bad Double-buffered",10,10);
// draw the rect at the current mouse position
// to the offscreen image
bufferGraphics.fillRect(curX,curY,20,20);
// draw the offscreen image to the screen like a normal image.
// Since offscreen is the screen width we start at 0,0.
g.drawImage(offscreen,0,0,this);
}

// Always required for good double-buffering.
// This will cause the applet not to first wipe off
// previous drawings but to immediately repaint.
// the wiping off also causes flickering.
// Update is called automatically when repaint() is called.

public void update(Graphics g)
{
paint(g);
}


// Save the current mouse position to paint a rectangle there.
// and request a repaint()
public void mouseMoved(MouseEvent evt)
{
curX = evt.getX();
curY = evt.getY();
repaint();
}


// The necessary methods.
public void mouseDragged(MouseEvent evt)
{
}

}

/*
This is all about double-buffering. It's easy to use and recommended to use always.
There is one dangerous pitfall here, when you create an offscreen image that's very large
the applet might run slow because it takes a lot of resources and effort.
I would not recommend offscreen images larger than 500*500 when redrawn at 30FPS.
(see Threads)
*/

java 載入圖檔方式

import java.awt.*;
import java.awt.event.*;
import java.awt.image.renderable.ParameterBlock;
import java.io.File;
import javax.media.jai.JAI;
import javax.media.jai.PlanarImage;
import javax.media.jai.RenderedOp;
import javax.media.jai.widget.ScrollingImagePanel;

public class FileTest extends WindowContainer {
 // Specify a default image in case the user fails to specify
 // one at run time.
 public static final String DEFAULT_FILE = "./images/glasses.jpg";
 public static void main(String args[]) {
  String fileName = null;
  // Check for a filename in the argument.
  if(args.length == 0) {
   fileName = DEFAULT_FILE;
  } else if(args.length == 1) {
   fileName = args[0];
  } else {
   System.out.println("\nUsage: java " + (new FileTest()).getClass().getName() + " [file]\n");
   System.exit(0);
  }
  new FileTest(fileName);
 }
 public FileTest() {}
 public FileTest(String fileName) {
  // Read the image from the designated path.
  System.out.println("Creating operation to load image from '" + fileName + "'");
  RenderedOp img = JAI.create("fileload", fileName);
  // Set display name and layout.
  setTitle(getClass().getName()+": "+fileName);
 
  // Display the image.
  System.out.println("Displaying image");
  add(new ScrollingImagePanel(img, img.getWidth(),  img.getHeight()));
  pack();
  show();
 }
}

 

class WindowContainer extends Frame implements WindowListener {

   public WindowContainer () {
     this.addWindowListener(this);
   }

   public void windowClosing(WindowEvent e) {
  System.exit(0);
   }
   public void windowOpened(WindowEvent e) {}
   public void windowClosed(WindowEvent e) {}
   public void windowIconified(WindowEvent e) {}
   public void windowDeiconified(WindowEvent e) {}
   public void windowActivated(WindowEvent e) {}
   public void windowDeactivated(WindowEvent e) {}

}

jpeg 轉 bmp方法

procedure Bmp2Jpeg(const BmpFileName, JpgFileName: string);
var
Bmp: TBitmap;
Jpg: TJPEGImage;
begin
Bmp := TBitmap.Create;
Jpg := TJPEGImage.Create;
try
Bmp.LoadFromFile(BmpFileName);
Jpg.Assign(Bmp);
Jpg.SaveToFile(JpgFileName);
finally
Jpg.Free;
Bmp.Free;
end;
end;

procedure Jpeg2Bmp(const BmpFileName, JpgFileName: string);
var
Bmp: TBitmap;
Jpg: TJPEGImage;
begin
Bmp := TBitmap.Create;
Jpg := TJPEGImage.Create;
try
Jpg.LoadFromFile(JpgFileName);
Bmp.Assign(Jpg);
Bmp.SaveToFile(BmpFileName);
finally
Jpg.Free;
Bmp.Free;
end;
end;

vista 中delphi 開發的程式發送封包權限不足的處理

http://delphi.ktop.com.tw/board.php?cid=168&fid=920&tid=99333

有關function節省編譯後空間? 真的有效嗎?沒試過

http://delphi.ktop.com.tw/board.php?cid=30&fid=70&tid=99044

1.type TDataProvider=class
2.private:
3. procedure _AppendData(SKey : String; SName : String; SValue1 : integer; SValue2 : String);
4.public:
5. procedure AppendData(SKey :String; SName : String);
6. procedure AppendData(SKey : String; SName : String; SValue2 : String);
7.end;
8.
9.//implementation;
10.
11.procedure TDataProvider._AppendData(SKey : String; SName : String; SValue1 : integer; SValue2 : String);
12.begin
13.//優先處理會被省略的參數
14.//原先的函式本體
15.end;
16.
17.procedure TDataProvider.AppendData(SKey : String; SName : String);
18.begin
19.self._AppendData(SKey, SName, nil, -1, nil);
20.end;
21.
22.procedure TDataProvider.AppendData(SKey : String; SName : String; SValue2 : String);
23.
24.begin
25.self._AppendData(SKey, SName, nil, -1, SValue2);
26.end;

ShellListView 選擇的檔案

procedure TForm1.ShellListView1MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var i:integer;
begin
  for i := 0 to ShellListView1.Items.Count-1 do
  begin
    if ShellListView1.Items[i].Selected then
      ShowMessage(ShellListView1.Folders[i].PathName); // 這就是檔案全路徑
  end;
end;

測試pas檔轉html 的功能

unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,StrUtils;

const VK_RTN = chr(13)+ chr(10);

type
  TMain = class(TForm)
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    Memo1: TMemo;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    ColorDialog1: TColorDialog;
    procedure Button1Click(Sender: TObject);
    procedure Label1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
  TmpStyle=(mpReservedWord, mpSymbol , mpString , mpComment ,mpSpace );

  TDataSec=record
    DataString:String;
    Style:TmpStyle;
  end;

  TPasFile=Class
    Data,FFileName:String;
  protected
    ReservedWordList:TStringList;
  public
    function EncodeToHtml:String;
    constructor Create(FileName:string);
    destructor Destroy;override;
  End;

var
  Main: TMain;

implementation

{$R *.dfm}

procedure TMain.Button1Click(Sender: TObject);
var o:TPasFile;
  s:String;
begin
  s := '中文實驗<>'' '' ';
  if OpenDialog1.Execute then
  begin
    o := TPasFile.Create(OpenDialog1.FileName);
    Memo1.Lines.Clear;
    Memo1.Lines.Add(o.EncodeToHtml);
    Memo1.Lines.SaveToFile('C:\a.html');
    Application.ProcessMessages;
    winexec('explorer.exe C:\a.html',SW_SHOW );
    o.Free;
  end;
end;

{ TPasFile }

constructor TPasFile.Create(FileName:string);
var sl:TStringList;
begin
  sl :=TStringList.Create;
  FFileName :=FileName;
  sl.LoadFromFile(FileName);
  Data := sl.Text;
  sl.Free;

  ReservedWordList := TStringList.Create;
  ReservedWordList.Add('constructor');
  ReservedWordList.Add('destructor');
  ReservedWordList.Add('begin');
  ReservedWordList.Add('inherited');
  ReservedWordList.Add('end');
  ReservedWordList.Add('var');
  ReservedWordList.Add('Integer');
  ReservedWordList.Add('string');
  ReservedWordList.Add('procedure');
  ReservedWordList.Add('function');
  ReservedWordList.Add('protected');
  ReservedWordList.Add('public');
  ReservedWordList.Add('if');
  ReservedWordList.Add('then');
  ReservedWordList.Add('While');
  ReservedWordList.Add('do');
  ReservedWordList.Add('for');
  ReservedWordList.Add('to');
  ReservedWordList.Add('in');
  ReservedWordList.Add('else');
  ReservedWordList.Add('override');
  ReservedWordList.Add('type');
  ReservedWordList.Add('record');
  ReservedWordList.Add('class');
  ReservedWordList.Add('implementation');
  ReservedWordList.Add('private');
  ReservedWordList.Add('case');
  ReservedWordList.Add('of');
  ReservedWordList.Add('array');
  ReservedWordList.Add('unit');
  ReservedWordList.Add('interface');


  ReservedWordList.Text := UpperCase( ReservedWordList.Text);
end;

destructor TPasFile.Destroy;
begin
  ReservedWordList.Free;
  inherited;
end;

function TPasFile.EncodeToHtml: String;
var
  I,oldPos: Integer;
  htmlStr,sHead,sFoot:string;
  oDs:TDataSec;

  function GotoStr(sa:array of string):integer;
    var ii,j:integer;
  begin
    Result := Length(Data);
    for j := (i+1) to Length(Data) do
       for ii := Low(sa) to High(sa) do
         if data[j]=sa[ii] then
         begin
           Result := j ;
           exit;
         end;
  end;

  function GotoNextComm:integer;
    var j:integer;
  begin
    Result := Length(Data);
    for j := (i+1) to Length(Data) do
      if (data[j]='''')and(data[j+1]<>'''') then
      begin
        Result := j ;
        exit;
      end;
  end;

  procedure SetDataSec(S:String;style:TmpStyle);
  begin
    //處理關鍵字
    if ReservedWordList.IndexOf( UpperCase(s)) <> -1  then
      style := mpReservedWord;

    //處理 html 不能使用的字
    s:= StringReplace(s,'<','<',[rfReplaceAll] );
    s:= StringReplace(s,'>','>',[rfReplaceAll] );

    oDs.DataString := s;
    oDs.Style := style;
  end;

  function HtmlColorStr(Color:TColor):String;
  begin
    Result := format('#%.2x%.2x%.2x',[GetRValue(Color)
        ,GetGValue(Color),GetBValue(Color) ]);
  end;


begin
  i := 1;

  while i < Length(Data) do
  begin
    oldPos := i;
    case Data[i] of
     ' ' : SetDataSec(' ',mpSpace) ;
     '{' :
        begin
          i := GotoStr(['}']);
          SetDataSec(Copy(Data,oldPos,i - oldPos +1),mpComment );
        end;

     '/' :
        begin
          if Data[i+1]='/' then
          begin
            i := GotoStr( [ chr(10)]);
            SetDataSec(Copy(Data,oldPos,i - oldPos +1 ),mpComment );
          end
          else
            SetDataSec(string( data[i]),mpSymbol );
        end;

     ':','=',';','.','[',']','(',')',',',chr(13),chr(10):
        begin
          SetDataSec(string( data[i]),mpSymbol );
        end;

     '''':
        begin
          i := GotoNextComm;
          SetDataSec(Copy(Data,oldPos,i - oldPos +1),mpString );
        end;
    else
        begin
          i := GotoStr([' ','{','/',chr(13),chr(10),':','=',';','.','[',']','(',')',',' ]);
          SetDataSec(Copy(Data,oldPos,i - oldPos ),mpString );
          dec(i);
        end;
    end;
//    <font color=#ff0000><b></b></font> 紅
//    <font color=#009900></font>  綠
//    <font color=#7d0000> 咖啡色

    if (ods.Style = mpReservedWord) and(Main.Label1.Font.Color<>clBlack)then
      htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label1.Font.Color)+'><b>' + ods.DataString +'</b></font>'
    else if (ods.Style = mpComment) and(Main.Label2.Font.Color<>clBlack) then
      htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label2.Font.Color)+'>' + ods.DataString +'</font>'
    else if (ods.Style = mpSymbol)and(Main.Label3.Font.Color<>clBlack) then
      htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label3.Font.Color)+'>' + ods.DataString +'</font>'
    else if (Main.Label4.Font.Color<>clBlack) then
      htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label4.Font.Color)+'>' + ods.DataString +'</font>'
    else
      htmlStr := htmlStr + ods.DataString;

    inc(i);
  end;

sHead :=
'<html>' + VK_RTN +
'<head>' + VK_RTN +
'<meta http-equiv="Content-Type" content="text/html; charset=big5">' + VK_RTN +
'<title>'+FFileName+'</title>' + VK_RTN +
'</head>' + VK_RTN +
//'<body text="#000000" bgcolor="#FFFFFF" >'+ VK_RTN +
'<pre><code>' + VK_RTN ;


sFoot :=  VK_RTN +
'</code></pre>' + VK_RTN +
//'</body>' + VK_RTN +
'</html>' ;


  Result := sHead + htmlStr + sFoot;
end;



procedure TMain.Label1Click(Sender: TObject);
begin
  if ColorDialog1.Execute then
    (Sender as TLabel).Font.Color := ColorDialog1.Color;

  //Memo1.Text := ColorToString( ColorDialog1.Color );
 // Memo1.Text := format('#%.2x%.2x%.2x',[GetRValue(ColorDialog1.Color)
 // ,GetGValue(ColorDialog1.Color),GetBValue(ColorDialog1.Color) ]);
end;

end.

搖別人視窗是不好的事

var
   hand:HWND;   
   r:TRect;   
   i:integer;
begin 
   hand := GetForegroundWindow;  
   GetWindowRect(hand , r );
    for i := 0 to 4 do  
    begin    
     MoveWindow(hand,r.Left,r.Top -3,r.Right-r.Left,r.Bottom-r.Top,true ); sleep(40);
     MoveWindow(hand,r.Left-3,r.Top ,r.Right-r.Left,r.Bottom-r.Top,true ); sleep(40);
     MoveWindow(hand,r.Left,r.Top +3,r.Right-r.Left,r.Bottom-r.Top,true ); sleep(40);
     MoveWindow(hand,r.Left+3,r.Top ,r.Right-r.Left,r.Bottom-r.Top,true ); sleep(40);
    end;

字元處理轉成文字 Char to Hex byte

procedure TFVoltage.com7ReceiveData(Sender: TObject; DataPtr: 
     Pointer;  DataSize: Cardinal);
var s : string;
   i : smallint;
begin 
   Label1.Caption := ''; 
   s := stringofchar(' ',DataSize); 
   move(dataptr^,pchar(s)^,DataSize); 
   for i := 0 to DataSize-1 do  
   begin  
     if (s[i]<>'') and (i>3) and (i<(DataSize-2)) then   
     Label1.Caption := Label1.Caption+ '[' +inttostr(strtoint('0x' + 
            inttohex(byte(s[i]),2)))+ '] '    
     else if (byte(s[i])=0) and (i>3) and (i<(DataSize-2)) then   
       Label1.Caption := Label1.Caption+ '[' + '0' + '] '; 
   end; 
   ListBox1.Items.Insert(0,Label1.Caption);
end;

加載字型

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;