That won't solve the error. I'm looking for an answer to what is causing the
error.
Here's more detail:
Err.Description: This method or property is not available because the
Clipboard is empty or not valid.
Err.Number: 4605
This is the macro function I use (I omitted the variable declarations):
Sub SendPics(sNamedRangeHasBrokenReference As String,
sInvalidBookMarkInlineObj As String, sInvalidBookMarkStartEnd As String,
sInvalidBookMark As String, sMissingBookmarks As String, sBookmarkExtends As
String)
sMissingBookmarks = ""
On Error GoTo ErrorHandler
'loop through each sheet
For i = 0 To LstSheets.ListCount - 1
If LstSheets.Selected(i) = True Then 'If the Worksheet is
selected
WorkSheetName = Me.LstSheets.List(i)
Call ClearClipboard
For Each aName In Worksheets(WorkSheetName).Names
WsNameLength = Len(WorkSheetName)
'Adjust for Names that Have Quotes around the WorksheetName
QuoteAdj = 0
If Left(aName.name, 1) = "'" Then QuoteAdj = 2
If Mid(aName.name, WsNameLength + QuoteAdj + 2, 5) = "zetw_"
Then
PicName = Right(aName.name, Len(aName.name) -
WsNameLength - QuoteAdj - 1)
MyStatusBar.SimpleText = "Sending " & PicName
If Doc.Bookmarks.Exists(PicName) Then
Set B = Doc.Bookmarks.Item(PicName)
With B
bErrorFound = False
'VALIDATE Word bookmarks
Call ValidateBookmarks(B, aName, bErrorFound,
sNamedRangeHasBrokenReference, sInvalidBookMarkInlineObj,
sInvalidBookMarkStartEnd, sInvalidBookMark, sMissingBookmarks,
sBookmarkExtends)
If Not bErrorFound Then
On Error Resume Next
Set rngValidation = Nothing
Set rngValidation =
aName.RefersToRange.SpecialCells(xlCellTypeAllValidation)
'format lists (font=brown, underline) in
tables
'before sending image to Word
If Not rngValidation Is Nothing Then Call
SetListsFormat(WorkSheetName, True, PicName)
On Error GoTo SkipName
'Copy Excel table range
aName.RefersToRange.Copy
Set myShapeRange =
..Range.InlineShapes(1).Range
Set r = myShapeRange.Duplicate
'Set r =
Doc.Range(.Range.InlineShapes(1).Range.start,
..Range.InlineShapes(1).Range.End)
r.PasteSpecial Link:=False,
DataType:=wdPasteMetafilePicture, Placement:=wdInLine
Doc.Bookmarks.Add PicName,
Doc.Range(r.start - 1, r.start)
If ChkViewReport Then
With TheSentRange
.name = aName.name
.Sent = True
ValueReviewed = True
End With
End If
'format lists (font=brown, underline) in
tables
'after sending image to Word
If Not rngValidation Is Nothing Then Call
SetListsFormat(WorkSheetName, False, PicName)
End If 'END data validation
End With
Else 'If Doc.Bookmarks.Exists(PicName)
'No placeholder (bookmark) found. The picture will
not be sent
sMissingBookmarks = sMissingBookmarks & aName.name &
vbNewLine
End If 'END If Doc.Bookmarks.Exists(PicName)
If ChkViewReport Then
With TheSentRange
If ValueReviewed = False Then
.name = aName.name
.Sent = False
End If
If .name <> vbNullString Then SentRanges.Add
TheSentRange
Set TheSentRange = Nothing
ValueReviewed = False
End With
End If
End If 'END IF = "zetw_"
SkipName:
'trap & handle errors
If Err.Number <> 0 Then
'command failed error ('r.PasteSpecial' failed)
If Err.Number = 4198 Then
Resume
'Out of Memory error
ElseIf Err.Number = 4605 Then
Err.Raise 4605
'specified data type is unavailable error -
aName.RefersToRange.Copy failed; it copied data in bad format
ElseIf Err.Number = 5342 Then
aName.RefersToRange.Copy
Resume
End If
Err.Clear
End If
Next aName
On Error GoTo ErrorHandler
End If ' LstSheets.Selected(i) = True
Next i
MyStatusBar.SimpleText = "Ready "
'RLT 6/15/06 destroy objects to release memory and application prevent
slow down
Set r = Nothing
Set B = Nothing
Set B2 = Nothing
Set aName = Nothing
Set TheSentRange = Nothing
Set rngValidation = Nothing
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 4198
Resume
Case 5891
MsgBox "Your word document may contain a bookmark which does not
have a name." & _
(Chr(13) & Chr(10)) & "Please update the associated Word
document:" & _
(Chr(13) & Chr(10)) & "1. Go to the associated Word document,
click Insert, click Bookmark." & _
(Chr(13) & Chr(10)) & "2. Scroll to the top of the bookmark
list and delete the blank bookmark to fix this error." & _
(Chr(13) & Chr(10)) & "3. If you still receive this error
please contact your administrator", vbOKOnly, "Associate and Send"
Case 4605
MsgBox "Out of Memory error is preventing Associate & Send from
continuing.", vbOKOnly, "Associate and Send"
Case Else
Call ErrorHandlerFunction("SendPics")
End Select
'RLT 6/15/06 destroy objects to release memory and application prevent
slow down
Set r = Nothing
Set B = Nothing
Set B2 = Nothing
Set aName = Nothing
Set TheSentRange = Nothing
Set SentRanges = Nothing
Set rngValidation = Nothing
End Sub
