save userform as pdf file to Microsoft Teams folder

M

Mr_Ragweed2

Board Regular
Joined
Nov 11, 2022
Messages
145
Office Version
  1. 365
Platform
  1. Windows
Howdy,
I have a userform that i currently can print. I would like to print and save from the "print button" on the form. I'm assuming it would save as a pdf but maybe an image is easier? Doesn't matter to me. I would like to save it to a specific folder in Microsoft Teams.
my code for printing is below. (It is not specific to my printer as it allows many users to print to their default printer.)

VBA Code: 
If Application.Dialogs(xlDialogPrinterSetup).Show Then
    UserForm1_MyUserformName.PrintForm
    Else
    Exit Sub
End If

I have a cell to reference for giving a unique name to each file: Sheet("Special Sheet").Range("D1")
All users would be saving to the same file:
"https://blah blah.sharepoint.com/:f:?r/teams/blah blah/Shared%20Documents/General/Blah%20Apps/abc%20Orders?csf=1&web=1&e=xW6Z7s"

Any help is greatly appreciated. Thank you very much!
 
Sort by date Sort by votes
Yes - i assumed my attempt would be fruitless, but i at least wanted to try.

Thank both of you very much. You are correct in pointing out i placed the code in the wrong place. Now i see the difference and will give it a try.

Dan_W and Jaafar, both of you give very good explanations that i am finding educational, not just solve solve my problem and move on.
It goes back to "Give a man a fish and he will eat for a day. Teach a man to fish and he will eat for life."
Thank you both, i will post my results hopefully soon.
 
Upvote 0

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Dan_W said:
Jaafar - Thank you very much for the code solution. I did think it would be easier to save the file to BMP than to PNG (as taken from another thread I participated in), but it didn't occur to me to use PrintWindow here, it's a very good idea. What I found interesting is that the capture does not include the mouse cursor here, whereas with the PNG capture I cobbled together, I had to include a routine to hide and show the mouse cursor.
Click to expand...
Dan - Probably the biggest advantage of PrintWindow is that it captures the userform even if it is obscured by (ie:= underneath) another topmost window or even if the userform is partially offscreen... As we all know, relying on SendKeys\keybd_event is not reliable at all and causes al sorts of problems.

If you try again the keybd_event approach (in your CaptureWindow routine) on a form that is partially underneath the Task Manager or on a form that is partially offscreen, you will see that sending Alt+ Prtscreeen keystrokes will only capture the current onscreen\visible area of the form.

the bitmap file approach avoids GDI+ altogether, and is an image file format native to VBA. It results in larger file sizes, however, which is why I asked above whether file sizes would be an issue!
Click to expand...
We can easily tweak the SaveUserFormToDisk function I posted to save the form image as PNG, JPEG, etc ( using GDPlus or WIA ) hence substantially reduncing the resulting image file size.
 
Upvote 0
Jaafar Tribak said:
Dan - Probably the biggest advantage of PrintWindow is that it captures the userform even if it is obscured by (ie:= underneath) another topmost window or even if the userform is partially offscreen... As we all know, relying on SendKeys\keybd_event is not reliable at all and causes al sorts of problems.
Click to expand...
This explains a lot.

Around the same time as I had prepared the Userform Capture -> PNG routine, I also worked on a solution to screen capture a worksheet-embedded webbrowser control - https://www.mrexcel.com/board/threads/email-embedded-microsoft-browser-map.1209221/post-5918364

I first came across PrintWindow when researching this query. OP had wanted the screen capture to get the webbrowser image (Google maps) even if not visible - I thought PrintWindow had solved everything, and in my testing it worked, but OP said that parts of the image was missing etc. Your point about it being "partially" offscreen suggests to me my tests did capture OP's exact use case, they difference in results (to be fair, I can't embed the WB control in 64bit office).

you will see that sending Alt+ Prtscreeen keystrokes will only capture the current onscreen\visible area of the form.
Click to expand...
I was not aware of this, thank you! The Sendkeys Method was more a result of my frustration of not being able get the GetWindowRect to capture the userform image without adding or cropping several pixels to each side. I figured that this will work and this will do, but I managed to get it working for the WB thread so I should've just been a bit more patient.

