save userform as pdf file to Microsoft Teams folder

[Mr_Ragweed2]

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

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!

 

[John_w]

Now i am getting a "Document not saved. The document may be open, or an error may have been encountered when saving" error... on this line:

.ExportAsFixedFormat Type:=xlTypePDF, fileName:=PDFfile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

But in your code above that you're using fileName:=fullPath and I don't see fullPath being defined.

For saving to Sharepoint, you might need to save it to a local disk first and then copy/move the file to Sharepoint, maybe using the VBA native commands FileCopy or Name or using FileSystemObject methods.

 

[Mr_Ragweed2]

Sorry, i did not copy enough of the code.

Dim strPath As String, strFName As String
Dim fullPath As String
    
strPath = "https://blah blah.sharepoint.com/:f:/r/teams/blah blah/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/"
strFName = Sheets("Combined data").Range("D1").Value
fullPath = strPath & strFName & ".pdf"

 

[Mr_Ragweed2]

I found this thread but it is way over my head. It's not using pdf's but talks about BMP/jpeg/png images instead if those options are easier. I just need a savable picture to a file that can be referenced/reprinted at any time, format doesn't matter.

Save active (current) Userform to Desktop as .png

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

www.mrexcel.com

Just trying to help.

 

[John_w]

The best version of the code in that thread is Save active (current) Userform to Desktop as .png

Copy and paste the second piece of code into a new standard module. Call the UserFormSnapshot procedure from your userform module (e.g. a Command Button) like this:

Private Sub CommandButton2_Click()
    Dim FilePath As String
    FilePath = ThisWorkbook.Path & "\Userform_image.png"
    UserFormSnapshot Me, FilePath, True, 0
End Sub

Change FilePath to suit.

 

[Mr_Ragweed2]

I am getting this error:

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

I see the original thread also had the same issue, but i can't follow how to fix it.

I have this bit in the code on the button in the userform: I have tried both of the versions and get the same error above.

Dim FilePath As String
    FilePath = Environ("USERPROFILE") & "\Desktop\"
    UserFormSnapshot Me, FilePath & ".png", True, 2

'Dim FilePath As String
  '  FilePath = ThisWorkbook.Path & "\Userform_image.png"
  '  UserFormSnapshot Me, FilePath, True, 0

I even tried this version that was originally typed for D:\

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

I put the entire code you linked me to into its own module:

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

 

[Mr_Ragweed2]

btw, i left the filepath as is so it would go to C drive. Once we get this part solved i will deal with putting it on sharepoint

 

[Dan_W]

Hi. So where are you up to?

 

[Dan_W]

Sorry - just refreshed and saw this now.

That's not the most recent version is it?

 

[Dan_W]

Nope, you're absolutely right, it is. So that error occurs when GDI doesn't have anything to work with. which is why I included the Pause routine.
You said earlier that you were after a PDF or an image or something, and you wanted to load it to Sharepoint right? Does file size matter?

 

[John_w]

I even tried this version that was originally typed for D:\

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

Try:

Dim FilePath As String
FilePath = Environ("USERPROFILE") & "\Desktop\"
UserFormSnapshot Me, FilePath & "Userform.png", True, 2

Which should create the file Userform.png on your Desktop.