southcraven
12-14-2014, 11:54 PM
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
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