Henry Simpson
hsimpson88 at hotmail.com
Wed Mar 12 17:34:00 CST 2003
Here is some code that I've culled for finding bookmarks and writing field
data to them together with a few ancilliary functions. The additional is
for sorting queries and template names in the arrays prior to filling the
callbacks. I cannot include all the code here as it is very extensive and
I've culled some of the error handling. The code below is derived from a
demo that I gave to a client and relies on a naming convention in the
bookmark naming to match field data to bookmarks. If I were to include all
the code for parsing out repeated use of the same field and parsing dates
and other formatting, there would be a great deal more. One of the nice
things that is done in the sample, and there may be a function or two
missing, is that it checks the bookmarks and identifies any non matching
bookmarks that the user has created. Note also that this uses a hard coded
fixed query to get the fields that may be written. It is easily modified to
point to other saved queries with broader or narrower collections of fields.
First, the callback functions for the Doc template selection and Query
selection templates. If the user does not select a query, a document is
generated for the current Member record.
Dim mstrTable As String 'Table of Primary Record to which docs are
related, parsed from Opening Args
Dim mlngFileID As Long 'Long PK of record from which Doc form is
opened, parsed from Opening Args
Dim mstrPath As String 'Path to File Folder based on Table and PK
above and Path to BE
Dim marDocNames As Variant 'Callback data array for Templates combo.
Below path to Table
Dim mlngIDot As Long 'Count of above
Dim marQryNames As Variant 'Callback data array for Recipient Query
combo
Dim mlngIQry As Long 'Count of above
Private Sub GetTemplates()
'Fills array with all template docs in the table's template folder for the
template combo callback
Dim strFileName As String
Dim strFilePath As String
strFilePath = fnDbPath & mstrTable & "\Templates\"
strFileName = Dir(strFilePath & "*.Dot", vbDirectory)
ReDim marDocNames(0, 0)
Do While Len(strFileName)
If Not (strFileName = ".." Or strFileName = ".") Then
ReDim Preserve marDocNames(0, mlngIDot)
marDocNames(0, mlngIDot) = Left$(strFileName, Len(strFileName) -
4)
strFileName = Dir
mlngIDot = mlngIDot + 1
End If
Loop
qSort marDocNames, 0, False, 0
End Sub
Private Sub GetQuerys()
'Fills Array for combo query callback listing all queries in the database
Dim strPrefix As String
Dim db As DAO.Database
Dim qdf As QueryDef
Set db = CurrentDb
strPrefix = "" 'removed, ordinarily a passed in parameter
ReDim marQryNames(0, 0)
For Each qdf In db.QueryDefs
If Left$(qdf.Name, Len(strPrefix)) = strPrefix Then
ReDim Preserve marQryNames(0, mlngIQry)
marQryNames(0, mlngIQry) = qdf.Name
mlngIQry = mlngIQry + 1
End If
Next
qSort marQryNames, 0, False, 0
db.Close
Set db = Nothing
Set qdf = Nothing
End Sub
Function Dot(fld As Control, ID As Variant, Row As Long, Col As Long, Code
As Variant) As Variant
'Word template callback for cboDocType
Dim ReturnVal As Variant
ReturnVal = Null
Select Case Code
Case acLBInitialize
ReturnVal = mlngIDot
Case acLBOpen
ReturnVal = Timer
Case acLBGetRowCount
ReturnVal = mlngIDot
Case acLBGetColumnCount
ReturnVal = 1
Case acLBGetColumnWidth
ReturnVal = -1
Case acLBGetValue
ReturnVal = marDocNames(0, Row)
Case acLBGetFormat
Case acLBEnd
End Select
Dot = ReturnVal
End Function
Function Qry(fld As Control, ID As Variant, Row As Long, Col As Long, Code
As Variant) As Variant
'cboQuery filling function
Dim ReturnVal As Variant
ReturnVal = Null
Select Case Code
Case acLBInitialize
ReturnVal = mlngIQry
Case acLBOpen
ReturnVal = Timer
Case acLBGetRowCount
ReturnVal = mlngIQry
Case acLBGetColumnCount
ReturnVal = 1
Case acLBGetColumnWidth
ReturnVal = -1
Case acLBGetValue
ReturnVal = marQryNames(0, Row)
Case acLBGetFormat
Case acLBEnd
End Select
Qry = ReturnVal
End Function
Private Sub cmdNewDoc_Click()
Dim r As DAO.Recordset
Dim r2 As DAO.Recordset
Dim owdApp As Word.Application
Dim owdDoc As Word.Document
Dim strTemplate As String
Dim owdBkm As Word.Bookmark
Dim strFld As String
Dim strFileName As String
Dim lngTemp As Long
Dim strFormat As String
Dim strWrite As String
Dim blnBkmChecked As Boolean
If Len(Me.cboQuery) Then
Set r2 = CurrentDb.OpenRecordset(Me.cboQuery)
If Not r2.EOF Then
Do Until r2.EOF
Set r = CurrentDb.OpenRecordset("SELECT tblMember.*, Locale,
Province, MemberType " & _
"FROM (tblProvince RIGHT JOIN (tblLocale RIGHT JOIN
tblMember ON tblLocale." & _
"LocaleID = tblMember.LocaleID) ON tblProvince.ProvinceID
= tblLocale.ProvinceID) " & _
"INNER JOIN tblMemberType ON tblMember.MemberTypeID =
tblMemberType.MemberTypeID " & _
"WHERE ContactID = " & r2!ContactID)
strTemplate = fnDbPath & mstrTable & "\Templates\" &
Me.cboDocType & ".dot"
If fnWordTemplate(owdApp, owdDoc, strTemplate) Then
With owdDoc
On Error Resume Next
If blnBkmChecked = False Then
fnCheckBookMarks r, owdDoc
blnBkmChecked = True
End If
For Each owdBkm In owdDoc.Bookmarks
If InStr(owdBkm.Name, "__") Then
lngTemp = InStr(owdBkm.Name, "__") + 2
strFormat = Mid$(owdBkm.Name, lngTemp)
strFld = Left(owdBkm.Name,
InStr(owdBkm.Name, "_") - 1)
strWrite = Format$(r(strFld), strFormat)
ElseIf InStr(owdBkm.Name, "_") Then
strFld = Left(owdBkm.Name,
InStr(owdBkm.Name, "_") - 1)
strWrite = r(strFld)
Else
strFld = owdBkm.Name
strWrite = r(strFld)
End If
owdBkm.Select
owdApp.Selection = strWrite
Next
End With
If Me.chkMemberFolder = True Then
strFileName = fnFileSuffix(fnDbPath & mstrTable &
"\" & r2!ContactID & "\" & fnFileNameOK(Me.cboDocType)) & "doc"
fnFolders mstrTable & "\" & r2!ContactID & "\"
owdDoc.SaveAs strFileName
If Len(Dir(strFileName)) = 0 Then
MsgBox "File Save Error. Can't save " &
strFileName
End If
End If
If Me.chkGroupFolder = True Then
fnFolders mstrTable & "\" & Me.cboQuery & "\"
strFileName = fnFileSuffix(fnDbPath & mstrTable &
"\" & Me.cboQuery & "\" & fnFileNameOK(r!FirstName & " " & r!LastName & "-"
& Me.cboDocType)) & "doc"
owdDoc.SaveAs strFileName
If Len(Dir(strFileName)) = 0 Then
MsgBox "File Save Error. Can't save " &
strFileName
End If
End If
If Me.chkPrint = True Then
owdDoc.PrintOut
End If
If Me.chkOpenDocs = False Then
owdDoc.Close SaveChanges:=wdDoNotSaveChanges
End If
strFileName = fnFileSuffix(fnDbPath & mstrTable & "\" &
r!FirstName & " " & r!LastName & "-" & fnFileNameOK(Me.cboDocType)) & "doc"
owdDoc.SaveAs strFileName
If Len(Dir(strFileName)) = 0 Then
MsgBox "File Save Error. Can't save " & strFileName
End If
End If
owdApp.Visible = True
r2.MoveNext
Loop
End If
Else
Set r = CurrentDb.OpenRecordset("SELECT tblMember.*, Locale,
Province, MemberType " & _
"FROM (tblProvince RIGHT JOIN (tblLocale RIGHT JOIN tblMember ON
tblLocale." & _
"LocaleID = tblMember.LocaleID) ON tblProvince.ProvinceID =
tblLocale.ProvinceID) " & _
"INNER JOIN tblMemberType ON tblMember.MemberTypeID =
tblMemberType.MemberTypeID " & _
"WHERE ContactID = " & mlngFileID)
strTemplate = fnDbPath & mstrTable & "\Templates\" & Me.cboDocType &
".dot"
If fnWordTemplate(owdApp, owdDoc, strTemplate) Then
With owdDoc
On Error Resume Next
fnCheckBookMarks r, owdDoc
For Each owdBkm In owdDoc.Bookmarks
If InStr(owdBkm.Name, "__") Then
lngTemp = InStr(owdBkm.Name, "__") + 2
strFormat = Mid$(owdBkm.Name, lngTemp)
strFld = Left(owdBkm.Name, InStr(owdBkm.Name, "_") -
1)
strWrite = Format$(r(strFld), strFormat)
ElseIf InStr(owdBkm.Name, "_") Then
strFld = Left(owdBkm.Name, InStr(owdBkm.Name, "_") -
1)
strWrite = r(strFld)
Else
strFld = owdBkm.Name
strWrite = r(strFld)
End If
owdBkm.Select
owdApp.Selection = strWrite
Next
End With
If Me.chkMemberFolder = True Then
strFileName = fnFileSuffix(mstrPath &
fnFileNameOK(Me.cboDocType)) & "doc"
owdDoc.SaveAs strFileName
If Len(Dir(strFileName)) = 0 Then
MsgBox "File Save Error. Can't save " & strFileName
Else
Me.sfrmDocumentList.Form.AddToArray Mid$(strFileName,
Len(mstrPath) + 1), FileLen(strFileName), "fax*"
End If
End If
If Me.chkPrint = True Then
owdDoc.PrintOut
End If
If Me.chkOpenDocs = False Then
owdDoc.Close SaveChanges:=wdDoNotSaveChanges
End If
End If
owdApp.Visible = True
End If
On Error Resume Next
r.Close
Set r = Nothing
r2.Close
Set r2 = Nothing
Set owdDoc = Nothing
Set owdApp = Nothing
End Sub
This code above is in a form with some of the check boxes I mentioned. It
has combos that are filled by callback for templates in a location beneath
the path to the table container file and a combo filled with queries with a
prefixed naming convention. I culled out the prefix code.
Function fnDbPath() As String
Dim lngPos As Long
Dim lngPosStrt As Long
Dim lngPosExit As Long
Dim strFile As String
strFile = CurrentDb.Name
lngPosStrt = 2
Do Until lngPosStrt = 1
lngPos = InStr(lngPosStrt, strFile, "\")
lngPosStrt = lngPos + 1
If lngPosStrt <> 1 Then lngPosExit = lngPosStrt - 1
Loop
fnDbPath = Left$(strFile, lngPosExit)
End Function
Public Function fnWordTemplate(owdApp As Word.Application, owdDoc As
Word.Document, strTemplate As String, Optional blnClose As Boolean = False)
As Boolean
Dim lngCount As Long
If Len(Dir(strTemplate)) Then
fnReturnWord owdApp, blnClose
lngCount = owdApp.Documents.Count
Set owdDoc = owdApp.Documents.Add(Template:=strTemplate,
newtemplate:=False)
If owdApp.Documents.Count = lngCount + 1 Then
fnWordTemplate = True
Else
MsgBox "Unable to create new document"
End If
Else
MsgBox "The template file: " & strTemplate & _
" was not found. Unable to create document."
Exit Function
End If
End Function
Public Function fnCheckBookMarks(r As DAO.Recordset, owdDoc As
Word.Document)
Dim owdBkm As Word.Bookmark
Dim strBkm() As String
Dim lngI As Long
Dim lngJ As Long
Dim blnFound As Boolean
ReDim strBkm(1, owdDoc.Bookmarks.Count - 1)
For Each owdBkm In owdDoc.Bookmarks
strBkm(0, lngI) = owdBkm.Name
If InStr(owdBkm.Name, "__") Then
strBkm(1, lngI) = Left(owdBkm.Name, InStr(owdBkm.Name, "_") - 1)
ElseIf InStr(owdBkm.Name, "_") Then
strBkm(1, lngI) = Left(owdBkm.Name, InStr(owdBkm.Name, "_") - 1)
Else
strBkm(1, lngI) = owdBkm.Name
End If
lngI = lngI + 1
Next
For lngI = 0 To owdDoc.Bookmarks.Count - 1
For lngJ = 0 To r.Fields.Count - 1
If strBkm(1, lngI) = r(lngJ).Name Then
blnFound = True
Exit For
Debug.Print lngI & " = " & lngJ
End If
Next
If blnFound = False Then
MsgBox strBkm(1, lngI) & " was not found in the recordset but is
a bookmark in " & _
"the Template." & vbCrLf & vbCrLf & "This bookmark cannot be
filled from the " & _
"recordset. It will require a query that returns a field with
that name."
End If
blnFound = False
Next
End Function
Function fnFixFileName(ByVal strIn As String, strMapIn As String, ByVal
strMapOut As String) As String
Dim IntI As Integer
Dim intPos As Integer
Dim strChar As String * 1
Dim strout As String
If Len(strMapIn) > 0 Then
If Len(strMapOut) > 0 Then
strMapOut = Left$(strMapOut & String(Len(strMapIn),
Right$(strMapOut, 1)), Len(strMapIn))
End If
For IntI = 1 To Len(strIn)
strChar = Mid$(strIn, IntI, 1)
intPos = InStr(1, strMapIn, strChar)
If intPos > 0 Then
strout = strout & Mid$(strMapOut, intPos, 1)
Else
strout = strout & strChar
End If
Next IntI
End If
fnFixFileName = strout
End Function
Function fnFileNameOK(strIn As String) As String
Dim strout As String
strout = fnFixFileName(strIn, "/\?*" & Chr$(34), "-")
fnFileNameOK = fnFixFileName(strout, ".", "")
End Function
Sub qSort(varAr As Variant, fld As Long, Asc As Boolean, NumberCol As Long,
Optional lngL As _
Long = -2, Optional lngR As Long = -2)
Dim lngI As Long
Dim lngK As Long
Dim lngJ As Long
Dim varMid As Variant
If lngL = -2 Then lngL = LBound(varAr, 2)
If lngR = -2 Then lngR = UBound(varAr, 2)
If lngL < lngR Then
lngJ = (lngL + lngR) \ 2
varMid = varAr(fld, lngJ)
lngI = lngL
lngK = lngR
If Asc Then
Do
Do While varAr(fld, lngI) > varMid
lngI = lngI + 1
Loop
Do While varAr(fld, lngK) < varMid
lngK = lngK - 1
Loop
If lngI <= lngK Then
Swap varAr, lngI, lngK, NumberCol
lngI = lngI + 1
lngK = lngK - 1
End If
Loop Until lngI > lngK
Else
Do
Do While varAr(fld, lngI) < varMid
lngI = lngI + 1
Loop
Do While varAr(fld, lngK) > varMid
lngK = lngK - 1
Loop
If lngI <= lngK Then
Swap varAr, lngI, lngK, NumberCol
lngI = lngI + 1
lngK = lngK - 1
End If
Loop Until lngI > lngK
End If
If lngK <= lngJ Then
qSort varAr, fld, Asc, NumberCol, lngL, lngK
qSort varAr, fld, Asc, NumberCol, lngI, lngR
Else
qSort varAr, fld, Asc, NumberCol, lngI, lngR
qSort varAr, fld, Asc, NumberCol, lngL, lngK
End If
End If
End Sub
Private Sub Swap(varArr As Variant, lng1 As Long, lng2 As Long, NumCol As
Long)
Dim varTemp As Variant
Dim lngN As Long
For lngN = 0 To NumCol
varTemp = varArr(lngN, lng2)
varArr(lngN, lng2) = varArr(lngN, lng1)
varArr(lngN, lng1) = varTemp
Next
End Sub
Hen
>From: "Klos, Susan" <Susan.Klos at fldoe.org>
>Reply-To: accessd at databaseadvisors.com
>To: "'accessd at databaseadvisors.com'" <accessd at databaseadvisors.com>
>Subject: RE: [AccessD] Word Automation
>Date: Wed, 12 Mar 2003 08:12:23 -0500
>
>Henry, I would like to learn more about how you do this.
_________________________________________________________________
MSN 8 helps eliminate e-mail viruses. Get 2 months FREE*.
http://join.msn.com/?page=features/virus