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