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
"John Bundy" <(E-Mail Removed)(remove)> wrote in message
news:FACE0C9C-4658-4E7B-88FE-(E-Mail Removed)...
> Will need code and specific error to be much help, you can try pushing
> through it with a application.displayalerts=false or on error resume next
> but
> maybe not, and it won't solve the underlying issue.
> --
> -John
> Please rate when your question is answered to help us and others know what
> is helpful.
>
>
> "Richard" wrote:
>
>> We have a macro that copies an Excel range and pastes it as a metafile
>> picture (we want the color fonts to show in black/white in the picture)
>> in a
>> Word document.
>>
>> Some of our users are getting this error when running our macro. Users
>> can
>> continue running the macro by clicking Ok on the error msg but sometimes
>> they have to exit out of Excel completely.
>>
>> Users are getting the error but I haven't been able to find the cause or
>> reproduce the error myself.
>> Any help will be greately appreciated.
>>
>> Thanks,
>> Richard
>>
>>
>>
|
Similar Threads