As for saving the image, and it may be that you know a solution, but both Mr Ragweed2 and I keep hitting tthe GDI+ Error 7, as I wrote above in my second reply of today (lost count?), it seems to occur when the image has not been fully copied across to the clipboard when SavePNG routine goes to access the clipboard and save it. It also seems that neither you nor John have encountered in this routine - so I wonder if it's just a computer speed problem?

As for WIA, I was literally in the middle of writing up my notes on that and hope to post them soon!
 
Upvote 0
Dan,
it seems to occur when the image has not been fully copied across to the clipboard when SavePNG routine goes to access the clipboard and save it.
Click to expand...
Looks like a timng issue as transfering data to the clipboard will take some time... The approach I have used doesn't use the clipboard at all so it won't complain from this timing issue either.

Here is the tweaked and more inclusive SaveUserFormToDisk routine which now allows the user to save to disk images of the userform (or Frame & Multipage which both have hwnds) in different formats.

Image file formats supported:
BMP,DIB,RLE,JPEG,JPG,JPE,JFIF,GIF,TIFF,TIF,PNG

SaveUserFormAsImage.xlsm



1- API code in a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
#Else
    Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
    Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
   'GDIPlus
    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
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
    Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
   'GDIPlus
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
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
    DebugEventCallback        As LongPtr
    SuppressBackgroundThread  As LongPtr
    SuppressExternalCodecs    As Long
End Type

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

Private Type EncoderParameters
    Count       As Long
    Parameter   As EncoderParameter
End Type



Public Function SaveUserFormToDisk( _
    ByVal Form As UserForm, _
    ByRef Path As String, _
    ByVal Filename As String, _
    Optional ByVal FullContent As Boolean = True _
) As Boolean

    Const S_OK = &H0
    Const PW_CLIENTONLY = &H1
    Const PW_RENDERFULLCONTENT = &H2
    Const INVALID_FILE_ATTRIBUTES = -1&

    Dim hWnd As LongPtr, hDC As LongPtr, hMemDC As LongPtr
    Dim hMemBmp As LongPtr, hPrevBmp As LongPtr
    Dim tRect As RECT
 
    'GDIPlus
    Dim tEncoder As GUID, tSI As GdiplusStartupInput, TParams As EncoderParameters
    Dim GDIPToken As LongPtr, hBitmap As LongPtr, lRet As Long
    Dim sPathFile As String, sExt As String, sFormatCLSID As String
 
 
    On Error GoTo errHandler
 
    If Right(Path, 1) <> Application.PathSeparator Then Path = Path & Application.PathSeparator
    sPathFile = Path & Filename
    sExt = Right(sPathFile, Len(sPathFile) - InStrRev(sPathFile, "."))
 
    Select Case UCase(sExt)
        Case "BMP", "DIB", "RLE"
            sFormatCLSID = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
        Case "JPEG", "JPG", "JPE", "JFIF"
            sFormatCLSID = "{557cf401-1a04-11d3-9a73-0000f81ef32e}"
        Case "GIF"
            sFormatCLSID = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
        Case "TIFF", "TIF"
            sFormatCLSID = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
        Case "PNG"
            sFormatCLSID = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
    End Select
 
 
    Call IUnknown_GetWindow(Form, VarPtr(hWnd))
    hDC = GetDC(hWnd)
    Call GetWindowRect(hWnd, tRect)
    With tRect
        hMemBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
    End With
    hMemDC = CreateCompatibleDC(hDC)
    hPrevBmp = SelectObject(hMemDC, hMemBmp)
    Call PrintWindow(hWnd, hMemDC, IIf(FullContent, PW_RENDERFULLCONTENT, PW_CLIENTONLY))
 
    tSI.GdiplusVersion = 1&
    lRet = GdiplusStartup(GDIPToken, tSI)
    If lRet = S_OK Then
        lRet = GdipCreateBitmapFromHBITMAP(hMemBmp, NULL_PTR, hBitmap)
        If lRet = S_OK Then
            CLSIDFromString StrPtr(sFormatCLSID), tEncoder
            TParams.Count = 1&
            lRet = GdipSaveImageToFile(hBitmap, StrPtr(sPathFile), tEncoder, TParams)
            If lRet = S_OK Then
                If GetFileAttributes(sPathFile) <> INVALID_FILE_ATTRIBUTES Then
                    SaveUserFormToDisk = True
                End If
            End If
        End If
    End If
     
