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]

The following requires that WORD be open before running the macro :

Option Explicit

Sub paste_the_pic()
Dim wdPasteDefault
Dim appwd As Object
       Set appwd = GetObject(, "Word.Application")
      
   Worksheets("MS").Shapes("Picture 1").Copy
   appwd.documents.Add
    appwd.Selection.Paste (wdPasteDefault)
    
End Sub

 

[NdNoviceHlp]

Hi j4ymf. Here's a link with some code... This code sends a Word Doc
The guts of your code would go something like this...

Sub test()
Dim wdapp As Object, wddoc As Object, ws As Worksheet
Dim sh As Shape, Flag As Boolean, TblWdth As Double

Set ws = ThisWorkbook.Sheets("sheet1")
Set Rng = ws.Range("D1")

For Each sh In ActiveSheet.Shapes
If sh.Type = msoPicture Or sh.Type = msoLinkedPicture Then
If sh.TopLeftCell.Address = Rng.Address Then
sh.CopyPicture
Flag = True
Exit For
End If
End If
Next sh

If Not Flag Then
MsgBox "No picture in Range " & Rng.Address
Exit Sub
End If

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
wdapp.Visible = True

Set wddoc = wdapp.Documents.Add
With wddoc.PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With wddoc
.Tables.Add wdapp.Selection.Range, NumRows:=1, NumColumns:=1
End With
'paste pic of range
With wddoc.Tables(1).Cell(1, 1).Range
.PasteSpecial DataType:=3
End With
Application.CutCopyMode = False
'format table
With wddoc.Tables(1)
.AutoFormat Format:=16, applyborders:=False
.AutoFitBehavior (0)
.Columns.Width = TblWdth
End With
End Sub

HTH. Dave

 

[j4ymf]

Hello Logit, thank you for your reply - Where whould i put your code as i can't seem to get it to work.

But ive found this code and it copies my picture to a new Word document but how would i combine this to my original code.
could you please help me re write my original code, both of these work but how would i combine them.

Many thanks

Sub luxation()
    Dim objWord, objDoc As Object
    Sheets("MS").Select
    ActiveWindow.View = xlNormalView
    Range("C1").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = True
    objWord.Selection.Paste
    objWord.Selection.TypeParagraph
    
End Sub

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 = 12
        End With
    Next c
    
    ' Add text to footer in left-aligned
    footerText = "  PFP Defined | contactus@pfpdefined.com | 01623 343 007 | pfpdefined.com"

    ' 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]

Each of the macros would go in a Routine Module.

Right click a sheet tab ... say Sheet 1.

Click View Code

In the large white colored space on the right hand side is where you would paste the macros.

Then you would go back to Sheet 1, insert a Command Button on the sheet and when you do a small window opens with the various macro names. Select the macro
you want to run with the button and click OK.

 

[j4ymf]

Thank you Logit

But both codes are still opening two word documents still and i need the picture to be on the same document.

CreateObject("Word.Application")

im guessing its to do with the create object but im still confused

thank you for your patients

 

[NdNoviceHlp]

"But ive found this code and it copies my picture to a new Word document" ????? Did you look at any other responses in this thread? The code in #3 is tested and does exactly what you asked for and is also very similar to the code you "found". It seemed like you already had code for document naming and saving as you posted it, so I didn't include that part. Anyways, I'm sure Logit will be able to assist with any future inquires. Dave

 

[Logit]

Both of the following now create and save to a Word doc :

Option Explicit

Sub luxation()
    Dim objWord, objDoc As Object
    Sheets("Sheet1").Select
    ActiveWindow.View = xlNormalView
    Range("D1").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = True
    objWord.Selection.Paste
    objWord.Selection.TypeParagraph
    
End Sub


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
    Dim wdAlignParagraphLeft

    ' Set the worksheet (assuming sheet name "MS")
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Get the value from Form!C2 for naming the Word document
    docName = ThisWorkbook.Sheets("Sheet1").Range("C1").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 = 12
        End With
    Next c
    
    ' Add text to footer in left-aligned
    footerText = "  PFP Defined | contactus@pfpdefined.com | 01623 343 007 | pfpdefined.com"

    ' 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
    
    With wddoc
        ' Save the Word document with the name from Form!C2
        .SaveAs ThisWorkbook.Path & "\" & docName & ".docx"
    End With
    
    ' 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]

I rewrote the macro in Post #2 and it now functions as desired :

Option Explicit


Sub paste_the_pic()
Dim wdPasteDefault
Dim appwd As Object
Dim wdapp As Object

' 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
        
    Worksheets("Sheet1").Shapes("Picture 1").Copy
    wdapp.documents.Add
    wdapp.Selection.Paste (wdPasteDefault)
    
    MsgBox "Image successfully created in Word."
    
End Sub

 

[j4ymf]

Thank you for your help Logit, much apprichated