Hi Graham,
Thanks a lot for your suggestions.
I always use Option explicit in all the modules.
The solution of this issue was spotted by Bill:
Wrd.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strFileWord, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
Warmest regards.
Norbert
Sorry I did not send of the complete code however here it is:
--------------------------------------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : cmdExhibits_Click
' Author : certified
' Date : 9/1/2014
' Purpose :
'---------------------------------------------------------------------------------------
Private Sub cmdExhibits_Click()
Dim dbsDB As Database
Dim rstRS As DAO.Recordset
Dim strSQL As String
Dim rstRS1 As DAO.Recordset
Dim strSQL1 As String
Dim rstRS2 As DAO.Recordset
Dim strSQL2 As String
Dim strExhibits As String
Dim intExhibits As Integer
Dim strDOS As String
Dim intDOSCt As Integer
Dim strExhibitByDr As String
Dim intExhibitByDr As Integer
Dim intspace As Integer
Dim intSpace2 As Integer
Dim intSpace1 As Integer
Dim Wrd As New Word.Application
Dim strMergeDoc As String
Dim strDBPath As String
Dim strDBFile As String
Dim dbdir As String
Dim strServerPath As String
Dim strWitnesses As String
Dim strDirWord As String
Dim strFileWordName As String
Dim strFileWord As String
Dim strFileTempWord As String
On Error GoTo cmdExhibits_Click_Error
intSpace2 = 3
intSpace1 = 4
Set dbsDB = CurrentDb
strSQL = "SELECT * FROM tblExhibits Where ExhibitFlag=True"
Set rstRS = dbsDB.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
strDOS = ""
intDOSCt = 0
strExhibits = ""
With rstRS
Do Until .EOF
If !ExhibitsID = 2 Then
intExhibits = 1
strSQL1 = "SELECT * FROM QS_ExhibitsBalance WHERE " & "ClientID= " & Me.txtClientID
Set rstRS1 = dbsDB.OpenRecordset(strSQL1, dbOpenDynaset, dbSeeChanges)
Do Until rstRS1.EOF
intDOSCt = intDOSCt + 1
If intDOSCt = 4 Then
strDOS = strDOS & vbCrLf
strDOS = strDOS & Space(52) & Format(rstRS1!Date, "mm/dd/yyyy")
intDOSCt = 1
Else
If intDOSCt = 1 Then
strDOS = Space(28) & Format(rstRS1!Date, "mm/dd/yyyy")
Else
strDOS = strDOS & "," & Format(rstRS1!Date, "mm/dd/yyyy")
End If
End If
If Left(strDOS, "1") = "," Then strDOS = Mid(strDOS, 2)
rstRS1.MoveNext
Loop
rstRS1.Close
strExhibits = intExhibits & "." & Space(intSpace1) & !Description & strDOS
End If
If !ExhibitsID = 3 Then
strSQL1 = "SELECT * FROM QS_ExhibitsByDr WHERE " & "ClientID= " & Me.txtClientID
Set rstRS1 = dbsDB.OpenRecordset(strSQL1, dbOpenDynaset, dbSeeChanges)
Do Until rstRS1.EOF
strSQL2 = "SELECT * FROM QS_ExhibitsDr WHERE " & "ClientID= " & Me.txtClientID & " AND LocationNo=" & rstRS1!LocationNo
Set rstRS2 = dbsDB.OpenRecordset(strSQL2, dbOpenDynaset, dbSeeChanges)
intDOSCt = 0
strDOS = ""
intExhibits = intExhibits + 1
Do Until rstRS2.EOF
If Len(CStr(intExhibits)) = 2 Then
intspace = intSpace2
Else
intspace = intSpace1
End If
intExhibitByDr = 51 - Len(intExhibits & Space(intspace) & !Description & " " & rstRS2!Doctor)
intDOSCt = intDOSCt + 1
If intDOSCt = 4 Then
strDOS = strDOS & vbCrLf
strDOS = strDOS & Space(51) & Format(rstRS1!Date, "mm/dd/yyyy")
intDOSCt = 1
Else
If intDOSCt = 1 Then
strDOS = Format(rstRS2!Date, "mm/dd/yyyy")
Else
strDOS = strDOS & "," & Format(rstRS2!Date, "mm/dd/yyyy")
End If
End If
If Len(CStr(intExhibits)) = 2 Then
intspace = intSpace2
Else
intspace = intSpace1
End If
strExhibitByDr = intExhibits & "." & Space(intspace) & !Description & " " & rstRS2!Doctor & Space(intExhibitByDr) & strDOS
rstRS2.MoveNext
Loop
strExhibits = strExhibits & vbCrLf & vbCrLf & strExhibitByDr
rstRS1.MoveNext
Loop
rstRS1.Close
End If
If !ExhibitsID = 4 Then
intExhibits = intExhibits + 1
If Len(CStr(intExhibits)) = 2 Then
intspace = intSpace2
Else
intspace = intSpace1
End If
strExhibits = strExhibits & vbCrLf & vbCrLf & intExhibits & "." & Space(intspace) & !Description
End If
If !ExhibitsID = 5 Then
intExhibits = intExhibits + 1
If Len(CStr(intExhibits)) = 2 Then
intspace = intSpace2
Else
intspace = intSpace1
End If
strExhibits = strExhibits & vbCrLf & vbCrLf & intExhibits & "." & Space(intspace) & !Description & Space(83 - (Len(intExhibits) + intspace + Len(!Description) + Len(!ServiceDates))) & !ServiceDates
End If
If !ExhibitsID = 6 Then
intExhibits = intExhibits + 1
If Len(CStr(intExhibits)) = 2 Then
intspace = intSpace2
Else
intspace = intSpace1
End If
strExhibits = strExhibits & vbCrLf & vbCrLf & intExhibits & "." & Space(intspace) & !Description & Space(82 - (Len(intExhibits) + intspace + Len(!Description) + Len(!ServiceDates))) & !ServiceDates
End If
.MoveNext
Loop
If Not IsNothing(strSQL2) Then rstRS2.Close
End With
'now witnesses 20141120
strSQL = "SELECT * FROM tblWitness Where WitnessFlag=True"
Set rstRS = dbsDB.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
strWitnesses = ""
strWitnesses = Me.ClientName & vbCrLf
With rstRS
Do Until .EOF
strWitnesses = strWitnesses & !WitnessName
strWitnesses = strWitnesses & vbCrLf
.MoveNext
Loop
.Close
End With
Set dbsDB = Nothing
DoEvents
Set Wrd = CreateObject("Word.Application")
strMergeDoc = Application.CurrentProject.path
strMergeDoc = strMergeDoc + "\Exhibits.dotx"
Wrd.Documents.Add strMergeDoc
With Wrd.ActiveDocument.Bookmarks
.Item("EXHIBITSLIST").Range.Text = strExhibits
.Item("WITNESSLIST").Range.Text = strWitnesses
.Item("CASENO").Range.Text = Me.txtClaimNo
.Item("CLIENTNAME").Range.Text = Me.ClientName
End With
'-----------------------------------------------------by Keith--------------------------------9/1/09
strDBPath = CurrentDb.Name
strDBFile = Dir(strDBPath)
dbdir = Left$(strDBPath, Len(strDBPath) - Len(strDBFile))
strFileTempWord = dbdir & "TempWordDoc.Doc"
DoEvents
If FileExists(strFileTempWord) Then Kill strFileTempWord
Wrd.ActiveDocument.SaveAs strFileTempWord '// transfer the template to a new temp file
strDirWord = "\\192.168.164.4\c$\WORDSERVER\EXHIBIT LIST - MASTERS\"
strFileWordName = "Exhibits " & Me.ClientName & " " & Me.txtClaimNo & ".pdf"
strFileWord = strDirWord & strFileWordName
'20141121----------------------------------------convert word to pdf-------------------------------------
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strFileWord, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
''--------------------------------------------------------------------------------------------------------
Wrd.Quit
Set Wrd = Nothing
strDirWord = "\\server2008\WORDSERVER\EXHIBIT LIST - MASTERS\"
strFileWordName = "Exhibits " & Me.ClientName & " " & Me.txtClaimNo & ".doc"
strFileWord = strDirWord & strFileWordName
If FileExists(strFileTempWord) Then Call CopyFile(strFileTempWord, strFileWord)
On Error GoTo 0
Exit Sub
cmdExhibits_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdExhibits_Click of VBA Document Form_frmExhibits"
End Sub
Posted by: drnorbert@msn.com
| Reply via web post | • | Reply to sender | • | Reply to group | • | Start a New Topic | • | Messages in this topic (12) |
Tidak ada komentar:
Posting Komentar