Het lukt niet om de database in zijn geheel toe te voegen.
Hieronder de code zoals ik die nu gebruik.
Het programma loopt nu echter vast met de melding "compileerfout: sub of Function is niet gedefinieerd.
---------------------------------------------------------------------------------------------------------------------
Public Function StripHyperLink(strLink As String)
Dim i As Integer
Dim j As Integer
'opzoeken eerste # sign
i = InStr(strLink, "#")
'opzoeken tweede # sign
j = InStr(i + 1, strLink, "#")
If i <> 0 And j <> 0 Then
StripHyperLink = Mid(strLink, i + 1, (j - i))
Else
StripHyperLink = ""
End If
End Function
---------------------------------------------------------------------------------------------------------------------------
Private Sub Frmdoc_Click()
' On Error GoTo ErrHandler ' weglaten van deze regel schakelt foutafhandeling uit en kun je zien waar het fout gaat
Dim W As word.Application
Dim RS As DAO.Recordset
Dim Sdoc As String
Dim SdocinfoOK As String
Dim SdocinfoERR As String
Dim Sinfomelding As String
'controleer of weeknummer ingegeven is.
If Len(Me.Fweeknr) = 0 Then MsgBox "Geef aub een weeknummer in", vbExclamation: Exit Sub
Set RS = CurrentDb.OpenRecordset("select worddocument from Worddocumenten WHERE kalenderweek = " & Me.Fweeknr, dbOpenSnapshot)
'word opstarten
Set W = New word.Application
'doorloop de records
Do Until RS.EOF
'het volledige pad van het document bepalen, hiervoor # weghalen uit de veldwaarde van de link
'Een gedefinieerd hyperlinkadres bestaat uit maximaal vier elementen, die van elkaar worden gescheiden door een hekje (#):weergavetekst#adres#subadres#scherminfo
'Hier loopt het nu op fout, de tekstweergave wordt ook opgehaald.
Sdoc = RS!worddocument '-> dit levert bestanden op met #-jes
' Sdoc = Replace(RS!worddocument, "#", "")
' newlink = StripHyperLink("weergavetekst#hyperlinkadres#subadres#scherminfo") '(Rene Dirks)
Sdoc = Hyperlink(StripHyperLink("Sdoc")) ' WimenBeer
'controleer of bestand bestaat/benaderd kan worden
'indien dat niet het geval is toevoegen aan string die de foutmelding weergeeft
If Dir(Sdoc) = "" Then
SdocinfoERR = SdocinfoERR & Sdoc & vbCrLf
Else 'we kunnen het bestand benaderen dus probeer printen
W.Documents.Open Sdoc, False, True, False ' ***PROGRAMMA LIEP EERST OP DEZE REGEL VAST***
W.PrintOut
SdocinfoOK = SdocinfoOK & Sdoc & vbCrLf
End If
'volgende record
RS.MoveNext
Loop
'string met resultaat opbouwen
Sinfomelding = "* De volgende documenten zijn succesvol geprint : " & vbCrLf & SdocinfoOK & vbCrLf & vbCrLf & _
"* De volgende documenten zijn niet geprint omdat het bestand niet bestaat of niet kan worden benaderd : " & vbCrLf & SdocinfoERR
'en het resultaat tonen
MsgBox Sinfomelding, vbInformation, "Resultaat van printen"
'opruiming
exithere:
W.ActiveDocument.Close ' Deze regel is vlgs Robthom niet nodig!
W.Quit 'word afsluiten
Set W = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
MsgBox "Fout " & Err.Number & " is opgetreden " & vbCrLf & vbCrLf & Err.Description, vbExclamation
End Select
'als een fout optreedt wel opruiming van variabelen
Resume exithere
End Sub
-------------------------------------------------------------------------------------------------------------------------------
