Save active (current) Userform to Desktop as .png

[Jimmypop]

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....

 

[Jimmypop]

As soon as you have time you can always give the BMP version... Just wanted PNG's seeing as some managers are pedantic on image quality sometimes

 

[Dan_W]

Ha. Well, you should've said (and I should've double-checked) - !
GIF and JPG files are the image files most likely to have quality issues because they each use some form of compression algorithm that affects their appearance. BMP files, by contrast, are as good as you're going to get for a bitmap images in terms of quality - the 'downside' is the potential size of the file, especially as compared to PNG files, which are a better image format (IMO) in terms of image quality and file size. This may not be much of an issue, though, it it's limited to the capture of a userform. The one downside to PNG files, as you've discovered, is that it is not a file format that VBA can handle natively - thus requiring an inordinate number of APIs and code complexity.
Let me get back to you later on a BMP option.

 

[Dan_W]

How is it going? Any further issues?

 

[Jimmypop]

Hi Dan...

No further issues as of now... I had to disable the MsgBox informing that the Userform has been saved to the desktop. As soon as I add that then the GDI 7 Error comes up every second time after I have to close and reopen the workbook.

Not necessary for MsgBox, it is just on my workbook I generate various different Bar and Pareto charts directly onto a Userform and can save them as .pdf and .png respectivly with a Msgbox informing of said save action. The reason for wanting to save the Map Chart Userform as a snap shot is there is a table with information that cannot be displayed on the map chart but I can display on the userform... Hence the userform needing to be exported as a whole.

 

[Dan_W]

Hi. I stumbled across this thread looking for something, and on rereading my code, I think I've worked out the source of the problem. I've rewritten it - it's now a bit shorter and a bit more straight forward. It also includes an option to hide the mouse cursor (so it's not in the shot) and also to include the optional of having a delay on the 'shutter' (in seconds).

USAGE: The routine below is written to be called from the Userform, and passes the principal subroutine - UserFormSnapshot - the following four arguments:
1. the Userform object - ME
2. the PNG filename
3. preference re: mouse visibility - HideMouse = True or False
4. any timer delay (in seconds)

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

    Option Explicit
  
    Private Const IMAGE_BITMAP          As Long = 0
    Private Const LR_COPYRETURNORG      As Long = &H4
    Private Const CF_BITMAP             As Long = 2
    Private Const S_OK                  As Long = 0
  
   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 Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        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 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 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
        Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
        Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        Private Declare PtrSafe Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
      
        Dim GDIPToken As LongPtr, hBitmap As LongPtr, hCopy As LongPtr, hPtr As LongPtr, hWnd As LongPtr
    #Else
        Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
        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 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 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 SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
        Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
      
        Dim GDIPToken As Long, hBitmap  As Long, hCopy As Long, hPtr As Long, hWnd As Long
    #End If
 
    Public Sub UserFormSnapshot(ByVal UForm As Object, ByVal Filename As String, Optional ByVal HideMouse As Boolean = True, Optional ByVal TimerDelay As Long)
      
        Call IUnknown_GetWindow(UForm, VarPtr(hWnd))
      
        If Not hWnd = 0 Then
           
             CaptureWindow HideMouse, TimerDelay
           
             Dim tSI As GdiplusStartupInput, Result As Long
             Dim tEncoder As GUID, TParams As EncoderParameters
      
             OpenClipboard 0
             hPtr = GetClipboardData(CF_BITMAP)
             hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
      
             tSI.GdiplusVersion = 1
             Result = GdiplusStartup(GDIPToken, tSI)
      
             If Result = 0 Then
                 Result = GdipCreateBitmapFromHBITMAP(hCopy, 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
        End If
errHandler:
        EmptyClipboard
        CloseClipboard
        DeleteObject hCopy
      
        If Result Then Err.Raise 5, , "Cannot save the image. GDI+ Error:" & Result
      
    End Sub
 
    Private Sub CaptureWindow(Optional ByVal HideMouse As Boolean = True, Optional ByVal TimerDelay As Long)
      
        If HideMouse Then Call ShowMouse(False)
                  
        SetForegroundWindow hWnd
        SetFocus hWnd
      
        If TimerDelay Then Call Pause(TimerDelay)
              
        keybd_event &H12, 0, 0, 0
        keybd_event &H2C, 0, 0, 0
        keybd_event &H2C, 0, &H2, 0
        keybd_event &H12, 0, &H2, 0
      
        Call Pause(2)
        Call ShowMouse(True)
      
    End Sub
  
    Private Sub Pause(ByVal Period As Single)
        Dim StartTimer As Single
        StartTimer = Timer
        Do
            DoEvents
        Loop Until StartTimer + Period < Timer
    End Sub
  
    Private Sub ShowMouse(ByVal Value As Boolean)
        ShowCursor CLng(Value)
    End Sub

 

[Jimmypop]

Hi Dan

Thanks for the update...will test later on and revert back...

 

[Jimmypop]

Currently getting Invalid use of Me keyword error...

UserFormSnapshot Me, "D:\UserForm_Snapshot(" & Format(Now, "yymmdd-hhmmss") & ".png", True, 2

What I did to implement...

Pasted Long vba code to a module
Pasted short vba code to a module

Calling TestPNGSnapshot from my command button on userform

Also updated below: seeing as I do not have a D: Drive....(maybe this is where my mistake is....)

Sub TestPNGSnapshot()
    Dim FilePath As String
    FilePath = Environ("USERPROFILE") & "\Desktop\"
    UserFormSnapshot Me, "FilePath(" & Format(Now, "yymmdd-hhmmss") & ".png", True, 2
End Sub

 

[Dan_W]

The sample routine was written to be called from the Userform. The first argument is an Object data type, but the principal routine is expecting that you pass it the UserForm (which is accomplished with the Me keyword, if calling from the Userform). Alternatively:

Dim FRM As UserForm1
Set Frm = New UserForm1
Frm.Show vbModeless

Dim FilePath As String
FilePath = Environ("USERPROFILE") & "\Desktop\"
UserFormSnapshot FRM, "FilePath(" & Format(Now, "yymmdd-hhmmss") & ".png", True, 2

Should work.

 

[Jimmypop]

Thanks Dan

Will do further debugging after I am not in such a hurrythinking I am too hasty trying to test seeing as I am also busy with some month end reporting... Will do a proper file and code update and then test again when I am not so busy...

First got User Type not defined on

Dim FRM As UserForm1

but updated it to the name of my Userform as follows:

Dim FRM As MapChart
Set Frm = New MapChart
Frm.Show vbModeless

Dim FilePath As String
FilePath = Environ("USERPROFILE") & "\Desktop\"
UserFormSnapshot FRM, "FilePath(" & Format(Now, "yymmdd-hhmmss") & ".png", True, 2

Then it said cant show modal form seeing as there were other userforms open in the background... I updated all these to vbModeless...

So getting no errors now... but the Userform is not saving... So granted when I am free I will rather go and make these other to unload first so I am only working with the Mapchart Userform... Thanks so far for all the assistance...

 

[Dan_W]

First got User Type not defined on

Not knowing what your userforms, etc. are named, I'm glad you updated the code to fit your specific scenario.

hen it said cant show modal form seeing as there were other userforms open in the background... I updated all these to vbModeless...

As for this, it can't be helped - either you call the routine from within the userform, or the userforms need to be displayed modeless - otherwise the code won't progress to the point of taking the snapshot until after the userform has closed down.
I'm surprised it's not saving to your desktop though. I have a few other people testing it as we speak. Fingers crossed.