Don Elliker
delliker at hotmail.com
Fri Aug 8 10:35:30 CDT 2003
OK- maybe I didn't put enough code in the last try at this question, so here
is everyting except the dimensioning.
This fails when I try to use '.Action = acOLECreateLink' I get error 2771-
"The bound or unbound object frame you tried to edit doesn't contain an OLE
object."
Does Anybody have any idea why???
There is a QDoc on a similar subject but it has to do with Developer Toolkit
custom OLE controls which this is not.
strsql = "SELECT testcaseid,execcounter,screenshotref FROM
[tblTCScreenShot]"
Set rs = dbCur.OpenRecordset(strsql, dbOpenSnapshot)
If rs.RecordCount <> 0 Then
For intI = 0 To dbCur.Containers("reports").Documents.Count - 1
Set myDoc = dbCur.Containers("reports").Documents(intI)
If myDoc.Name Like "Report*" Then
DoCmd.DeleteObject acReport, myDoc.Name
End If
Next intI
rs.MoveLast
rs.MoveFirst
ReDim arstrReportName(1 To rs.RecordCount)
For intI = 1 To rs.RecordCount
varreturn = Dir(rs!screenshotref)
If varreturn <> "" Then
'Set myObj = GetObject(rs!screenshotref)
Set rpt = CreateReport(dbCur.Name, "Template")
Set ctl = CreateReportControl(rpt.Name, acObjectFrame,
acDetail, "", "", 25, 12)
strRef = rs!screenshotref
arstrReportName(intI) = rpt.Name
'DoCmd.Close acReport, rpt.Name, acSaveYes
'DoCmd.OpenReport arstrReportName(intI), acViewDesign, , ,
acHidden
Set ctl = Reports(0).Section(0).Controls(0)
With ctl
.Name = "SS" & intI
'.Class = "word.document.8"
.OLETypeAllowed = acOLEEither
.SourceDoc = strRef
'.SourceDoc = myObj
.SizeMode = acOLESizeZoom
.Action = acOLECreateLink
'.SourceItem = myObj
End With
DoCmd.Close acReport, arstrReportName(intI), acSaveYes
rs.MoveNext
Else
MsgBox "Could not find file " & rs!screenshotref,
vbExclamation, APP_CAPTION
End If
Next intI
For intI = 1 To UBound(arstrReportName)
If UBound(arstrReportName) > 0 Then
DoCmd.OpenReport arstrReportName(intI), acViewPreview
Else
MsgBox "No attachments found for this report.",
vbInformation, APP_CAPTION
End If
Next intI
End If
fnPrintScreenShot_Exit:
Erase arstrReportName
Set myObj = Nothing
Set rs = Nothing
Set ctl = Nothing
Set myDoc = Nothing
Set rpt = Nothing
If strEMsg <> "" Then
MsgBox strEMsg, vbInformation, APP_CAPTION
End If
Exit function
fnPrintScreenShot_Err:
Select Case Err
Case 7874
Resume Next
Case Else
strEMsg = Err & " - " & Err.Description
Resume fnPrintScreenShot_Exit
End Select
End function
"Things are only free to the extent that you don't pay for them".-Don
Elliker
_________________________________________________________________
Tired of spam? Get advanced junk mail protection with MSN 8.
http://join.msn.com/?page=features/junkmail