【分享】Delphi一个抓屏的函数

阿杰

<font color="#000080"><strong>procedure</strong></font> TMainFrm.ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);<br/><font color="#000080"><strong>var</strong></font><br/>dc: HDC; lpPal : PLOGPALETTE;<br/><font color="#000080"><strong>begin</strong></font><br/>&nbsp; <font color="#008000">// 检测所需抓屏的区域<br/></font>&nbsp; <font color="#000080"><strong>if</strong></font> ((Width = <font color="#0000ff">0</font>) <font color="#000080"><strong>or</strong></font> (Height = <font color="#0000ff">0</font>)) <font color="#000080"><strong>then</strong></font> exit;<br/>&nbsp; bm.Width := Width;<br/>&nbsp; bm.Height := Height;<br/>&nbsp; <font color="#008000">//获取设备上下文<br/></font>&nbsp; dc := GetDc(<font color="#0000ff">0</font>);<br/>&nbsp; <font color="#000080"><strong>if</strong></font> (dc = <font color="#0000ff">0</font>) <font color="#000080"><strong>then</strong></font> exit;<br/>&nbsp; <font color="#008000">{do we have a palette device?}</font><br/>&nbsp; <font color="#000080"><strong>if</strong></font> (GetDeviceCaps(dc, RASTERCAPS) AND<br/>&nbsp;&nbsp;&nbsp; RC_PALETTE = RC_PALETTE) <font color="#000080"><strong>then</strong></font><br/>&nbsp;&nbsp;&nbsp; <font color="#000080"><strong>begin</strong></font><br/>&nbsp;&nbsp;&nbsp; <font color="#008000">{allocate memory for a logical palette}</font><br/>&nbsp;&nbsp;&nbsp; GetMem(lpPal, sizeof(TLOGPALETTE) + (<font color="#0000ff">255</font> * sizeof(TPALETTEENTRY)));<br/>&nbsp;&nbsp;&nbsp; <font color="#008000">{zero it out to be neat}</font><br/>&nbsp;&nbsp;&nbsp; FillChar(lpPal^, sizeof(TLOGPALETTE) + (<font color="#0000ff">255</font> * sizeof(TPALETTEENTRY)), <font color="#0000ff">#0</font>);<br/>&nbsp;&nbsp;&nbsp; <font color="#008000">{fill in the palette version}</font><br/>&nbsp;&nbsp;&nbsp; lpPal^.palVersion := <font color="#0000ff">$300</font>;<br/>&nbsp;&nbsp;&nbsp; <font color="#008000">{grab the system palette entries}</font><br/>&nbsp;&nbsp;&nbsp; lpPal^.palNumEntries :=<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; GetSystemPaletteEntries(dc,<font color="#0000ff">0</font>,<font color="#0000ff">256</font>,lpPal^.palPalEntry);<br/>&nbsp;&nbsp;&nbsp; <font color="#000080"><strong>if</strong></font> (lpPal^.PalNumEntries &lt;&gt; <font color="#0000ff">0</font>) <font color="#000080"><strong>then</strong></font><br/>&nbsp;&nbsp;&nbsp; <font color="#000080"><strong>begin</strong></font><br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <font color="#008000">{create the palette}</font><br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; bm.Palette := CreatePalette(lpPal^);<br/>&nbsp;&nbsp;&nbsp; <font color="#000080"><strong>end</strong></font>;<br/>&nbsp;&nbsp;&nbsp; FreeMem(lpPal, sizeof(TLOGPALETTE) + (<font color="#0000ff">255</font> * sizeof(TPALETTEENTRY)));<br/>&nbsp;&nbsp;&nbsp; <font color="#000080"><strong>end</strong></font>;<br/>&nbsp; <font color="#008000">{copy from the screen to the bitmap}</font><br/>&nbsp; BitBlt(bm.Canvas.Handle,<font color="#0000ff">0</font>,<font color="#0000ff">0</font>,Width,Height,Dc,x,y,SRCCOPY);<br/>&nbsp; <font color="#008000">{release the screen dc}</font><br/>&nbsp; ReleaseDc(<font color="#0000ff">0</font>, dc);<br/><font color="#000080"><strong>end</strong></font>;<br/><br/><font color="#008000">//调用方法<br/></font><font color="#000080"><strong>procedure</strong></font> TMainFrm.Button1Click(Sender: TObject);<br/><font color="#000080"><strong>var</strong></font><br/>&nbsp; tBM : TBitmap;<br/><font color="#000080"><strong>begin</strong></font><br/>&nbsp; <font color="#000080"><strong>try</strong></font><br/>&nbsp;&nbsp;&nbsp; tBM := TBitmap.Create;<br/>&nbsp;&nbsp;&nbsp; ScreenShot(<font color="#0000ff">0</font>,<font color="#0000ff">0</font>,Screen.Width,Screen.height,tBM);<br/>&nbsp;&nbsp;&nbsp; tBM.SaveToFile(<font color="#0000ff">'c:\ScreenShot.BMP'</font>);<br/>&nbsp; <font color="#000080"><strong>finally</strong></font><br/>&nbsp;&nbsp;&nbsp; tBm.FreeImage;<br/>&nbsp;&nbsp;&nbsp; FreeAndNil(tBM);<br/>&nbsp; <font color="#000080"><strong>end</strong></font>;<br/><font color="#000080"><strong>end</strong></font>;

upring

看来delphi代码区是乱码了