如何将当前屏幕写进一JPG图片中，高手请给代码

Question

如何将当前屏幕写进一JPG图片中，高手请给代码

Answer 1

’很简单的问题，做过多少次。编码也很Flexible and neat.但很难从一个大的Project中拿出来。还是抄一个给你。好像是CSDN上的旧帖。  Option   Explicit  
  Option   Base   0  
   
  Private   Type   PALETTEENTRY  
        peRed   As   Byte  
        peGreen   As   Byte  
        peBlue   As   Byte  
        peFlags   As   Byte  
  End   Type  
   
  Private   Type   LOGPALETTE  
        palVersion   As   Integer  
        palNumEntries   As   Integer  
        palPalEntry(255)   As   PALETTEENTRY  
  End   Type  
   
  Private   Type   GUID  
        Data1   As   Long  
        Data2   As   Integer  
        Data3   As   Integer  
        Data4(7)   As   Byte  
  End   Type  
   
  Private   Const   RASTERCAPS   As   Long   =   38  
  Private   Const   RC_PALETTE   As   Long   =   &H100  
  Private   Const   SIZEPALETTE   As   Long   =   104  
   
  Private   Type   RECT  
        Left   As   Long  
        Top   As   Long  
        Right   As   Long  
        Bottom   As   Long  
  End   Type  
   
  Private   Declare   Function   CreateCompatibleDC   Lib   "GDI32"   (ByVal   hDC   As   Long)   As   Long  
  Private   Declare   Function   CreateCompatibleBitmap   Lib   "GDI32"   (ByVal   hDC   As   Long,   _  
                  ByVal   nWidth   As   Long,   ByVal   nHeight   As   Long)   As   Long  
  Private   Declare   Function   GetDeviceCaps   Lib   "GDI32"   (ByVal   hDC   As   Long,   ByVal   _  
                  iCapabilitiy   As   Long)   As   Long  
  Private   Declare   Function   GetSystemPaletteEntries   Lib   "GDI32"   (ByVal   hDC   As   Long,   _  
                  ByVal   wStartIndex   As   Long,   ByVal   wNumEntries   As   Long,   lpPaletteEntries   _  
                  As   PALETTEENTRY)   As   Long  
  Private   Declare   Function   CreatePalette   Lib   "GDI32"   (lpLogPalette   As   LOGPALETTE)   _  
                  As   Long  
  Private   Declare   Function   SelectObject   Lib   "GDI32"   (ByVal   hDC   As   Long,   ByVal   hObject   _  
                  As   Long)   As   Long  
  Private   Declare   Function   BitBlt   Lib   "GDI32"   (ByVal   hDCDest   As   Long,   ByVal   XDest   As   _  
                  Long,   ByVal   YDest   As   Long,   ByVal   nWidth   As   Long,   ByVal   nHeight   As   Long,   _  
                  ByVal   hDCSrc   As   Long,   ByVal   XSrc   As   Long,   ByVal   YSrc   As   Long,   ByVal   dwRop   _  
                  As   Long)   As   Long  
  Private   Declare   Function   DeleteDC   Lib   "GDI32"   (ByVal   hDC   As   Long)   As   Long  
  Private   Declare   Function   GetForegroundWindow   Lib   "USER32"   ()   As   Long  
  Private   Declare   Function   SelectPalette   Lib   "GDI32"   (ByVal   hDC   As   Long,   ByVal   hPalette   _  
                  As   Long,   ByVal   bForceBackground   As   Long)   As   Long  
  Private   Declare   Function   RealizePalette   Lib   "GDI32"   (ByVal   hDC   As   Long)   As   Long  
  Private   Declare   Function   GetWindowDC   Lib   "USER32"   (ByVal   hWnd   As   Long)   As   Long  
  Private   Declare   Function   GetDC   Lib   "USER32"   (ByVal   hWnd   As   Long)   As   Long  
  Private   Declare   Function   GetWindowRect   Lib   "USER32"   (ByVal   hWnd   As   Long,   lpRect   As   _  
                  RECT)   As   Long  
  Private   Declare   Function   ReleaseDC   Lib   "USER32"   (ByVal   hWnd   As   Long,   ByVal   hDC   As   _  
                  Long)   As   Long  
  Private   Declare   Function   GetDesktopWindow   Lib   "USER32"   ()   As   Long  
   
  Private   Type   PicBmp  
        Size   As   Long  
        Type   As   Long  
        hBmp   As   Long  
        hPal   As   Long  
        Reserved   As   Long  
  End   Type  
   
  Private   Declare   Function   OleCreatePictureIndirect   Lib   "olepro32.dll"   (PicDesc   As   _  
                  PicBmp,   RefIID   As   GUID,   ByVal   fPictureOwnsHandle   As   Long,   IPic   As   IPicture)   As   Long  
   
  '捕捉整个屏幕  
  Private   Sub   Command1_Click()  
        Set   Picture1.Picture   =   CaptureScreen()  
  End   Sub  
   
  '在两秒钟后捕捉当前的活动窗口  
  Private   Sub   Command2_Click()  
          MsgBox   "当你关闭这个对话框两秒钟之后程序会捕捉处于活动状态的窗口."  
          '等待两秒钟  
          Dim   EndTime   As   Date  
          EndTime   =   DateAdd("s",   2,   Now)  
          Do   Until   Now   >   EndTime  
                DoEvents  
                Loop  
          Set   Picture1.Picture   =   CaptureActiveWindow()  
       
          Me.SetFocus  
  End   Sub  
   
  Private   Sub   Command3_Click()  
          Set   Picture1.Picture   =   Nothing  
  End   Sub  
   
  Public   Function   CreateBitmapPicture(ByVal   hBmp   As   Long,   ByVal   hPal   As   Long)   As   Picture  
      Dim   r   As   Long  
   
        Dim   Pic   As   PicBmp  
        Dim   IPic   As   IPicture  
        Dim   IID_IDispatch   As   GUID  
   
        '填充IDispatch界面  
        With   IID_IDispatch  
              .Data1   =   &H20400  
              .Data4(0)   =   &HC0  
              .Data4(7)   =   &H46  
        End   With  
   
        '填充Pic  
        With   Pic  
              .Size   =   Len(Pic)                     '   Pic结构长度  
              .Type   =   vbPicTypeBitmap       '   图象类型  
              .hBmp   =   hBmp                             '   位图句柄  
              .hPal   =   hPal                             '   调色板句柄  
        End   With  
   
        '建立Picture图象  
        r   =   OleCreatePictureIndirect(Pic,   IID_IDispatch,   1,   IPic)  
   
        '返回Picture对象  
        Set   CreateBitmapPicture   =   IPic  
  End   Function
  

