[AccessD] Word Automation

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




More information about the AccessD mailing list