vba to copy shape and paste it into folder

[Dancarro]

Hi,

I am struggling with the below vba code.

I have a worksheet that has attached shapes which are pdf's and this worksheet belongs to a country which is in cell B1 (there are more worksheets for more countries).
The objective of the code is for each shape needs to be copied one by one and pasted into the country folder. I tried selecting all the shapes but these don't paste and I tried with recorded macro which neither works.
I have a problem with the pasting function.

Sub CopyShapesII()




Dim wb As Workbook
Dim sh As Shape
Dim strPath As String
Dim WorkBookPath As String
Dim TargetFile As String




Const RootPath As String = "H:\Works\Extract pdf"

strPath = [b1].Value
'If Dir(RootPath & strPath & "", vbDirectory) <> vbNullString Then
'With Application.FileDialog(msoFileDialogOpen)
'.InitialFileName = RootPath & strPath
'.Show

'End With
'Else
'MsgBox " The path " & RootPath & strPath & " does not exist.", vbExclamation, "Error"
'End If

For Each sh In wb.Worksheets("Invoice Attach").Shapes
If sh.Type = msoPicture Then
wb.Worksheets("Invoice Attach").Shapes(sh.Name).Copy
If Dir(RootPath & strPath & "", vbDirectory) <> vbNullString Then
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = RootPath & strPath
.Show

End With

End If
End If
Next
End Sub

Many thanks,
Dan

 

[John_w]

According to your code, the shapes are pictures, however I'm not sure how a picture can be a PDF, unless it is an image of a PDF page.

Anyway, see if this works for you:

Public Sub Save_Picture_Shapes()

    Dim ws As Worksheet
    Dim shp As Shape
    Dim rootPath As String
    Dim folderPath As String
    
    rootPath = "H:\Works\Extract pdf\"
    
    If Right(rootPath, 1) <> "\" Then rootPath = rootPath & "\"
    If Dir(rootPath, vbDirectory) = vbNullString Then MkDir rootPath
    
    For Each ws In ActiveWorkbook.Worksheets
        folderPath = rootPath & ws.Range("B1").Value & "\"
        If Dir(folderPath, vbDirectory) = vbNullString Then MkDir folderPath
        For Each shp In ws.Shapes
            If shp.Type = msoPicture Then
                Save_Object_As_Picture shp, folderPath & shp.Name & ".jpg"
            End If
        Next
    Next
    
    MsgBox "Done"
    
End Sub


Private Sub Save_Object_As_Picture(saveObject As Object, imageFileName As String)

    'Save a picture of an object as a JPG/JPEG
    
    'Arguments
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
    'imageFileName  - the .jpg or .jpeg file name (including folder path if required) the picture will be saved as
    
    Dim temporaryChart As ChartObject
     
    Application.ScreenUpdating = False
    
    saveObject.CopyPicture xlScreen, xlPicture
    
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    With temporaryChart
        .Activate                                'Required, otherwise image is blank with Excel 2016 or fast CPU
        .Border.LineStyle = xlLineStyleNone      'No border
        .Chart.Paste
        .Chart.Export imageFileName
        .Delete
    End With
    
    Application.ScreenUpdating = True
    
    Set temporaryChart = Nothing
    
End Sub

 

[Dancarro]

Hi John,

Thank you for your response. The issue is that it isn't saving the pdf

On my spreadsheet I have several pdf's which are embedded in the worksheet ('attached').

I changed the shp.Type to ... shp.Type = msoEmbeddedOLEObject and this works but it doesn't save the pdf but a picture. I actually need the pdf saved and its content

Sorry if I wasn't clear initially.

Kind Regards,
Dan

 

[John_w]

The shapes aren't pictures then, but embedded OLEObjects (msoEmbeddedOLEObject) as you've found.

Try the code at https://www.mrexcel.com/forum/excel...t-embedded-excel-post4743477.html#post4743477, which saves the first embedded PDF document object as a .PDF file. You'll have adapt the code to loop through ActiveSheet.OLEObjects to save multiple documents and you can delete the AvDoc code which opens the PDF file.

 

[Dancarro]

Hi John,

I reviewed the link you sent and to be honest I am a bit lost there's a lot going on

 

[John_w]

Try this macro - I converted ZVI's code into a function which can be called with a specific PDF OLE object and file name. Because OLE objects don't have a file name, the main loop assigns the file name "SheetName PDFn.pdf", where n increments for each PDF object.

Option Explicit

#If  VBA7 Then
    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 GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End  If


