Save active (current) Userform to Desktop as .png

Jimmypop

Jimmypop

Well-known Member
Joined
Sep 12, 2013
Messages
753
Office Version
  1. 365
Platform
  1. Windows
Good day

I have searched for code but not quite fond it yet...if it has been posted maybe point me in direction...

I need to when I click a command button that the active or current userform is saved as a png to desktop....
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
Hi. Do you know if you have 32bit or 64bit Excel? Also, where is the command button located? On the Userform you want a picture of?
 
Upvote 0
Dan_W said:
Hi. Do you know if you have 32bit or 64bit Excel? Also, where is the command button located? On the Userform you want a picture of?
Click to expand...
Good day....

64bit.
Command button located directly on Userform of which I want the picture of
 
Upvote 0
No hurries... Going of work now anyway so will only be back tomorrow.
 
Upvote 0
Hi.
From memory, the following code is something I have adapted from from code previously provided by Jaafar Tribak on this forum, which was originally designed to save an image stored on the clipboard to a JPG file. Over time, I have pulled it apart to see what makes it tick, and put it back together again multiple times into what is now perhaps something of a Frankenstein's monster, so any inelegance to the code or, more importantly, any bugs or flaws are entirely my own fault.

You indicated that the snapshot of the active userform should be taken upon pressing a button on that userform, with the generated PNG file being saved to the Desktop. I would therefore propose the calling the operative code direct from the userform with code such as:

VBA Code: 
 Sub TestPNGSnapshot()
   
        Dim FilePath As String
        FilePath = Environ("USERPROFILE") & "\Desktop\"
        UserFormSnapshot FilePath & "UserForm_Snapshot(" & Format(Now, "yymmdd-hhmmss") & ".png"
   
    End Sub

The operative code should be placed in a new, standard module (called, say, modUserformSnapshot):

VBA Code: 
    Option Explicit
   
    Private Type uPicDesc
       Size As Long
       Type As Long
       #If VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
       #Else
            hPic As Long
            hPal As Long
       #End If
    End Type
   
    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
       #If VBA7 Then
            DebugEventCallback As LongPtr
            SuppressBackgroundThread As LongPtr
       #Else
            DebugEventCallback As Long
            SuppressBackgroundThread As Long
       #End If
       SuppressExternalCodecs As Long
    End Type
   
    Private Type EncoderParameter
        GUID As GUID
        NumberOfValues As Long
        Type As Long
        #If VBA7 Then
            Value As LongPtr
        #Else
            Value As Long
        #End If
    End Type
   
    Private Type EncoderParameters
        Count As Long
        Parameter As EncoderParameter
    End Type
       
    #If VBA7 Then
        Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal HANDLE As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
        Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
        Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
        Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
        Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
        Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
        Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
        Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
    #Else
        Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
        Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
        Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare Function CloseClipboard Lib "user32" () As Long
        Private Declare Function EmptyClipboard Lib "user32" () As Long
        Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
        Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
        Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
        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

    #End If
   
    Private Const IMAGE_BITMAP = 0
    Private Const PICTYPE_BITMAP = 1
    Private Const LR_COPYRETURNORG = &H4
    Private Const CF_BITMAP = 2
    Private Const S_OK = 0

    Public Sub UserFormSnapshot(ByVal Filename As String)
      
       #If VBA7 Then
            Dim GDIPToken As LongPtr, hBitmap As LongPtr
       #Else
            Dim GDIPToken As Long, hBitmap  As Long
       #End If
   
        Dim tSI As GdiplusStartupInput, Result As Long, iPic As IPicture
        Dim tEncoder As GUID, TParams As EncoderParameters
   
        Set iPic = CreatePicture
   
        tSI.GdiplusVersion = 1
        Result = GdiplusStartup(GDIPToken, tSI)
   
        If Result = 0 Then
            Result = GdipCreateBitmapFromHBITMAP(iPic.HANDLE, 0, hBitmap)
            If Result = 0 Then
                CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tEncoder
                TParams.Count = 1
                Result = GdipSaveImageToFile(hBitmap, StrPtr(Filename), tEncoder, TParams)
                GdipDisposeImage hBitmap
            End If
            GdiplusShutdown GDIPToken
        End If
      
        If Result Then err.Raise 5, , "Cannot save the image. GDI+ Error:" & Result
      
    End Sub
   
    Public Function CreatePicture() As IPicture
   
       #If VBA7 Then
            Dim hCopy As LongPtr, hPtr As LongPtr, hLib As LongPtr
       #Else
            Dim hCopy As Long, hPtr As Long, hLib As Long
       #End If
   
        Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
        Dim iPic As IPicture, Result As Long
       
        On Error GoTo errHandler
   
        keybd_event 44, 1, 0&, 0&
       
        OpenClipboard 0
        hPtr = GetClipboardData(CF_BITMAP)
        hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
       
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_BITMAP
            .hPic = hCopy
            .hPal = 0
        End With
        hLib = LoadLibrary("oleAut32.dll")
        If hLib Then
            Result = OleCreatePictureIndirectAut(uPicInfo, IID_IDispatch, True, iPic)
        Else
            Result = OleCreatePictureIndirectPro(uPicInfo, IID_IDispatch, True, iPic)
        End If
        FreeLibrary hLib
       
        If Result = S_OK Then Set CreatePicture = iPic
       