errHandler:

    Call GdipDisposeImage(hBitmap)
    Call GdiplusShutdown(GDIPToken)
    Call SelectObject(hMemDC, hPrevBmp)
    Call DeleteObject(hMemBmp)
    Call DeleteDC(hMemDC)
    Call ReleaseDC(hWnd, hDC)
 
End Function



2- Code Usage example in the UserForm Module:
VBA Code: 
Option Explicit

'UserForm.
Private Sub CommandButton1_Click()
 
    'Image formats accepted :
    '=====================
    ' BMP,DIB,RLE,JPEG,JPG,JPE,JFIF,GIF,TIFF,TIF,PNG

    Dim sPath As String, sFile As String
 
    sPath = ThisWorkbook.Path
    sFile = Format(Now, "dd-mmm-yyyy - hh-mm-ss") & " - " & "MyFormImage.png" '<== change image extension as required.
 
    'Save form to disk in the workbook path as PNG.
    If SaveUserFormToDisk(Me, sPath, sFile) Then
        MsgBox "UserForm Image saved as: " & sPath & sFile, vbInformation, "SaveUserFormToDisk."
    Else
        MsgBox "Failed to save UserForm Image to disk." & vbLf & vbLf & _
            "Check validity of file path & file extension.", vbCritical
    End If

End Sub


'Frame.
Private Sub CommandButton2_Click()

    Dim sPath As String, sFile As String
 
    sPath = ThisWorkbook.Path
    sFile = Format(Now, "dd-mmm-yyyy - hh-mm-ss") & " - " & "MyFrameImage.GIF" '<== change image extension as required.
 
    'Save Frame1 to disk in the workbook path as GIF.
    If SaveUserFormToDisk(Me.Frame1, sPath, sFile) Then
        MsgBox "Frame Image saved as: " & sPath & sFile, vbInformation, "SaveFrameToDisk."
    Else
        MsgBox "Failed to save frame Image to disk." & vbLf & vbLf & _
            "Check validity of file path & file extension.", vbCritical
    End If

End Sub


I remember writing some code long time ago that would save the userform image as a PDF file by making the pdf printer as default .. Scaling the printed image is more difficult though.
 
Last edited:
Upvote 0
Solution
Jaafar Tribak said:
Dan,

Looks like a timng issue as transfering data to the clipboard will take some time... The approach I have used doesn't use the clipboard at all so it won't complain from this timing issue either.

Here is the tweaked and more inclusive SaveUserFormToDisk routine which now allows the user to save to disk images of the userform (or Frame & Multipage which both have hwnds) in different formats.

Image file formats supported:
BMP,DIB,RLE,JPEG,JPG,JPE,JFIF,GIF,TIFF,TIF,PNG

SaveUserFormAsImage.xlsm



1- API code in a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
#Else
    Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
    Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
   'GDIPlus
    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
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
    Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
   'GDIPlus
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
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
    DebugEventCallback        As LongPtr
    SuppressBackgroundThread  As LongPtr
    SuppressExternalCodecs    As Long
End Type

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

Private Type EncoderParameters
    Count       As Long
    Parameter   As EncoderParameter
End Type