Answer 2

Public   Function   CaptureWindow(ByVal   hWndSrc   As   Long,   ByVal   Client   As   Boolean,   ByVal   _  
          LeftSrc   As   Long,   ByVal   TopSrc   As   Long,   ByVal   WidthSrc   As   Long,   ByVal   HeightSrc   _  
          As   Long)   As   Picture  
   
          Dim   hDCMemory   As   Long  
          Dim   hBmp   As   Long  
          Dim   hBmpPrev   As   Long  
          Dim   r   As   Long  
          Dim   hDCSrc   As   Long  
          Dim   hPal   As   Long  
          Dim   hPalPrev   As   Long  
          Dim   RasterCapsScrn   As   Long  
          Dim   HasPaletteScrn   As   Long  
          Dim   PaletteSizeScrn   As   Long  
          Dim   LogPal   As   LOGPALETTE  
   
          If   Client   Then  
                  hDCSrc   =   GetDC(hWndSrc)  
          Else  
                  hDCSrc   =   GetWindowDC(hWndSrc)  
          End   If  
   
          hDCMemory   =   CreateCompatibleDC(hDCSrc)  
          hBmp   =   CreateCompatibleBitmap(hDCSrc,   WidthSrc,   HeightSrc)  
          hBmpPrev   =   SelectObject(hDCMemory,   hBmp)  
   
          '获得屏幕属性  
          RasterCapsScrn   =   GetDeviceCaps(hDCSrc,   RASTERCAPS)  
          HasPaletteScrn   =   RasterCapsScrn   And   RC_PALETTE  
          PaletteSizeScrn   =   GetDeviceCaps(hDCSrc,   SIZEPALETTE)  
   
          '如果屏幕对象有调色板则获得屏幕调色板  
          If   HasPaletteScrn   And   (PaletteSizeScrn   =   256)   Then  
                  '建立屏幕调色板的拷贝  
                  LogPal.palVersion   =   &H300  
                  LogPal.palNumEntries   =   256  
                  r   =   GetSystemPaletteEntries(hDCSrc,   0,   256,   LogPal.palPalEntry(0))  
                  hPal   =   CreatePalette(LogPal)  
                  '将新建立的调色板选如建立的内存绘图句柄中  
                  hPalPrev   =   SelectPalette(hDCMemory,   hPal,   0)  
                  r   =   RealizePalette(hDCMemory)  
          End   If  
   
          '拷贝图象  
          r   =   BitBlt(hDCMemory,   0,   0,   WidthSrc,   HeightSrc,   hDCSrc,   LeftSrc,   TopSrc,   vbSrcCopy)  
   
          hBmp   =   SelectObject(hDCMemory,   hBmpPrev)  
   
          If   HasPaletteScrn   And   (PaletteSizeScrn   =   256)   Then  
                  hPal   =   SelectPalette(hDCMemory,   hPalPrev,   0)  
          End   If  
   
          '释放资源  
          r   =   DeleteDC(hDCMemory)  
          r   =   ReleaseDC(hWndSrc,   hDCSrc)  
   
          Set   CaptureWindow   =   CreateBitmapPicture(hBmp,   hPal)  
  End   Function  
  'capturescreen函数捕捉整个屏幕图象  
  Public   Function   CaptureScreen()   As   Picture  
          Dim   hWndScreen   As   Long  
   
          '获得桌面的窗口句柄  
          hWndScreen   =   GetDesktopWindow()  
          Set   CaptureScreen   =   CaptureWindow(hWndScreen,   False,   0,   0,   Screen.Width   _  
                  \   Screen.TwipsPerPixelX,   Screen.Height   \   Screen.TwipsPerPixelY)  
  End   Function  
   
  Public   Function   CaptureActiveWindow()   As   Picture  
          Dim   hWndActive   As   Long  
          Dim   r   As   Long  
          Dim   RectActive   As   RECT  
       
          hWndActive   =   GetForegroundWindow()  
          r   =   GetWindowRect(hWndActive,   RectActive)  
          Set   CaptureActiveWindow   =   CaptureWindow(hWndActive,   False,   0,   0,   _  
                  RectActive.Right   -   RectActive.Left,   RectActive.Bottom   -   RectActive.Top)  
  End   Function  
   
  Public   Sub   PrintPictureToFitPage(Prn   As   Printer,   Pic   As   Picture)  
          Const   vbHiMetric   As   Integer   =   8  
          Dim   PicRatio   As   Double  
          Dim   PrnWidth   As   Double  
          Dim   PrnHeight   As   Double  
          Dim   PrnRatio   As   Double  
          Dim   PrnPicWidth   As   Double  
          Dim   PrnPicHeight   As   Double  
       
          If   Pic.Height   >=   Pic.Width   Then  
                  Prn.Orientation   =   vbPRORPortrait  
          Else  
                  Prn.Orientation   =   vbPRORLandscape  
          End   If  
       
          PicRatio   =   Pic.Width   /   Pic.Height  
       
          PrnWidth   =   Prn.ScaleX(Prn.ScaleWidth,   Prn.ScaleMode,   vbHiMetric)  
          PrnHeight   =   Prn.ScaleY(Prn.ScaleHeight,   Prn.ScaleMode,   vbHiMetric)  
          PrnRatio   =   PrnWidth   /   PrnHeight  
       
          If   PicRatio   >=   PrnRatio   Then  
                  PrnPicWidth   =   Prn.ScaleX(PrnWidth,   vbHiMetric,   Prn.ScaleMode)  
                  PrnPicHeight   =   Prn.ScaleY(PrnWidth   /   PicRatio,   vbHiMetric,   Prn.ScaleMode)  
          Else  
                  PrnPicHeight   =   Prn.ScaleY(PrnHeight,   vbHiMetric,   Prn.ScaleMode)  
                  PrnPicWidth   =   Prn.ScaleX(PrnHeight   *   PicRatio,   vbHiMetric,   Prn.ScaleMode)  
          End   If  
       
          Prn.PaintPicture   Pic,   0,   0,   PrnPicWidth,   PrnPicHeight  
  End   Sub  
   
  Private   Sub   Command4_Click()  
          CommonDialog1.DefaultExt   =   ".BMP"  
          CommonDialog1.Filter   =   "Bitmap   Image   (*.bmp)|*.bmp"  
          CommonDialog1.ShowSave  
          If   CommonDialog1.FileName   <>   ""   Then  
                  SavePicture   Picture1.Picture,   CommonDialog1.FileName  
          End   If  
  End   Sub  
   
  Private   Sub   Command5_Click()  
          PrintPictureToFitPage   Printer,   Picture1.Picture  
          Printer.EndDoc  
  End   Sub  
   
  Private   Sub   Form_Load()  
          Command1.Caption   =   "捕捉整个屏幕"  
          Command2.Caption   =   "两秒钟后捕捉活动窗口"  
          Command3.Caption   =   "清除图象"  
          Command4.Caption   =   "保存图象"  
          Command5.Caption   =   "打印图象"  
  End   Sub