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]

Leaving current code as is. When i run the macro with a different customer info it will not save. (i was looking to see if it would overwrite or add a new tab). I get a Method "SaveAs" of object 'WorkBook" failed".
Here:

ActiveWorkbook.SaveAs Filename:= _
        "https://my_Company.sharepoint.com/teams/Company_Folder/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/Book2.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

I assume it is because "Book2" already exists??

 

[Dan_W]

I believe so. When I was looking at this yesterday, I came across a thread on reddit where the person indicated that you need to delete the file first and then save it using the URL address - assuming you want to use the same filename.

 

[Mr_Ragweed2]

So then this shouldn't be a problem when i get the naming figured out, right? Is there a way to insert an error handler to check if the name already exists and then "if true", give me the chance to rename the file manually using the same URL address?
That would be a pretty handy way to kill two birds with one stone. 1 - actually get to save the file. 2 - avoid duplicates.

 

[Dan_W]

There is, and I've written a script like it for someone on this forum, but would need to search for it. It's not very difficult, but I'll. Eed to get back to you tomorrow with it.

 

[Jaafar Tribak]

I'm assuming it would save as a pdf but maybe an image is easier

You can save the userform directly as an image (BITMAP) to disk without first needing to paste its screenshot to a worksheet. It will be cleaner and quicker.

Here is this SaveUserFormToDisk wrapper function that will do the job :

Place this code In the UserForm Module and execute the CommandButton1_Click event:

Option Explicit

#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 OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) 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 OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) 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 Sub CommandButton1_Click()

    Dim sPath As String, sFile As String
    
    sPath = ThisWorkbook.Path
    sFile = "FormPicTest.bmp"
    
    If SaveUserFormToDisk(Me, sPath, sFile) Then
        MsgBox "UserForm Image saved as: " & sPath & sFile, vbInformation, "SaveUserFormToDisk."
    Else
        MsgBox "Failed to save UserForm Image to disk.", vbCritical
    End If

End Sub


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

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

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim stdPic As StdPicture, lRet As Long
    Dim hwnd As LongPtr, hDC As LongPtr, hMemDc As LongPtr
    Dim hMemBmp As LongPtr, hPrevBmp As LongPtr
    Dim tRect As RECT
    
    On Error GoTo errHandler
    
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    
    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))
    
    With IID_IDispatch: .Data1 = &H20400: .Data4(0) = &HC0: .Data4(7) = &H46: End With
    With uPicInfo: .Size = Len(uPicInfo): .Type = PICTYPE_BITMAP: .hPic = hMemBmp: .hPal = CF_BITMAP: End With
    lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, stdPic)
    
    If lRet = S_OK Then
        stdole.SavePicture stdPic, Path & FileName
        If GetFileAttributes(Path & FileName) <> INVALID_FILE_ATTRIBUTES Then
            SaveUserFormToDisk = True
        End If
    End If
        
errHandler:
    Call SelectObject(hMemDc, hPrevBmp)
    Call DeleteObject(hMemBmp)
    Call DeleteDC(hMemDc)
    Call ReleaseDC(hwnd, hDC)
  
End Function

 

[Mr_Ragweed2]

