How to screenshot a userform and save the capture as JPG 1

[AncientTiger]

I've done this before in VB6, but is there a way in Excel VBA to screencapture the userform (already know how to do this), then save the image in the clipboard to a JPG file?

I recall that in VB6 if was a simple as sending the image to a picturebox control from the clipboard, then saving the picturebox control .PICTURE as a file (or something like that..I've slept a few times since I worked on that project! LOL), but I'm having a heck of a time finding a method to do something similar in Excel VBA...

Thanks in advance


------------------------------------
Over 35 years of programming, and still learning every day!

 

[strongm]

>then saving the picturebox control .PICTURE as a file

Not if you were trying to save as a jpeg! StdPic (and thus VB6's Picturebox control) could not understand jpegs. Sure, you could save to a file with a jpg extension, but what was actually saved was a bmp

 

[AncientTiger]

strongm, you prompted me to dig out my old notes on the process... you're right, that wasn't the method... I used this:

Microsoft Windows Image Acquisition Library v2.0 (wiaaut.dll)

FPATH = "C:\test.bmp"

Dim picfile As New WIA.ImageFile
Dim picprocess As New WIA.ImageProcess
Set picfile = New WIA.ImageFile


picfile.LoadFile FPATH
Set picprocess = New WIA.ImageProcess
With picprocess
.Filters.Add .FilterInfos!Convert.FilterID
.Filters.Item(1).Properties!FormatID.Value = wiaFormatJPEG
.Filters.Item(1).Properties!Quality.Value = 100
Set picfile = .Apply(picfile)
End With
picfile.SaveFile "c:\test.jpg"

------------------------------------
Over 35 years of programming, and still learning every day!

 

[strongm]

Yep, WIA 2 would be the route I'd have advised. We've covered it a number of times in this forum.

So, now all you need to do is somehow load picfile from the data on the clipboard ...

 

[AncientTiger]

Unfortunately, I'm not finding any way in VBA to work with the clipboard like VB6 can.... Hoping someone here has that expertise

------------------------------------
Over 35 years of programming, and still learning every day!

 

[strongm]

No, sadly VBA doesn't have a clipboard object (and the one it can access in the parent app, e.g. Excel) is less capable. It also doesn't have a PropertyBag object - which makes serialising a Picture object for consumption by WIA tricky ...

You goal is still possible though ...

 

[strongm]

[COLOR=blue]Option Explicit

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   type As Long
   Value As Long
End Type

Private Type EncoderParameters
   Count As Long
   Parameter As EncoderParameter
End Type

Private Type PictDesc
    cbSizeofStruct As Long
    PicType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal Token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicArray As Any, RefIID As Any, ByVal OwnsHandle As Long, IPic As Any) As Long

Const PICTYPE_BITMAP = 1
Const CF_BITMAP = 2

Public Sub example()
    Dim ClipboardPic As Picture

    If OpenClipboard(0&) Then
        Set ClipboardPic = HandleToPicture(GetClipboardData(CF_BITMAP), PICTYPE_BITMAP) [COLOR=green]' assumes we have a bitmap on the clipboard[/color]
        CloseClipboard
        If Not ClipboardPic Is Nothing Then
            SaveAsJPG ClipboardPic, "d:\downloads\deleteme\test.jpg"
        Else
            MsgBox "Could not find bitmap on clipboard"
        End If
    Else
        MsgBox "Could not open Clipboard"
    End If

End Sub

Private Function HandleToPicture(hHandle As Long, PicType As Long) As Picture
    Dim pd As PictDesc
    Dim IPic As GUID

    If hHandle = 0 Then Exit Function [COLOR=green]' no handle to any type of image[/color]

    pd.cbSizeofStruct = Len(pd)
    pd.PicType = PicType
    pd.hImage = hHandle

    CLSIDFromString ByVal StrPtr("{00020400-0000-0000-C000-000000000046}"), IPic
    OleCreatePictureIndirect pd, IPic, -1, HandleToPicture

End Function

Private Sub SaveAsJPG(ByVal SrcPicture As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80)
Dim gdiInput As GdiplusStartupInput
Dim gdiStatus As Long
Dim Token As Long
Dim gdiImage As Long
Dim gdiJPGEncoder As GUID
Dim gdiEncoderParams As EncoderParameters

   [COLOR=green]' Initialize GDI+[/color]
   gdiInput.GdiplusVersion = 1
   gdiStatus = GdiplusStartup(Token, gdiInput)

   If gdiStatus = 0 Then

      [COLOR=green]' Create the GDI+ bitmap from the image handle[/color]
      gdiStatus = GdipCreateBitmapFromHBITMAP(SrcPicture.Handle, SrcPicture.hpal, gdiImage)

      If gdiStatus = 0 Then ' Successful?

         [COLOR=green]' Initialize the encoder GUID
         ' assumes platform has a JPG codec; in real world we might want to enumerate codecs to see if this assumption is true. See my gdi+ code in thread222-1686785 for one way of doing this[/color]
         CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), gdiJPGEncoder

         [COLOR=green]' Initialize the encoder parameters - we are setting up Quality encoder[/color]
         gdiEncoderParams.Count = 1
         With gdiEncoderParams.Parameter
            CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
            .NumberOfValues = 1
            .type = 4
            .Value = VarPtr(quality) '0-100%
         End With

         [COLOR=green]' Save the image[/color]
         gdiStatus = GdipSaveImageToFile(gdiImage, StrPtr(filename), gdiJPGEncoder, gdiEncoderParams)

         [COLOR=green]' Cleanup[/color]
         GdipDisposeImage gdiImage

      End If

      [COLOR=green]' Shutdown GDI+[/color]
      If Token Then GdiplusShutdown Token

   End If

   If gdiStatus Then msgbox "Could not save - GDI+ error"

End Sub[/color]

 

[AncientTiger]

WOW!!
Thanks Strongm, you're the best

------------------------------------
Over 35 years of programming, and still learning every day!