Public Function SaveUserFormToDisk( _
    ByVal Form As UserForm, _
    ByRef Path As String, _
    ByVal Filename As String, _
    Optional ByVal FullContent As Boolean = True _
) As Boolean

    Const S_OK = &H0
    Const PW_CLIENTONLY = &H1
    Const PW_RENDERFULLCONTENT = &H2
    Const INVALID_FILE_ATTRIBUTES = -1&

    Dim hWnd As LongPtr, hDC As LongPtr, hMemDC As LongPtr
    Dim hMemBmp As LongPtr, hPrevBmp As LongPtr
    Dim tRect As RECT
 
    'GDIPlus
    Dim tEncoder As GUID, tSI As GdiplusStartupInput, TParams As EncoderParameters
    Dim GDIPToken As LongPtr, hBitmap As LongPtr, lRet As Long
    Dim sPathFile As String, sExt As String, sFormatCLSID As String
 
 
    On Error GoTo errHandler
 
    If Right(Path, 1) <> Application.PathSeparator Then Path = Path & Application.PathSeparator
    sPathFile = Path & Filename
    sExt = Right(sPathFile, Len(sPathFile) - InStrRev(sPathFile, "."))
 
    Select Case UCase(sExt)
        Case "BMP", "DIB", "RLE"
            sFormatCLSID = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
        Case "JPEG", "JPG", "JPE", "JFIF"
            sFormatCLSID = "{557cf401-1a04-11d3-9a73-0000f81ef32e}"
        Case "GIF"
            sFormatCLSID = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
        Case "TIFF", "TIF"
            sFormatCLSID = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
        Case "PNG"
            sFormatCLSID = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
    End Select
 
 
    Call IUnknown_GetWindow(Form, VarPtr(hWnd))
    hDC = GetDC(hWnd)
    Call GetWindowRect(hWnd, tRect)
    With tRect
        hMemBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
    End With
    hMemDC = CreateCompatibleDC(hDC)
    hPrevBmp = SelectObject(hMemDC, hMemBmp)
    Call PrintWindow(hWnd, hMemDC, IIf(FullContent, PW_RENDERFULLCONTENT, PW_CLIENTONLY))
 
    tSI.GdiplusVersion = 1&
    lRet = GdiplusStartup(GDIPToken, tSI)
    If lRet = S_OK Then
        lRet = GdipCreateBitmapFromHBITMAP(hMemBmp, NULL_PTR, hBitmap)
        If lRet = S_OK Then
            CLSIDFromString StrPtr(sFormatCLSID), tEncoder
            TParams.Count = 1&
            lRet = GdipSaveImageToFile(hBitmap, StrPtr(sPathFile), tEncoder, TParams)
            If lRet = S_OK Then
                If GetFileAttributes(sPathFile) <> INVALID_FILE_ATTRIBUTES Then
                    SaveUserFormToDisk = True
                End If
            End If
        End If
    End If
    
errHandler:

    Call GdipDisposeImage(hBitmap)
    Call GdiplusShutdown(GDIPToken)
    Call SelectObject(hMemDC, hPrevBmp)
    Call DeleteObject(hMemBmp)
    Call DeleteDC(hMemDC)
    Call ReleaseDC(hWnd, hDC)
 
End Function



2- Code Usage example in the UserForm Module:
VBA Code: 
Option Explicit

'UserForm.
Private Sub CommandButton1_Click()
 
    'Image formats accepted :
    '=====================
    ' BMP,DIB,RLE,JPEG,JPG,JPE,JFIF,GIF,TIFF,TIF,PNG

    Dim sPath As String, sFile As String
 
    sPath = ThisWorkbook.Path
    sFile = Format(Now, "dd-mmm-yyyy - hh-mm-ss") & " - " & "MyFormImage.png" '<== change image extension as required.
 
    'Save form to disk in the workbook path as PNG.
    If SaveUserFormToDisk(Me, sPath, sFile) Then
        MsgBox "UserForm Image saved as: " & sPath & sFile, vbInformation, "SaveUserFormToDisk."
    Else
        MsgBox "Failed to save UserForm Image to disk." & vbLf & vbLf & _
            "Check validity of file path & file extension.", vbCritical
    End If

End Sub