Dan_W: I got it to upload to Teams with a unique filename!! (not the pdf of the userform, but the mimic sheet we were working on. The answer was simple, i was just overthinking it (which is usually the case for me.)

I changed this:

ActiveWorkbook.SaveAs Filename:= _
        "https://my_Company.sharepoint.com/teams/Company_Folder/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/Book2.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

to this: - (dropping the Book2, adding a bunch of &'s and using my newfile Dim that i posted earlier)

ActiveWorkbook.SaveAs FileName:= _
        "https://my_Company.sharepoint.com/teams/Company_Folder/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/" _
               & "\" & newfile & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

So now i just need an error handler to check if the file already exists and if it does then simply add a "counter".
ex: JohnDoe.xlsx exists so next file is JohnDoe1.xlsx and if that exists then name it JohnDoe2.xlsx etc, etc.
Unless of course there is an easier way.

Jaafar - I haven't given up on the pdf save of the userform as i believe i will have need of it in the very near future.
My current userform contains several command buttons. The button that runs this "save as pdf code" also has a lot of other code on it as i need to execute tasks in a specific sequence. That seems to be a problem because the "End Function" part of your code jumps to the bottom of my sub and i get an error. When i tried to make a button specifically for your code as a stand alone operation i got an error on the ME statement. (I dont have the exact errors in front of me as i am at home now.)
I'm positive your code is fine -i'm semi-new at this and i guarantee my code is not efficient. As such, i am not sure i am placing it correctly. I will work on this and get back to you. (I will create a new practice userform.) Thank you for helping me!

 

[Mr_Ragweed2]

Trying to work on code here to see if file already exists on Teams. I'm unsuccessfully adapting some code into this:

'check to see if file exists
    Dim PotentialName As String
    Dim ExistingName As String
    Dim TeamsPath As String
    
    PotentialName = "https://my_Company.sharepoint.com/teams/Company_Folder/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/" & "\" & newfile & ".xlsx"
    TeamsPath = "https://my_Company.sharepoint.com/teams/Company _Folder/Shared%20Documents/General/Sales%20Apps/Seed%20Orders/"
    ExistingName = Dir(TeamsPath & "\" & ".xlsx", vbNormal)
    
    If Not ExistingName = vbNullString Then
    'If ExistingName = PotentialName Then
    MsgBox "You must choose another name to save file as.  ex JohnDoe already exists so use JohnDoe2.  Thank you."
    Exit Sub
    End If

I am getting a "Bad file file name or number" error here:

ExistingName = Dir(TeamsPath & "\" & ".xlsx", vbNormal)

Not sure if its my bad code writing ability or because its on Teams.

 

[Dan_W]

My current userform contains several command buttons. The button that runs this "save as pdf code" also has a lot of other code on it as i need to execute tasks in a specific sequence. That seems to be a problem because the "End Function" part of your code jumps to the bottom of my sub and i get an error. When i tried to make a button specifically for your code as a stand alone operation i got an error on the ME statement. (I dont have the exact errors in front of me as i am at home now.)

I tried Jaafar's code in line with his instructions on how to implement it - namely, to put the code in a userform with a command button. And unsurprisingly, the code works perfectly. The approach Jaafar used was to save the file as Bitmap file, which is what I was thinking of proposing we didn't manage to solve the GDI+ Error 7 you had been experiencing - 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!

As to why it's not working on your computer, based on your helpful explanation of the errors, I suspect that: (1) you put the code in a standard module rather a userform - this would explain the problem with the ME keyword; and (2) the code will jump to the end if an error occurs, and the fact it occured at "End Function" and that you referred to the procedure as a "Sub", suggests that procedure type was changed to a subroutine?

You should try the code again and see whether or not it accomplishes what you were after originally.

BTW, I tested by code for creating a PNG file (that was causing the GDI+ error) - I also encountered that error frustratingly. It appears from my quick testing that the error will occur if the image capture has not been properly stored in the clipboard before GDI+ tried to save it to a file. If you pause for a sufficicent period of time before proceeding with the file saving, then it works. But again, Jaafars approach is the more reliable and straightforward approach to the task. (THANK YOU JAAFAR!)

 

[Dan_W]

I am getting a "Bad file file name or number" error here:

ExistingName = Dir(TeamsPath & "\" & ".xlsx", vbNormal)

Not sure if its my bad code writing ability or because its on Teams.

That approach won't work here, I'm afraid. It is limited to files on your computer's drive - here, by contrast, you're looking to see whether the file exists on the internet. Ordinarily, I would suggest pining the address but have not had a chance to test that. I suspect it may be a case of trying to access the file (through a MSXML2 or WinHttp method) and then seeing what status code returns. I have asked a friend who uses Sharepoint/Teams about it, and have yet to hear back.

 

[Dan_W]

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.