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!

 

[Mr_Ragweed2]

Dan w - I don't think file size matters. It is not being emailed or anything, just saved to a shared location.

John w - just tried your suggestion and still get the same error.

 

[Dan_W]

I just reread the original thread, and I remembered what the problem was - helped significantly by Johns prompting. He's right - the issues arised there ( and likely here too) because of the filepath. If it's still not working for you, is it the same error message? Can you possibly post the code you're currently using?

I should add that you shouldn't trust what I wrote in the original thread re: the file path - it was wrong. I think I just blindly copied pasted that from somewhere in teh thread, and it needed correcting, which John has kindly done.

 

[Mr_Ragweed2]

Yes the error message is the same:
"Cannot save the image. GDI+Error7"

Currently i am using this in the button code: (third try at this point)

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

Originally it was this:

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

and this in 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

 

[Dan_W]

Hmm not great. Just a thought - can you check to see if there happens to be a file at the save location already with that filename?

 

[Mr_Ragweed2]

Just checked, there is not.
Checked desktop (OneDrive)
C: drive
Teams
No file exists.

 

[Dan_W]

Ahh - it likely won't be on your OneDrive desktop - what about your standard one?

 

[John_w]

Just try:

UserFormSnapshot Me, "C:\Userform.png", True, 0

 

[Mr_Ragweed2]

That gave the same error.
Sorry for the delayed reply, i got called away yesterday evening.

 

[Mr_Ragweed2]

So i have been working on a "Plan B". I have created a mimic of the userform as a spreadsheet thinking avoiding the whole pdf/bmp/png thing for now is acceptable. I have code that saves that sheet as a new workbook to my C:\ Drive. Code is below:

Dim newfile As String
Dim newShName As String

newfile = Sheets("Plan B").Range("E6").Value
newShName = Sheets("Plan B").Range("E6").Value
Sheets("Plan B").Select
    Sheets("Plan B").Copy
    Sheets("Plan B").Select
    Sheets("Plan B").Name = newShName
    Range("O31").Select
    ChDir "C:\Users\My_Name\OneDrive - My_Company\Desktop" ' need to make this dynamic to any user - our format is JSmith
    ActiveWorkbook.SaveAs Filename:=newfile
ActiveWorkbook.Close

This code works as it should. but it can't be hardcoded to my username. Even if this is all the farther we get, i need any user to be able to do this and at least have a copy on the desktop that they can manually put in the Teams folder for now.

I have also created a blank workbook on Teams with the thought of it giving me an exact destination. In another thought i created a hyperlink on a spreadsheet to that workbook because i didn't know if there was a way to use that as a poor man's shortcut. I have tried recording the steps but to no avail.

Hyperlink shows on worksheet as "2022-23 Seed Orders.xlsx"

Actual address is:
"https://my company.sharepoint.com//r/teams/company name folder/_layouts/15/ _
'Doc.aspx?sourcedoc=%7B6DAF88D9-B569-4F2B-80A4-9ACA644AB355%7D&file=2022-23%20Seed%20Orders _
'.xlsx&wdLOR=c6EEBB463-5C6E-4EF6-B70C-68305E142839&action=default&mobileredirect=true"

(the big red "x" is actually colon x colon)

Does any of this help? I really appreciate the help you both have been giving me.

 

[Mr_Ragweed2]

Update: I think it works!
So was trying different save codes and none were working. My newfile workbook was open and when i clicked the X to close it i got an option to save. Normally i blow through this trying to reset my code and screen. This time i turned on the macro recorder because the save option actually listed my location to the new blank work book as an option. I put that recorded code into my code and holy cow it actually saved there. Before i had been copying the path from the new blank workbook and apparently it was listing different.

The part that did not work (because i haven't tried and don't know how to do this) is i did not get the new name of the file. It simply saved as Book2.
Current code is this:

Dim newfile As String
Dim newShName As String
newfile = Sheets("Plan B").Range("E6").Value
newShName = Sheets("Plan B").Range("E6").Value
Sheets("Plan B").Select
    Sheets("Plan B").Copy
    Sheets("Plan B").Select
    Sheets("Plan B").Name = newShName
    Range("O31").Select
    
    ActiveWorkbook.SaveAs Filename:= _
        "https://my_Company.sharepoint.com/teams/Company_Folder/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/Book2.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

How do i change the "Book2.xlsx" part of the filename to the newfile.xlsx name?