使用VBIDE开发能在VB6.0IDE环境中自动拷贝工程中的Form图片的小工具

我有6-7天没有写东西了。这对时间在忙着做标题上写明的小抓图工具。写的我好辛苦，但还是开发出来了。我在此贴出来与大家共享，希望能对大家有所帮助。

我这个小工具完成以下功能：当你打开一个现存的工程项目，在VBIDE环境的插件管理中添加本插件，然后它就可以将当前工程中包含的全部Form的设计时图片全部抓下来，以BMP格式存到一个指定的文件夹。这样在做界面跳转分析（画面迁移）和源代码工程分析的时候非常有用。

开发环境：VB6.0    引用库：VBIDE

开发过程和代码：

1、建立ADDIN工程

2、编码实现功能：

核心代码如下 ： 　

Private Sub SaveCurrentProject()
        '进行必要的程序初始化
        InitProgram

        Dim win As VBIDE.Window
        For Each win In VBInstance.Windows
        '<<<<<<<<<<>>>>>>>>改变关掉所有的窗体考虑到性能问题
            'If Not (win.Type = vbext_wt_Designer) Then
                win.Close   '不是设计和代码窗体的全部关闭 虽然关闭了窗体,但没有从Windows中Remove
            'End If
        Next
       
        '先打开所有的窗体
         Dim eComponent As VBIDE.VBComponent
         For Each eComponent In VBInstance.ActiveVBProject.VBComponents
            If eComponent.Type = vbext_ct_VBForm Then
                eComponent.Activate
                Call keybd_event(vbKeyReturn, 1, 0, 0) '虚拟键 这里的SCAN取了1,不行的话换0
            End If
        Next
       
        Dim everyComponent As VBComponent
        '遍历所有的Components对象,如果是VBForm就处理,打印图片保存
        For Each everyComponent In VBInstance.ActiveVBProject.VBComponents
            If everyComponent.Type = vbext_ct_VBForm Then
                '打开当前处理的窗体
                Dim designWin As VBIDE.Window
                Set designWin = everyComponent.DesignerWindow
                designWin.Visible = True
                '可以加耶可以不加
                designWin.SetFocus
                '获得处理窗体中的VBForm对象
                Dim designForm As VBIDE.VBForm
                Set designForm = everyComponent.Designer
                '向Form中添加一个Control 设置不可见属性 再Remove掉他
                Dim ctr As VBIDE.VBControl
                Set ctr = designForm.VBControls.Add("VB.Label")
                ctr.Properties("Caption") = ""
                ctr.Properties("Left") = "0"
                ctr.Properties("Top") = "0"
                ctr.Properties("Width") = "1"
                ctr.Properties("Height") = "1"
                '再次获得加入的控件 以从其Parent属性中得到VBForm 的hWnd
                Dim realControl As Label
                Dim ctrl As VBIDE.VBControl
                For Each ctrl In designForm.ContainedVBControls
                    If ctrl.ProgId = "VB.Label" Then
                        Set realControl = ctrl.ControlObject
                        Exit For
                    End If
                Next
                '设置图片文件存储路径
                Dim sFile   As String
                Dim realFilePath As String
                Dim fileName As String
                'MsgBox "222222222"
                '<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>适应需求改动了下面的部分
                'VBP中的Form只能保存在当前工程的目录下面
                realFilePath = VBInstance.ActiveVBProject.fileName
                realFilePath = StrReverse(realFilePath)
                realFilePath = StrReverse(Right(realFilePath, Len(realFilePath) - InStr(realFilePath, "/") + 1))
                If InStr(everyComponent.FileNames(1), "/") = 0 Then
                    realFilePath = realFilePath + everyComponent.FileNames(1)
                Else
                    fileName = StrReverse(everyComponent.FileNames(1))
                    fileName = StrReverse(Left(fileName, InStr(fileName, "/") - 1))
                    realFilePath = realFilePath + fileName
                End If
                sFile = SaveFilePath(realFilePath) + ".bmp"
                '抓取VBForm并保存
                'MsgBox sFile
                SavePicture CaptureCertainWindow(realControl.Parent.hWnd), sFile     '保存
                '从VBForm中去掉这个控件，保持原文件不变
                designForm.VBControls.Remove ctr
            End If
        Next
   
End Sub

 

      #If Win32 Then
         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
      #ElseIf Win16 Then
         Public Function CaptureWindow(ByVal hWndSrc As Integer, _
            ByVal Client As Boolean, ByVal LeftSrc As Integer, _
            ByVal TopSrc As Integer, ByVal WidthSrc As Long, _
            ByVal HeightSrc As Long) As Picture

            Dim hDCMemory As Integer
            Dim hBmp As Integer
            Dim hBmpPrev As Integer
            Dim r As Integer
            Dim hDCSrc As Integer
            Dim hPal As Integer
            Dim hPalPrev As Integer
            Dim RasterCapsScrn As Integer
            Dim HasPaletteScrn As Integer
            Dim PaletteSizeScrn As Integer
      #End If
         Dim LogPal As LOGPALETTE

         ' Depending on the value of Client get the proper device context
         If Client Then
            hDCSrc = GetDC(hWndSrc) ' Get device context for client area
         Else
            hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire
                                          ' window
         End If

         ' Create a memory device context for the copy process
         hDCMemory = CreateCompatibleDC(hDCSrc)
         ' Create a bitmap and place it in the memory DC
         hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
         hBmpPrev = SelectObject(hDCMemory, hBmp)

         ' Get screen properties
         RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
                                                            'capabilities
         HasPaletteScrn = RasterCapsScrn And RC_PALETTE       ' Palette
                                                              'support
         PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
                                                              ' palette

         ' If the screen has a palette make a copy and realize it
         If HasPaletteScrn And (PaletteSizeScrn = 256) Then
            ' Create a copy of the system palette
            LogPal.palVersion = &H300
            LogPal.palNumEntries = 256
            r = GetSystemPaletteEntries(hDCSrc, 0, 256, _
                LogPal.palPalEntry(0))
            hPal = CreatePalette(LogPal)
            ' Select the new palette into the memory DC and realize it
            hPalPrev = SelectPalette(hDCMemory, hPal, 0)
            r = RealizePalette(hDCMemory)
         End If

         ' Copy the on-screen image into the memory DC
         r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _
            LeftSrc, TopSrc, vbSrcCopy)

      ' Remove the new copy of the  on-screen image
         hBmp = SelectObject(hDCMemory, hBmpPrev)

         ' If the screen has a palette get back the palette that was
         ' selected in previously
         If HasPaletteScrn And (PaletteSizeScrn = 256) Then
            hPal = SelectPalette(hDCMemory, hPalPrev, 0)
         End If

         ' Release the device context resources back to the system
         r = DeleteDC(hDCMemory)
         r = ReleaseDC(hWndSrc, hDCSrc)

         ' Call CreateBitmapPicture to create a picture object from the
         ' bitmap and palette handles.  Then return the resulting picture
         ' object.
         Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
      End Function

具体的技术要点我就不说了，VBIDE不好开发，一是资料少。二是公开接口不够完善。以至于一些简单的显而易见的操作都可能使VB主程序死掉。总之毛病多多~~~~~~~~~！    这是所有，欢迎大家批评指教~！