I am working on the macro which can copy and paste the data excel to word to create the offer letter. Example, we already have the offer letter template in which we will have to modify the few details to roll out offer letter. could you please help me to fix this or it would be big help if you can provide me the new code.
please find the below codes
Public Declare Function CountClipboardFormats Lib "user32" () As Long
Dim appWd As Word.Application
Dim wdFind As Object
Dim ClipT As String
Function IsClipboardEmpty() As Boolean
IsClipboardEmpty = (CountClipboardFormats() = 0)
End Function
Sub CheckClipBrd()
If IsClipboardEmpty() = True Then
ClipEmpty.PutInClipboard
End If
End Sub
Sub FormatPaste()
wdFind.Replacement.Text = ""
wdFind.Forward = True
wdFind.Wrap = wdFindContinue
wdFind.Execute
Call CheckClipBrd
appWd.Selection.Paste
CutCopyMode = False
End Sub
Sub NoFormatPaste()
wdFind.Replacement.Text = ""
wdFind.Forward = True
wdFind.Wrap = wdFindContinue
wdFind.Execute
Call CheckClipBrd
appWd.Selection.PasteSpecial DataType:=wdPasteText
CutCopyMode = False
End Sub
Sub CopyDatatoWord()
Dim docWD As Word.Document
Dim OL As Object
Set appWd = CreateObject("Word. Application")
appWd.Visible = True
Set docWD = appWd.Documents.Open("\\X:\Users\yuan\Financial Director - Offer Letter.docx")
'Select Sheet where copying from in excel
Set OL = Sheets("OL")
Set wdFind = appWd.Selection.Find
ClipT = " "
OL.Range("B4").Copy
wdFind.Text = "<Date>"
Call FormatPaste
OL.Range("B6").Copy
wdFind.Text = "Qwerty02"
Call FormatPaste
OL.Range("B7").Copy
wdFind.Text = "Qwerty03"
Call FormatPaste
OL.Range("B8").Copy
wdFind.Text = "Qwerty04"
Call FormatPaste
OL.Range("B9").Copy
wdFind.Text = "Qwerty05"
Call FormatPaste
OL.Range("B11").Copy
wdFind.Text = "Qwerty06"
Call FormatPaste
OL.Range("B13").Copy
wdFind.Text = "Qwerty07"
Call FormatPaste
OL.Range("B15").Copy
wdFind.Text = "Qwerty08"
Call NoFormatPaste
OL.Range("B17").Copy
wdFind.Text = "Qwerty09"
Call NoFormatPaste
OL.Range("B18").Copy
wdFind.Text = "Qwerty10"
Call NoFormatPaste
OL.Range("B20").Copy
wdFind.Text = "Qwerty11"
Call NoFormatPaste
OL.Range("B22").Copy
wdFind.Text = "Qwerty12"
Call NoFormatPaste
OL.Range("B24").Copy
wdFind.Text = "Qwerty13"
Call NoFormatPaste
End If
'docWD.SaveAs (Dir2 & ".docx")
docWD.SaveAs ("\\annapurna\Shared\Practice Quarterly Reports\Q1_2011\Test.docx")
'appWD.Quit
Set appWd = Nothing
Set docWD = Nothing
End Sub
There is probably a simpler way to do this, but what I've done in the past is embed a WORD template into my excel workbook on another worksheet. The WORD doc has empty bookmarks for where I want to input info. So I basically just open the embedded doc, save a blank copy of it to the user's computer (business requirement to ensure we also use a blank template), then open that blank copy we just saved and fill it out. Then save it.
'opens embedded doc
Set o = .OLEObjects("Object 1")
o.Verb xlVerbOpen
Dim WDApp As Word.Application
Dim wdDoc2 As Word.Document
Dim nIndex As Integer
Set WDApp = GetObject(, "Word.Application")
Set wdDoc = WDApp.ActiveDocument
'must have already named your FilePath
'saves blank copy of template to the user's computer. will override if one exists.
wdDoc.SaveAs2 FilePath & "temp-name" & ".docx"
'closes out of the original doc. then opens the one we saved to the computer
wdDoc.Close
WDApp.Quit
Set WDApp2 = CreateObject("Word.Application")
Set wdDoc2 = WDApp2.Documents.Open(FilePath & "temp=name" & ".docx")
Set objRange = wdDoc2.Bookmarks("Plan").Range
WDApp2.Visible = False
Sheets("Sheet2").Select
'fills out the bookmarks in the doc with values from the worksheet
wdDoc2.FormFields("Pol").Result = Range("B2").Value & Range("E2").Value
wdDoc2.FormFields("Pol2").Result = Range("B2").Value & Range("E2").Value
wdDoc2.FormFields("Name").Result = Range("C3").Value
wdDoc2.FormFields("Name2").Result = Range("C3").Value
wdDoc2.FormFields("Owner").Result = Range("C8").Value
wdDoc2.FormFields("DueDate").Result = Range("B5").Value
wdDoc2.FormFields("Amt").Result = Format(Range("B6").Value, "Currency")
'shows the doc so the use could review, and then press OK to save (not required)
WDApp2.Visible = True
MsgBox "Please Review Letter and Press OK to Continue"
WDApp2.Visible = False
'saves as a docx and a PDF
wdDoc2.SaveAs2 FilePath & "filename" & ".docx"
wdDoc2.SaveAs2 FilePath & "filename" & ".pdf", 17
wdDoc2.Close
WDApp2.Quit
MsgBox "Letter Created Successfully!"
Set WDApp2 = Nothing
Set wdDoc2 = Nothing
Maybe that could help you if all else fails.
Related
I am trying to combine individual MS Word docs into 1 MS Word doc. The below code works just fine to do that. The problem I am having is that I want to insert some code to create a page break after each document so that the next document starts on a new page. I believe something needs to be added in the Sumit routine.
I have tried every syntax that I can possibly find online. Nothing is working.
'Dim fso As New FileSystemObject
Dim NoOfFiles As Double
Dim counter As Integer
Dim r_counter As Integer
Dim s As String
Dim listfiles As Files
Dim newfile As Worksheet
Dim mainworkbook As Workbook
Dim FetchFileClicked
Dim Folderpath As Variant
Sub Sumit()
If FetchFileClicked = False Then
MsgBox "First click the 'Load Control File' button"
End
End If
Application.ScreenUpdating = False
strRandom = Replace(Replace(Replace(Now, ":", ""), "/", ""), " ", "")
MergeFileName = "Merger" & strRandom & ".doc"
MergeFolder = mainworkbook.Sheets("Main").Range("L10").Value
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
Set objSelection = objWord.Selection
objDoc.SaveAs (MergeFolder & MergeFileName)
For i = 1 To NoOfFiles
If Range("B" & i).Value = "Yes" Then
Set objTempWord = CreateObject("Word.Application")
Set tempDoc = objWord.Documents.Open(Folderpath & "\" & Range("A" & i).Value)
Set objTempSelection = objTempWord.Selection
tempDoc.Range.Select
tempDoc.Range.Copy
objSelection.TypeParagraph
objSelection.Paste
tempDoc.Close
End If
Next
objDoc.Save
Application.ScreenUpdating = True
mainworkbook.Sheets("Main").Activate
MsgBox "Completed...Merge File is saved at " & MergeFolder & MergeFileName
FetchFileClicked = False
End Sub
Sub fetchFiles()
Set mainworkbook = ActiveWorkbook
Range("A:A").Clear
Range("B:B").Clear
Folderpath = mainworkbook.Sheets("Main").Range("L8").Value
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 0
For Each fls In listfiles
counter = counter + 1
Range("A" & counter).Value = fls.Name
'Range("B" & counter).Value = "Yes"
Range("A" & counter).Borders.Value = 1
Range("B" & counter).Borders.Value = 1
With Range("B" & counter).Validation
.Delete
'replace "=A1:A6" with the range the data is in.
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="Yes,No"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Next
Call controlFile
MsgBox "Control File Loaded"
FetchFileClicked = True
End Sub
Sub controlFile()
Worksheets("Main").Range("b1:b6").Formula = "=iferror(VLOOKUP(A1,Table2,MATCH(""load"",Table2[#Headers],0),0),"""")&"""""
Application.Wait (Now + TimeValue("0:00:03"))
End Sub
I expect each of the individual documents that are added to the newly combined document to be added at the "start of a new page", NOT in the middle of an existing page, like it is today.
I have a code which copies data from a spreadsheet into specific bookmarks on a particular document. When it is run it works fine, but the bookmarks are deleted from the spreadsheet. Is there a way I can keep the bookmarks in the document
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet6")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\GR1 CPA Test1.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("CN1").Range.Text = ws.Range("C25").Value
.Bookmarks("CN2").Range.Text = ws.Range("C25").Value
.Bookmarks("CNo").Range.Text = ws.Range("C26").Value
.Bookmarks("CL1").Range.Text = ws.Range("C27").Value
.Bookmarks("Ex1").Range.Text = ws.Range("C28").Value
.Bookmarks("Ex2").Range.Text = ws.Range("C28").Value
.Bookmarks("Su1").Range.Text = ws.Range("C29").Value
.Bookmarks("Su2").Range.Text = ws.Range("C29").Value
.Bookmarks("Su3").Range.Text = ws.Range("C29").Value
.Save
.Close
End With
Set objWord = Nothing
End Sub
I've used this in the past:
'Replace the text in a bookmark or insert text into an empty (zero-length) bookmark
Sub SetBookmarkText(oDoc As Word.Document, sBookmark As String, sText As String)
Dim BMRange As Word.Range
If oDoc.Range.Bookmarks.Exists(sBookmark) Then
Set BMRange = oDoc.Range.Bookmarks(sBookmark).Range
BMRange.Text = sText
oDoc.Range.Bookmarks.Add sBookmark, BMRange
Else
MsgBox "Bookmark '" & sBookmark & "' not found in document '" & oDoc.Name & "'" & _
vbCrLf & "Content not updated"
End If
End Sub
Usage:
Dim ws As Worksheet, doc as object
Set ws = ThisWorkbook.Sheets("Sheet6")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set doc = objWord.Documents.Open("C:\GR1 CPA Test1.docx")
SetBookmarkText doc, "CN1", ws.Range("C25").Value
SetBookmarkText doc, "CN2", ws.Range("C25").Value
'etc etc
doc.Save
doc.Close
Set objWord = Nothing
End Sub
I am writing a vba macro for a word document. I use vba macro to generate textbox and text to the word document. The issue is that the textbox moves to the top of last page instead of staying on the first page.
I don't know what i am doing wrong. All i need is for that textbox to remain on the first page. I really need to include the textbox.
below is my code and the output image
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
ActiveDocument.Content.Select
Selection.Delete
With wdApp
.Visible = True
.Activate
With .Selection
Dim objShape As Word.Shape
Set objShape2 = ActiveDocument.Shapes.addTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
With .Selection
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
For i = 1 To 40
.TypeText i
.TypeParagraph
Next i
End With
End With
Word Shape objects must be anchored to a character position in the Word document. They will always appear on the page where the anchor character is and, if the anchor formatting is not to the page, they will move relatively on the page with the anchor character.
A special case ensues when a document is "empty" (a lone paragraph), so it helps to make sure the document has more than one character in it. In the code sample below an additional paragraph is inserted before adding the TextBox - to the first paragraph.
I've made some other adjustments to the code:
Added On Error GoTo 0 so that error messages will appear. Otherwise, debugging becomes impossible.
Removed the With for the Word application since it's not necessary when using Word objects
Declared and use a Word Range object for inserting content. As with Excel, it's better to not work with Selection whenever possible.
Used the wrdDoc object you declare and instantiate instead of ActiveDocument.
This code worked fine in my test, but I cannot, of course, repro your entire environment.
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
wdApp.Visible = True
wrdApp.Activate
Dim i As Long
Dim objShape2 As Word.Shape
Dim rng As Word.Range
Set rng = wrdDoc.Content
rng.Delete
With rng
.InsertAfter vbCr
.Collapse wdCollapseStart
Set objShape2 = ActiveDocument.Shapes.AddTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60, Anchor:=rng)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
rng.Start = ActiveDocument.Content.End
For i = 1 To 40
.Text = i & vbCr
.Collapse wdCollapseEnd
Next i
End With
Another solution for you to look at.
'12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
'========1=========2=========3=========4=========5=========6=========7=========8=========9=========A=========B=========C
Option Explicit
Sub textboxtest()
Const my_doc_name As String = "mydocument.docx"
Dim my_fso As Scripting.FileSystemObject
Dim my_doc As Word.Document
Dim my_range As Word.Range
Dim counter As Long
Dim my_text_box As Word.Shape
Dim my_shape_range As Word.ShapeRange
' There is no need to test for the Word app existing
' if this macro is in a Word template or Document
' because to run the macro Word MUST be loaded
Set my_fso = New Scripting.FileSystemObject
If my_fso.FileExists(ThisDocument.Path & "\" & my_doc_name) Then
Set my_doc = Documents.Open(ThisDocument.Path & "\" & my_doc_name)
Else
Set my_doc = Documents.Add
my_doc.SaveAs2 ThisDocument.Path & "\" & my_doc_name
End If
my_doc.Activate ' Although it should already be visible
my_doc.content.Delete
Set my_text_box = my_doc.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
left:=400, _
top:=100, _
Width:=250, _
Height:=60)
With my_text_box
.Name = "TextBox1"
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.left = wdShapeRight
.top = wdShapeTop
With .TextFrame
.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
Set my_range = my_text_box.Parent.Paragraphs(1).Range
'FROM
'
' https://learn.microsoft.com/en-us/office/vba/api/word.shape'
' Every Shape object is anchored to a range of text. A shape is anchored
' to the beginning of the first paragraph that contains the anchoring
' range. The shape will always remain on the same page as its anchor.
my_range.Collapse Direction:=wdCollapseEnd
With my_range
For counter = 1 To 90
.Text = counter
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
Next
End With
End Sub
I whould like to fill a word with values and export to pdf multiple times.
If is use a SaveAs2 the firt time it make a pdf but second or third it doesen't work.
'ActiveDocument.SaveAs2 FileName:="C:\alap\" & fajlneve & ".pdf", FileFormat:=wdFormatPDF
If I use the CutePDf printer, the result is the same, first time i=1 it works, but second it doesen't.
Public compname As String
Public filename As String
Function FillwordForm()
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Error.Clear
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
Path = "C:\pelda\MINTA.docx"
Set doc = appword.Documents.Open(Path, , True)
With doc
.formfields("szerzCegnev").result = compname
End With
appword.Visible = True
appword.Activate
Set doc = Nothing
Set appword = Nothing
appword.ActivePrinter = "CutePDF Writer"
ActiveDocument.PrintOut OutPutFileName:="C:\pelda\" & filename & ".pdf"
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Word.Application.Quit
End Function
'---------------------------------------------------------------
Sub cucc()
For i = 1 To 2
compname = Cells(i, 1)
filename = Cells(i, 2)
Call FillwordForm
Next i
End Sub
can you use:
ActiveDocument.SaveAs2(docname,17);
?
(17 is PDF-format -link to fileformats)
Greetz
I keep getting the 462 error the second or third time I run this loop. I don't think I have any objects that are floating but maybe I missed something, I am kind of new at this. This macro is taking all the charts from Excel, pasting them into Word as pictures, resizing them, saving the document and closing it. The For loop has formatting for the chart to be pasted as a normal picture and the text below it to be caption so I can create a figure table easily.
The error takes place in the .Height = InchesToPoints(6.1) line.
Private Sub ChartstoWord_Click()
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim cname, wordname, restage, pNumber, wfile As String
Dim n As Integer
Dim i As Long
Application.ScreenUpdating = False
If wordfile.Value = "" Then
MsgBox "Please enter a word file name", vbOKOnly
Exit Sub
End If
wfile = CurveDirectoryBox & "\" & wordfile.Value & ".docx"
wordname = UCase(dataname.Value)
'if word file doesn't exist then it makes the word file for you
If Dir(wfile) = "" Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
Set WDDoc = WDApp.Documents.Add
WDApp.Visible = True
With WDDoc
.SaveAs wfile
.Close
End With
Set WDDoc = Nothing
WDApp.Quit
Set WDApp = Nothing
End If
' Create new instance of Word and open filename provided if file exists
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Open wfile
WDApp.Visible = True
Set WDDoc = WDApp.ActiveDocument
With WDDoc
.Range(start:=.Range.End - 1, End:=.Range.End - 1).Select
.PageSetup.Orientation = wdOrientLandscape
End With
For n = 1 To Charts.Count
Charts(n).Select
cname = ActiveChart.ChartTitle.Characters.Text
ActiveChart.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
' Paste chart at end of current document
WDApp.Visible = True
With WDApp
.Selection.Style = WDApp.ActiveDocument.Styles("Normal")
.Selection.Font.Size = 12
.Selection.Font.Bold = True
.Selection.PasteSpecial Link:=False, Placement:=wdInLine, DisplayAsIcon:=False, DataType:=wdPasteEnhancedMetafile
.Selection.TypeParagraph
.Selection.Style = WDApp.ActiveDocument.Styles("Caption")
.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Selection.Font.Size = 12
.Selection.Font.Bold = False
.Selection.TypeText (wordname + " " + cname)
.Selection.TypeParagraph
End With
Next n
'resize all pictures
WDApp.Visible = True
With WDApp
With WDDoc
For i = 1 To WDApp.ActiveDocument.InlineShapes.Count
With WDApp.ActiveDocument.InlineShapes(i)
'.Width = InchesToPoints(7.9)
.Height = InchesToPoints(6.1)
End With
Next i
End With
End With
WDDoc.Save
WDDoc.Close
Set WDDoc = Nothing
WDApp.Quit
Set WDApp = Nothing
Worksheets("Control").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub
I was able to solve the problem, ended up being that the command InchesToPoints is a word command and needs the wdapp in front of it. Thanks for all the suggestions, I also cleaned up a code a bit after all your receommendations.
Private Sub ChartstoWord_Click()
Dim WDApp As Word.Application
Dim cname, wordname, restage, pNumber, wfile As String
Dim n As Integer
Dim i, h As Long
Application.ScreenUpdating = False
If wordfile.Value = "" Then
MsgBox "Please enter a word file name", vbOKOnly
Exit Sub
End If
wfile = CurveDirectoryBox & "\" & wordfile.Value & ".docx"
wordname = UCase(dataname.Value)
'if word file doesn't exist then it makes the word file for you
If Dir(wfile) = "" Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Add
WDApp.ActiveDocument.SaveAs wfile
WDApp.ActiveDocument.Close
WDApp.Quit
Set WDApp = Nothing
End If
' Create new instance of Word and open filename provided if file exists, checks to see if file is open or not already
If IsFileOpen(wfile) = False Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Open wfile
End If
If IsFileOpen(wfile) = True Then
Set WDApp = GetObject(wfile).Application
WDApp.Visible = True
End If
'moves cursor in word to the end of the document and change page to landscape
WDApp.ActiveDocument.Range(start:=WDApp.ActiveDocument.Range.End - 1, End:=WDApp.ActiveDocument.Range.End - 1).Select
WDApp.ActiveDocument.PageSetup.Orientation = wdOrientLandscape
'loops through all charts and pastes them in word
For n = 1 To Charts.Count
Charts(n).Select
cname = ActiveChart.ChartTitle.Characters.Text
ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
WDApp.Visible = True
WDApp.Selection.Style = WDApp.ActiveDocument.Styles("Normal")
WDApp.Selection.Font.Size = 12
WDApp.Selection.Font.Bold = True
WDApp.Selection.PasteSpecial Link:=False, Placement:=wdInLine, DisplayAsIcon:=False, DataType:=wdPasteEnhancedMetafile
WDApp.Selection.TypeParagraph
WDApp.Selection.Style = WDApp.ActiveDocument.Styles("Caption")
WDApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
WDApp.Selection.Font.Size = 12
WDApp.Selection.Font.Bold = False
WDApp.Selection.TypeText (wordname + " " + cname)
WDApp.Selection.TypeParagraph
Next n
'resize all pictures
WDApp.Visible = True
For i = 1 To WDApp.ActiveDocument.InlineShapes.Count
WDApp.ActiveDocument.InlineShapes(i).Select
WDApp.ActiveDocument.InlineShapes(i).Height = WDApp.InchesToPoints(6.1)
Next i
WDApp.ActiveDocument.SaveAs wfile
WDApp.ActiveDocument.Close
WDApp.Quit
Set WDApp = Nothing
Worksheets("Control").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Definitly too much With, and not even used, so here is a version of your resize that should be cleaner but not sure that it'll be enough, give it a try
Too many WDApp.Visible = True also, only one will be enough but as you close it after, you should even set it to False!
'resize all pictures
For i = 1 To WDDoc.InlineShapes.Count
With WDDoc.InlineShapes(i)
'.Width = InchesToPoints(7.9)
.Height = InchesToPoints(6.1)
End With
Next i