errHandler:
        EmptyClipboard
        CloseClipboard
       
        If err Then err.Raise 5, , "Cannot Create Picture."
      
    End Function

Please let me know how you get on with the code. Thank you.
 
Upvote 0
Solution
Hi Dan_W

Once again thanks for the time and effort... Got it working the way I wanted with some minor tweaks to your code.... Explanation below:

On the section:

VBA Code: 
 #Else
        Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
        Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
        Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare Function CloseClipboard Lib "user32" () As Long
        Private Declare Function EmptyClipboard Lib "user32" () As Long
        Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
        Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
        Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
        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

I just had to update with PtrSafe seeing as it gave me all in red and said I had to update to 64-bit. So Updated as follows:

VBA Code: 
#Else
        Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
        Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
        Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
        Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
        Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
        Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
        Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
        Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
        Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

When I had everything set up I received the error below:

Run-time error 5:

Cannot save the image. GDI + Error: 7

On Line

VBA Code: 
       If Result Then Err.Raise 5, , "Cannot save the image. GDI+ Error:" & Result

Screenshot 2022-06-29 091446.png

I relooked at code and realized that we are using OneDrive and everything gets uploaded there. So following line did not work for me:

VBA Code: 
FilePath = Environ("USERPROFILE") & "\Desktop\"

I also wanted functionality so anyone can use the program without me having to give everyone a different FilePath so I used a Function called GetDesktop() to automatically retrieve the filepath for the desktop for different users (gets called as GetDesktop():

VBA Code: 
Function GetDesktop() As String
    Dim oWSHShell As Object
    Set oWSHShell = CreateObject("WScript.Shell")
    GetDesktop = oWSHShell.SpecialFolders("Desktop")
    Set oWSHShell = Nothing
End Function

I also added a MsgBox to let user know that this has been saved to their desktop.

So my final code is:

VBA Code: 
Private Sub CommandButton1_Click()
    Dim FilePath As String
    FilePath = GetDesktop() & "\"
    UserFormSnapshot FilePath & "5S Map Chart" & ".png"
    Call MsgBox("Chart has been exported successfully to your Desktop at " _
    & vbNewLine & vbNewLine & "" & FilePath, vbInformation, "Charts Export Result")
End Sub

    Option Explicit
   
    Private Type uPicDesc
       Size As Long
       Type As Long
       #If VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
       #Else
            hPic As Long
            hPal As Long
       #End If
    End Type
   
    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
       #If VBA7 Then
            DebugEventCallback As LongPtr
            SuppressBackgroundThread As LongPtr
       #Else
            DebugEventCallback As Long
            SuppressBackgroundThread As Long
       #End If
       SuppressExternalCodecs As Long
    End Type
   
    Private Type EncoderParameter
        GUID As GUID
        NumberOfValues As Long
        Type As Long
        #If VBA7 Then
            Value As LongPtr
        #Else
            Value As Long
        #End If
    End Type
   
    Private Type EncoderParameters
        Count As Long
        Parameter As EncoderParameter
    End Type
       
    #If VBA7 Then
        Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
        Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
        Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
        Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As Long
        Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
        Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As LongPtr
        Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
        Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
    #Else
        Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
        Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
        Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
        Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
        Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
        Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
        Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
        Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
        Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

    #End If
   
    Private Const IMAGE_BITMAP = 0
    Private Const PICTYPE_BITMAP = 1
    Private Const LR_COPYRETURNORG = &H4
    Private Const CF_BITMAP = 2
    Private Const S_OK = 0

    Public Sub UserFormSnapshot(ByVal Filename As String)
      
       #If VBA7 Then
            Dim GDIPToken As LongPtr, hBitmap As LongPtr
       #Else
            Dim GDIPToken As Long, hBitmap  As Long
       #End If
   
        Dim tSI As GdiplusStartupInput, Result As Long, iPic As IPicture
        Dim tEncoder As GUID, TParams As EncoderParameters
   
        Set iPic = CreatePicture
   
        tSI.GdiplusVersion = 1
        Result = GdiplusStartup(GDIPToken, tSI)
   
        If Result = 0 Then
            Result = GdipCreateBitmapFromHBITMAP(iPic.handle, 0, hBitmap)
            If Result = 0 Then
                CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tEncoder
                TParams.Count = 1
                Result = GdipSaveImageToFile(hBitmap, StrPtr(Filename), tEncoder, TParams)
                GdipDisposeImage hBitmap
            End If
            GdiplusShutdown GDIPToken
        End If
      
        If Result Then Err.Raise 5, , "Cannot save the image. GDI+ Error:" & Result
      
    End Sub
   
    Public Function CreatePicture() As IPicture
   
       #If VBA7 Then
            Dim hCopy As LongPtr, hPtr As LongPtr, hLib As LongPtr
       #Else
            Dim hCopy As Long, hPtr As Long, hLib As Long
       #End If
   
        Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
        Dim iPic As IPicture, Result As Long
       
        On Error GoTo errHandler
   
        keybd_event 44, 1, 0&, 0&
       
        OpenClipboard 0
        hPtr = GetClipboardData(CF_BITMAP)
        hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
       
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_BITMAP
            .hPic = hCopy
            .hPal = 0
        End With
        hLib = LoadLibrary("oleAut32.dll")
        If hLib Then
            Result = OleCreatePictureIndirectAut(uPicInfo, IID_IDispatch, True, iPic)
        Else
            Result = OleCreatePictureIndirectPro(uPicInfo, IID_IDispatch, True, iPic)
        End If
        FreeLibrary hLib
       
        If Result = S_OK Then Set CreatePicture = iPic
       
errHandler:
        EmptyClipboard
        CloseClipboard
       
        If Err Then Err.Raise 5, , "Cannot Create Picture."
      
    End Function

Thanks again for assistance.:cool:🍻
 
Upvote 0
Jimmypop said:
I just had to update with PtrSafe seeing as it gave me all in red and said I had to update to 64-bit.
Click to expand...
You actually don't need to do that, and if the plan is to distribute you workbook to others, you may need to put it back if any of those recipients are using 32-bit Office. This uses conditional compilation, which tells the VBA compiler that it should only look at certain parts of the code and disregard other parts; this is the purpose behind the
VBA Code: 
#If VBA7 Then
#Else
#End If
parts of the code. The first part is for 64bit Office, the second part is for 32bit Office - so depending on which version of Excel you're using the opposite part will always appear in red. That notwithstanding, it will still run. I'm also using 64bit Office and here is a screen capture of my own screen for example:
1656505402066.png

Jimmypop said:
Cannot save the image. GDI + Error: 7
Click to expand...
Are you still getting this error message? I gather not if it's working.

Jimmypop said:
I also wanted functionality so anyone can use the program without me having to give everyone a different FilePath so I used a Function called GetDesktop() to automatically retrieve the filepath for the desktop for different users (gets called as GetDesktop():
Click to expand...
When you say that the line "doesn't work for you", what do you mean? Does it produce an error message? The alternative you provided does the same thing as my code - both return the Desktop folder path as it is set in the individual user's system (the environment-string table).
 
Upvote 0
Hi Dan
Dan_W said:
You actually don't need to do that, and if the plan is to distribute you workbook to others, you may need to put it back if any of those recipients are using 32-bit Office. This uses conditional compilation, which tells the VBA compiler that it should only look at certain parts of the code and disregard other parts; this is the purpose behind the parts of the code. The first part is for 64bit Office, the second part is for 32bit Office - so depending on which version of Excel you're using the opposite part will always appear in red. That notwithstanding, it will still run. I'm also using 64bit Office and here is a screen capture of my own screen for example:
Click to expand...
All of the company is now using 64bit systems, but thanks for the info, I can use this in other applications I am currently busy with.

Dan_W said:
Are you still getting this error message? I gather not if it's working.
Click to expand...

Sometimes still getting it, not sure why. I will have to close the workbook and reopen then it works again. I have noticed that on occasion the snapshot that is taken is much smaller and it is only part of the userform, not a train smash at the moment I am guessing I need to do this before doing anything else on the workbook.

Dan_W said:
When you say that the line "doesn't work for you", what do you mean? Does it produce an error message? The alternative you provided does the same thing as my code - both return the Desktop folder path as it is set in the individual user's system (the environment-string table).
Click to expand...

All our work is uploaded to OneDrive and also all users desktops point to OneDrive.

VBA Code: 
FilePath = Environ("USERPROFILE") & "\Desktop\"

Gives me the file path C:\Users\Jimmypop\Desktop\

Where it needs to give me C:\Users\Jimmypop\OneDrive - CompanyABC Ltd\Desktop\

As soon as I did this with GetDesktop it pointed to the right location

Hope I am making sense🙈🙈
 
Upvote 0
Jimmypop said:
Sometimes still getting it, not sure why. I will have to close the workbook and reopen then it works again. I have noticed that on occasion the snapshot that is taken is much smaller and it is only part of the userform, not a train smash at the moment I am guessing I need to do this before doing anything else on the workbook.
Click to expand...
It's a generic error and the cause can be any number of things. The reason for smaller, partial image is partly because there wasn't (really) in the first place (it still created an image), and partly because of the method I've used to capture the image. Essentially, the method I adopted I was capture the activewindow; so when an error message appears, the image that is ultimately captured is the location of where that error message was (I've found). I've also since found that the error message will occur on userforms that are 'graphics intensive' - which makes some kind of sense = GDI+ (graphics device interface +). GDI+ APIs are being used here because you wanted as a PNG files - if BMPs were ok, this would be much shorter (and arguably easier to use and implement) code.

There are some other possibilities that might be worth trying, but I wanted to get something to you sooner rather than (much, much) later.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Copy Entire Workbook, save as sheet name with current date, hide all sheets except one, & attach to email
Replies
2
Views
641
Amo840812
A
S
  • Solved
CLose a Userfom After 10 Seconds or When User Clicks Button
Replies
3
Views
121
Jaafar Tribak
Jaafar Tribak
I
  • Question Question
File is allready saved but code should be stopping duplicates being saved
Replies
5
Views
292
ipbr21054
I
A
  • Question Question
Quirk selects invisible ComboBox when clicking nearby visible Command Button
Replies
1
Views
28
AnthK
A
I
  • Question Question
Advice for slight alteration to existing working code
Replies
1
Views
240
ipbr21054
I

Forum statistics

Threads
1,224,829
Messages
6,181,218
Members
453,024
Latest member
Wingit77

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top