保存picturebox中所有内容(包括其他控件)

Question

Option Explicit
Private 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
Dim a As Long
Private Sub Form_Click()
Picture2.Width = Picture1.Width
Picture2.Height = Picture1.Height
a = BitBlt(Picture2.hDC, 0, 0, Picture2.Width, Picture2.Height, Picture1.hDC, 0, 0, vbSrcCopy)
SavePicture Picture2.Image, "E:\a1.bmp"
If a <> 0 Then MsgBox "none"
End SubPrivate Sub Form_Load()
Picture1.AutoRedraw = True
Picture2.AutoRedraw = True
End Sub
昨天用这个程序还是正常的,今天再用就运行不正确了
请问这个程序哪里出错了,为什么保存下来的图片是空的,picture1上的label1没有显示呢?

Answer 1

程序没有错,我试了.
想保存picture1上的label1,请参见:zzyong00(阿勇)的,有个变通的办法.我一时找不到.自己找一下. 

Answer 2

Private Const twipFactor = 1440
Private Const WM_PAINT = &HF
Private Const WM_PRINT = &H317
Private Const PRF_CLIENT = &H4&    ' Draw the window's client area.
Private Const PRF_CHILDREN = &H10& ' Draw all visible child windows.
Private Const PRF_OWNED = &H20&    ' Draw all owned windows.Private Declare Function SendMessage Lib "user32" Alias _
   "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
   ByVal wParam As Long, ByVal lParam As Long) As Long
   Picture1.SetFocus
   Picture2.AutoRedraw = True
   rv = SendMessage(Picture1.hwnd, WM_PAINT, Picture2.hDC, 0)
   rv = SendMessage(Picture1.hwnd, WM_PRINT, Picture2.hDC, _
   PRF_CHILDREN + PRF_CLIENT + PRF_OWNED)
   Picture2.Picture = Picture2.Image
   Picture2.AutoRedraw = False   SavePicture Picture2.Image, "E:\a1.bmp"   

Answer 3

of123的方法可以实现,但是如果我在picture1上再放一个picture3,做成示波器的样子,以几个label作为x,y轴坐标,当我使用of123的方法时,label与picture3的位置就乱了,这个问题怎么呢?

Answer 4

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
Private Const BITMAPTYPE = &H4D42
Private Const INVALID_HANDLE_VALUE = (-1)
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = 2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const GENERIC_READ = &H80000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type
Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type
Private Type BITMAPFILEHEADER
        bfType As Integer
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
End TypePrivate Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) 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 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 Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Sub Command1_Click()
    Dim hmemDC As Long
    Dim hmemBMP As Long
    Dim lpmemBits As Long
    Dim bmp_info As BITMAPINFO
    Dim hFile As Long
    Dim bmpfile_info As BITMAPFILEHEADER
    Dim lpBytesWritten As Long
    
    Picture1.ScaleMode = vbPixels
    
    With bmp_info.bmiHeader
        .biSize = LenB(bmp_info.bmiHeader)
        .biWidth = Picture1.ScaleWidth
        .biHeight = Picture1.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = .biHeight * (((.biWidth * .biBitCount + 31) And &HFFFFFFE0) \ 8)
    End With
    
    hmemDC = CreateCompatibleDC(Picture1.hdc)
    hmemBMP = CreateDIBSection(Picture1.hdc, bmp_info, DIB_RGB_COLORS, lpmemBits, 0, 0)
    SelectObject hmemDC, hmemBMP
    BitBlt hmemDC, 0, 0, bmp_info.bmiHeader.biWidth, bmp_info.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy
    hFile = CreateFile("E:\example4\2.bmp", _
           GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
            0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile <> INVALID_HANDLE_VALUE Then
        With bmpfile_info
            .bfType = BITMAPTYPE
            .bfOffBits = 14 + bmp_info.bmiHeader.biSize
            .bfSize = .bfOffBits + bmp_info.bmiHeader.biSizeImage
        End With
        
        WriteFile hFile, bmpfile_info.bfType, 2, lpBytesWritten, 0
        WriteFile hFile, bmpfile_info.bfSize, 12, lpBytesWritten, 0
        WriteFile hFile, bmp_info.bmiHeader, bmp_info.bmiHeader.biSize, lpBytesWritten, 0
        WriteFile hFile, ByVal lpmemBits, bmp_info.bmiHeader.biSizeImage, lpBytesWritten, 0        CloseHandle hFile
    End If
    DeleteObject hmemBMP
    DeleteDC hmemDC    Clipboard.Clear
    Clipboard.SetData LoadPicture("E:\example4\2.bmp"), 2
    'Picture3.Cls
    'Picture3.Width = Picture1.Width
    'Picture3.Height = Picture1.Height
  
    'Picture3.Picture = LoadPicture("E:\example4\2.bmp")
    'SavePicture Picture3.Image, "E:\example4\3.bmp"
    'Set Picture3.Picture = LoadPicture("E:\example4\test.bmp") ', _
                    vbLPCustom, 3, Picture1.Width, Picture1.Height)
    'SavePicture Picture3.Image, "E:\example4\a1.bmp"
End sub
这样做很好用,把picture1上所有的控件都以bitmap形式保存下来了