'Frame.
Private Sub CommandButton2_Click()

    Dim sPath As String, sFile As String
 
    sPath = ThisWorkbook.Path
    sFile = Format(Now, "dd-mmm-yyyy - hh-mm-ss") & " - " & "MyFrameImage.GIF" '<== change image extension as required.
 
    'Save Frame1 to disk in the workbook path as GIF.
    If SaveUserFormToDisk(Me.Frame1, sPath, sFile) Then
        MsgBox "Frame Image saved as: " & sPath & sFile, vbInformation, "SaveFrameToDisk."
    Else
        MsgBox "Failed to save frame Image to disk." & vbLf & vbLf & _
            "Check validity of file path & file extension.", vbCritical
    End If

End Sub


I remember writing some code long time ago that would save the userform image as a PDF file by making the pdf printer as default .. Scaling the printed image is more difficult though.
Click to expand...
Thank you, Jaafar. I had suspected my reliance on the clipboard was il-advised

I know that you did a project situating a printer icon/button on a msgbox that produced a capture in PDF, and I came across some code of yours on VBF, I think, where you captured a full-length userform in a single image (one with an extended scrolk height), but I havent worked my way through that one yet.
 
Upvote 0
ok, First i apologize for being an idiot. Second, i am missing something in your instructions. I created a new userform that i call from a button on a spreadsheet. I have no other modules or code, beyond "userform1.show" on the button on the worksheet.
Here is the userform:
1670196924938.jpeg

When i double click the user form in vba i have this:
VBA Code: 
Private Sub CommandButton1_Click()

End Sub

Private Sub UserForm_Click()

End Sub
Am i putting all of this in the same place?
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
#Else
    Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
    Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
   'GDIPlus
    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
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
    Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
   'GDIPlus
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
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
    DebugEventCallback        As LongPtr
    SuppressBackgroundThread  As LongPtr
    SuppressExternalCodecs    As Long
End Type

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

Private Type EncoderParameters
    Count       As Long
    Parameter   As EncoderParameter
End Type



Public Function SaveUserFormToDisk( _
    ByVal Form As UserForm, _
    ByRef Path As String, _
    ByVal Filename As String, _
    Optional ByVal FullContent As Boolean = True _
) As Boolean

    Const S_OK = &H0
    Const PW_CLIENTONLY = &H1
    Const PW_RENDERFULLCONTENT = &H2
    Const INVALID_FILE_ATTRIBUTES = -1&

    Dim hWnd As LongPtr, hDC As LongPtr, hMemDC As LongPtr
    Dim hMemBmp As LongPtr, hPrevBmp As LongPtr
    Dim tRect As RECT
 
    'GDIPlus
    Dim tEncoder As GUID, tSI As GdiplusStartupInput, TParams As EncoderParameters
    Dim GDIPToken As LongPtr, hBitmap As LongPtr, lRet As Long
    Dim sPathFile As String, sExt As String, sFormatCLSID As String
 
 
    On Error GoTo errHandler
 
    If Right(Path, 1) <> Application.PathSeparator Then Path = Path & Application.PathSeparator
    sPathFile = Path & Filename
    sExt = Right(sPathFile, Len(sPathFile) - InStrRev(sPathFile, "."))
 
    Select Case UCase(sExt)
        Case "BMP", "DIB", "RLE"
            sFormatCLSID = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
        Case "JPEG", "JPG", "JPE", "JFIF"
            sFormatCLSID = "{557cf401-1a04-11d3-9a73-0000f81ef32e}"
        Case "GIF"
            sFormatCLSID = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
        Case "TIFF", "TIF"
            sFormatCLSID = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
        Case "PNG"
            sFormatCLSID = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
    End Select
 
 
    Call IUnknown_GetWindow(Form, VarPtr(hWnd))
    hDC = GetDC(hWnd)
    Call GetWindowRect(hWnd, tRect)
    With tRect
        hMemBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
    End With
    hMemDC = CreateCompatibleDC(hDC)
    hPrevBmp = SelectObject(hMemDC, hMemBmp)
    Call PrintWindow(hWnd, hMemDC, IIf(FullContent, PW_RENDERFULLCONTENT, PW_CLIENTONLY))
 
    tSI.GdiplusVersion = 1&
    lRet = GdiplusStartup(GDIPToken, tSI)
    If lRet = S_OK Then
        lRet = GdipCreateBitmapFromHBITMAP(hMemBmp, NULL_PTR, hBitmap)
        If lRet = S_OK Then
            CLSIDFromString StrPtr(sFormatCLSID), tEncoder
            TParams.Count = 1&
            lRet = GdipSaveImageToFile(hBitmap, StrPtr(sPathFile), tEncoder, TParams)
            If lRet = S_OK Then
                If GetFileAttributes(sPathFile) <> INVALID_FILE_ATTRIBUTES Then
                    SaveUserFormToDisk = True
                End If
            End If
        End If
    End If
     
