Copy Picture - VBA

[j4ymf]

Hello All

How we use this code to export to a word document but its not copying the pictures, how could we amend this VBA so it copies the pictire in D1 and paste it in the same location.
Many thanks in advance.

Sub ExportMSToWordWithoutBordersAndFooter()
    ' Declare variables
    Dim ws As Worksheet
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim rng As Range
    Dim tbl As Object
    Dim c As Integer
    Dim footerText As String
    Dim docName As String
    Dim creationDate As String

    ' Set the worksheet (assuming sheet name "MS")
    Set ws = ThisWorkbook.Sheets("MS")
   
    ' Get the value from Form!C2 for naming the Word document
    docName = ThisWorkbook.Sheets("Form").Range("C2").Value
   
    ' Format the creation date as "DD.MM.YY"
    creationDate = Format(Date, "DD.MM.YY")
   
    ' Append the creation date to the document name
    docName = docName & " " & creationDate
   
    ' Ensure Excel is in automatic calculation mode
    Application.Calculation = xlCalculationAutomatic
   
    ' Recalculate the worksheet to ensure all data is current
    ws.Calculate
   
    ' Clear the clipboard before copying
    Application.CutCopyMode = False
   
    ' Disable screen updating to ensure fresh data is copied
    Application.ScreenUpdating = False
   
    ' Define the range you want to export (refresh UsedRange)
    Set rng = ws.UsedRange
   
    ' Create a new instance of Word
    On Error Resume Next
    Set wdApp = GetObject(Class:="Word.Application")
    If wdApp Is Nothing Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
   
    ' Make Word visible
    wdApp.Visible = True
   
    ' Create a new document in Word
    Set wdDoc = wdApp.Documents.Add
   
    ' Copy the range from Excel
    rng.Copy
   
    ' Small delay to ensure clipboard updates
    Application.Wait (Now + TimeValue("0:00:01"))
   
    ' Paste the copied Excel content into the Word document as a table to preserve formatting
    wdDoc.Content.PasteExcelTable LinkedToExcel:=False, WordFormatting:=True, RTF:=True
 
    ' Reference the pasted table
    Set tbl = wdDoc.Tables(1)
   
    ' Auto-fit the table in Word to fit the page width
    tbl.AutoFitBehavior 1 ' wdAutoFitWindow = 1
   
    ' Remove all borders from the table
    tbl.Borders.Enable = False
   
    ' Set font size of the first row to 16
    For c = 1 To tbl.Columns.Count
        With tbl.Cell(1, c).Range
            .Font.Size = 16
        End With
    Next c
   
    ' Add text to footer in left-aligned
    footerText = ""

    ' Add footer to the document
    With wdDoc.Sections(1).Footers(1).Range ' wdHeaderFooterPrimary = 1
        .Text = footerText
        .ParagraphFormat.Alignment = wdAlignParagraphLeft ' Left-align the footer
        .Font.Name = "Century Gothic"
        .Font.Size = 11
        .Font.Color = RGB(56, 56, 56) ' Dark grey/black color
        ' Removed the left indent for no spacing
        .ParagraphFormat.SpaceAfter = 0 ' No space after the footer
        .ParagraphFormat.SpaceBefore = 0 ' No space before the footer
    End With
   
    ' Save the Word document with the name from Form!C2
    wdDoc.SaveAs2 ThisWorkbook.Path & "\" & docName & ".docx"
   
    ' Re-enable screen updating
    Application.ScreenUpdating = True
       
    ' Clean up
    Set tbl = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set rng = Nothing
     
   
    ' Inform the user
    MsgBox "Export completed successfully. Document saved as " & docName & ".docx", vbInformation
   
   
 

   
   
End Sub

 

[Logit]

You are welcome