Paste Excel Picture from Cell in to Word - Error 438

[southcraven]

The following code fails at line For Each Pic In ActiveSheet.Pictures



Sub cmdPrint()
'
' cmdPrint_Click
' Opens Word Template pastes BM data saves as new file name
'

Dim rngCProw As Range
Dim Pic As Picture

Set rngCProw = ActiveCell.EntireRow 'selected row as range variable
rngCProw.Select 'reselect row if user selected one cell

' UserForm1.Show

Dim WDApp As Word.Application 'opens word in background
Dim WDDoc As Word.Document

Set WDApp = New Word.Application

With WDApp
Set WDDoc = .Documents.Add(Template:="Survey Station Description 3.dotm")
.Visible = True 'line above opens the station description template this line makes it visible
.Selection.GoTo what:=wdGoToBookmark, Name:="Name"
.Selection.TypeText Text:=rngCProw.Range("A1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Location"
.Selection.TypeText Text:=rngCProw.Range("B1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Lat4326"
.Selection.TypeText Text:=rngCProw.Range("C1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Long4326"
.Selection.TypeText Text:=rngCProw.Range("D1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Lat1303v4284"
.Selection.TypeText Text:=rngCProw.Range("E1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Long1303v4284"
.Selection.TypeText Text:=rngCProw.Range("F1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="E1303v28409"
.Selection.TypeText Text:=rngCProw.Range("G1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="N1303v28409"
.Selection.TypeText Text:=rngCProw.Range("H1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Lat15865v4284"
.Selection.TypeText Text:=rngCProw.Range("I1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Long15865v4284"
.Selection.TypeText Text:=rngCProw.Range("J1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="E15865v28409"
.Selection.TypeText Text:=rngCProw.Range("K1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="N15865v28409"
.Selection.TypeText Text:=rngCProw.Range("L1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="Elevation"
.Selection.TypeText Text:=rngCProw.Range("M1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="ScaleFactor"
.Selection.TypeText Text:=rngCProw.Range("N1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="LocalGridE"
.Selection.TypeText Text:=rngCProw.Range("O1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="LocalGridN"
.Selection.TypeText Text:=rngCProw.Range("P1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="txtPoint"
.Selection.TypeText Text:=rngCProw.Range("Q1").Value
.Selection.GoTo what:=wdGoToBookmark, Name:="txtNotes"
.Selection.TypeText Text:=rngCProw.Range("R1").Value

'copies images in columns S,T,U from the matched row
For Each Pic In ActiveSheet.Pictures
If Pic.TopLeftCell.Address = rngCProw.Range("S1").Address Then
Pic.Copy
.Selection.GoTo what:=wdGoToBookmark, Name:="Map"
.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False, _
DataType:=wdPasteMetafilePicture ', Placement:=wdFloatOverText
ElseIf Pic.TopLeftCell.Address = rngCProw.Range("T1").Address Then
Pic.Copy
.Selection.GoTo what:=wdGoToBookmark, Name:="???" '<---Change the bookmark Name to suit
.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False, _
DataType:=wdPasteMetafilePicture ', Placement:=wdFloatOverText
ElseIf Pic.TopLeftCell.Address = rngCProw.Range("U1").Address Then
Pic.Copy
.Selection.GoTo what:=wdGoToBookmark, Name:="???" '<---Change the bookmark Name to suit
.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False, _
DataType:=wdPasteMetafilePicture ', Placement:=wdFloatOverText
End If
Next Pic

End With

Set WDApp = Nothing
Set myDoc = Nothing

End Sub

[Charlize]

Maybe try a counting loop instead of For Each loop. Something like this :


'counter for number of pictures on sheet
Dim picno As Long
'holder for the picture
Dim thepic
'do this only if some pictures are on active sheet
If ActiveSheet.Pictures.Count > 0 Then
'loop through them all
For picno = 1 To ActiveSheet.Pictures.Count
'the first picture assigned to thepic
Set thepic = ActiveSheet.Pictures.Item(picno)
If thepic.Address = rngCProw.Range("S1").Address Then
thepic.Copy
.Selection.Goto what:=wdGoToBookmark, Name:="Map"
.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False, _
DataType:=wdPasteMetafilePicture ', Placement:=wdFloatOverText
ElseIf thepic.TopLeftCell.Address = rngCProw.Range("T1").Address Then
thepic.Copy
.Selection.Goto what:=wdGoToBookmark, Name:="???" '<---Change the bookmark Name to suit
.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False, _
DataType:=wdPasteMetafilePicture ', Placement:=wdFloatOverText
ElseIf thepic.TopLeftCell.Address = rngCProw.Range("U1").Address Then
thepic.Copy
.Selection.Goto what:=wdGoToBookmark, Name:="???" '<---Change the bookmark Name to suit
.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False, _
DataType:=wdPasteMetafilePicture ', Placement:=wdFloatOverText
End If
Next picno
End If
Charlize

[Charlize]

Or maybe it's just the declaration of Pic. Try declaring it as object instead of picture. Pic isn't a keyword either ?

[southcraven]

Please review posts here, thanks for replying

excel forum, cannot post links, but same subject

[snb]

Don't use bookmarks in Word if you are using VBA.
You'd better use documentvariables instead

in that case you can use:


Sub M_snb()
sn=range("A1:R1")

for j=1 to ubound(sn,2)
activedocument.variables(chr(j+64))=sn(1,j)
next
activedocument.fields.update
End sub