如何将窗体的某一区域存为了一个图片文件?

Question

hDCSrc = GetDC(hWndSrc)        '如果要考貝非客戶區則用這行
hDCSrc = GetWindowDC(hWndSrc)
    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)
     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?象
   SavePicture IPic,"C:\temp.bmp"

Answer 1

hDCSrc = GetDC(hWndSrc)      
hDCSrc = GetWindowDC(hWndSrc)
    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)
     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)          
      .Type = vbPicTypeBitmap   
      .hBmp = hBmp              
      .hPal = hPal              
   End With
   r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
   SavePicture IPic,"C:\temp.bmp"

Answer 2

下面的代码拷贝窗口内100X100像素的内容到Picture1并保存：Option ExplicitPrivate Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020Private Sub Command1_Click()
    BitBlt Picture1.hDC, 0, 0, 100, 100, Me.hDC, 0, 0, SRCCOPY
    SavePicture Picture1.Image, "c:\abcd.bmp"
End Sub