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

Private Const SRCCOPY As Long = &HCC0020



Private Sub SaveFormAsImage()

    Dim pic As PictureBox

    Set pic = Me.Controls.Add("VB.PictureBox", "picTemp")



    ' ScaleMode をピクセル単位に設定 

    Me.ScaleMode = vbPixels

    pic.ScaleMode = vbPixels



    ' PictureBox のサイズをフォームに合わせる 

    pic.Width = Me.ScaleWidth

    pic.Height = Me.ScaleHeight

    pic.AutoRedraw = True  ' 描画を有効にする 



    ' フォームの内容を PictureBox にコピー 

    BitBlt pic.hDC, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Me.hDC, 0, 0, SRCCOPY

    pic.Refresh



    ' 画像を保存 

    SavePicture pic.Image, "Z:\form_image.bmp"



    ' 一時 PictureBox の削除 

    Me.Controls.Remove "picTemp"

End Sub



Private Sub Command1_Click()

    SaveFormAsImage

    MsgBox "画像を保存しました", vbInformation

End Sub