errHandler:

    Call GdipDisposeImage(hBitmap)
    Call GdiplusShutdown(GDIPToken)
    Call SelectObject(hMemDC, hPrevBmp)
    Call DeleteObject(hMemBmp)
    Call DeleteDC(hMemDC)
    Call ReleaseDC(hWnd, hDC)
 
End Function
Whether i put all of it in the commandbutton1_click piece or all of it in the useform_click piece i get this error:
1670197401505.jpeg

I completely believe you both that the code works just fine. This is all on my ignorance of what i am doing at this point.
 
Upvote 0
nevermind. i reread you last post jaafar. i see how the two are split. I am getting an "Internal error" on this line:

VBA Code: 
Private Type EncoderParameter
 
Upvote 0
update. So i was frustrated and closed everything and opened it just now. When i tried to run it, via clicking commandbutton1 on the called userform i got the following msgbox from the code: (as designed by the code)
VBA Code: 
MsgBox "Failed to save UserForm Image to disk." & vbLf & vbLf & _
            "Check validity of file path & file extension.", vbCritical
Somewhere a few pages of posts ago, i mentioned my computer is operating on Sharepoint/OneDrive. I thought this may be relevant so i change the sPath in Jaafars's code to my C:\ Drive and it saved the png perfectly!
VBA Code: 
 'sPath = ThisWorkbook.Path
    sFile = Format(Now, "dd-mmm-yyyy - hh-mm-ss") & " - " & "MyFormImage.png" '<== change image extension as required.
    sPath = "C:\Users\My_Username\OneDrive - My_Company\Desktop"
I have even edited the sFile code to reflect a unique name, and that works as well.

The problem i am having is the path i have to Teams is not working.
If i/we cannot get that to go. What would be the vba so that any user saves it to their C:\Drive? ie) how can i code to search and use their username?
Is that the Environ(username) stuff i see every now and then? I'm not familiar with that either.
 
Upvote 0
This code works for saving an .xlsx file to Teams:
VBA Code: 
ActiveWorkbook.SaveAs FileName:= _
        "https://My_Company.sharepoint.com/teams/Company_File/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/" & "\" & newfile & ".xlsx" _
Where "newfile" is a unique name.
I have tried this:
VBA Code: 
sPath = "https://My_Company.sharepoint.com/teams/Company_File/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/"
and this:
VBA Code: 
sPath = "https://My_Company.sharepoint.com/teams/Company_File/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/" & "\"
and this:
VBA Code: 
sPath = "https://My_Company.sharepoint.com/teams/Company_File/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/" & "\"  & ".png"

All give me the "file not saved" msgbox.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
VB help please - Save as pdf in specific folder
Replies
2
Views
89
JV0710
J
I
  • Question Question
Saved pdf from worksheet doesnt show all the page
Replies
6
Views
282
ipbr21054
I
M
  • Question Question
pdf of ws not saving - error
Replies
0
Views
835
Mr_Ragweed2
M
P
  • Solved
Export Worksheets into a Single PDF using Criteria on each Worksheet
Replies
7
Views
621
jolivanes
jolivanes
I
  • Question Question
File is allready saved but code should be stopping duplicates being saved
Replies
5
Views
265
ipbr21054
I

Forum statistics

Threads
1,223,702
Messages
6,173,966
Members
452,539
Latest member
delvey

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