Public Sub Save_All_Embedded_PDFs()

    Dim rootPath As String
    Dim folderPath As String, fullFileName As String
    Dim ws As Worksheet
    Dim OLEobj As OLEObject
    Dim n As Long, saved As Boolean
    
    rootPath = "H:\Works\Extract pdf\"

    If Right(rootPath, 1) <> "\" Then rootPath = rootPath & "\"
    If Dir(rootPath, vbDirectory) = vbNullString Then MkDir rootPath
        
    For Each ws In ThisWorkbook.Worksheets
        folderPath = rootPath & ws.Range("B1").Value & "\"
        If Dir(folderPath, vbDirectory) = vbNullString Then MkDir folderPath
        n = 0
        For Each OLEobj In ws.OLEObjects
            Debug.Print OLEobj.Name, OLEobj.progID, OLEobj.OLEType
            If OLEobj.progID Like "Acro*.Document*" Or OLEobj.OLEType = 1 Then
                n = n + 1
                fullFileName = folderPath & ws.Name & " PDF" & n & ".pdf"
                saved = Save_Embedded_PDF(OLEobj, fullFileName)
                If saved Then MsgBox "Saved " & OLEobj.Name & " on sheet '" & ws.Name & "' as" & vbCrLf & vbCrLf & _
                                     fullFileName
            End If
        Next
    Next
    
End Sub


Public Function Save_Embedded_PDF(obj As Object, fullFileName As String) As Boolean

    #If  VBA7 Then
        Dim hWnd As LongPtr, Size As LongPtr, Ptr As LongPtr
    #Else
        Dim hWnd As Long, Size As Long, Ptr As Long
    #End  If
    
    Dim a() As Byte, b() As Byte, i As Long, j As Long, k As Long
    Dim FN As Integer
    
    Save_Embedded_PDF = False 'default return value - PDF not saved
    
    obj.Copy
    If OpenClipboard(0) Then
        hWnd = GetClipboardData(49156)
        If hWnd Then Size = GlobalSize(hWnd)
        If Size Then Ptr = GlobalLock(hWnd)
        If Ptr Then
            ReDim a(1 To CLng(Size))
            CopyMemory a(1), ByVal Ptr, Size
            Call GlobalUnlock(hWnd)
            i = InStrB(a, StrConv("%PDF", vbFromUnicode))
            If i Then
                k = InStrB(i, a, StrConv("%%EOF", vbFromUnicode)) ' - i + 7
                While k
                    j = k - i + 7
                    k = InStrB(k + 5, a, StrConv("%%EOF", vbFromUnicode))
                Wend
                ReDim b(1 To j)
                For k = 1 To j
                    b(k) = a(i + k - 1)
                Next
                Ptr = 0
            End If
        End If
        Application.CutCopyMode = False
        CloseClipboard
        If i Then
            If Len(Dir(fullFileName)) Then Kill fullFileName
            FN = FreeFile
            Open fullFileName For Binary As #FN
            Put #FN , , b
            Close #FN
        Else
            MsgBox "PDF OLE object " & obj.Name & " not saved because PDF format is corrupted", vbExclamation, "Save Embedded PDF Object"
            Exit Function
        End If
    Else
        Application.CutCopyMode = False
        MsgBox "Can't copy the OleObject '" & obj.Name & "' to the clipboard", vbCritical, "Save Embedded PDF Object"
        Exit Function
    End If
    
    Save_Embedded_PDF = True 'success - PDF saved

    'MsgBox "PDF document is saved as:" & vbLf & fullFileName, vbInformation, "Save Embedded PDF Object"
    
exit_:
        
    If Err Then MsgBox Err.Description, vbCritical, "Error #" & Err.Number
 
End Function

 

[Dancarro]

Hi John,

The macro works which is amazing.

In connection to the pdf, the attached pdf have a name for example REF 0001423_XD2019. Is there a way that the filename can capture this fullFileName = folderPath & ws.Name & " PDF" & n & ".pdf"


Kind Regards,
Dan

 

[John_w]

The file name shown in the PDF object is only available (in the SourceName property) if you ticked 'Link to file' when inserting the PDF file.

This macro shows whether the SourceName is available for each embedded object on the active sheet.

Private Sub Loop_Embedded_Objects()

    Dim obj As OLEObject
    Dim pid As String
    Dim sn As String
    
    For Each obj In ActiveSheet.OLEObjects
        pid = "NOT AVAILABLE"
        sn = "NOT AVAILABLE"
        On Error Resume Next
        pid = obj.progID
        sn = obj.SourceName
        On Error GoTo 0
        MsgBox "OLEObject name = " & obj.Name & vbCrLf & _
               "OLEType = " & obj.OLEType & vbCrLf & _
               "progId = " & pid & vbCrLf & _
               "SourceName = " & sn
    Next

End Sub

If SourceName isn't available then it means the embedded object isn't linked to the original file and therefore the code can't extract the file name from the embedded object.

 

[Dancarro]

Hi John,

Using this latest macro the SourceName isn't available as I couldn't like as the attachments are from different users and I don't want to be linked to their source.

Do you think there is a way around this?

Kind Regards,
Dan

 

[John_w]

Your icon for the embedded PDF includes the original file name, however there's no way of extracting this from the image.

You could define the file name elsewhere, either in a specific cell or as the Alternative Text in the object itself (right-click the embedded object -> Format Object -> Alt Text).