Access Archon #174
The code that does the work of listing, clearing and copying doc properties is listed below.
VBA Code
Private Sub cmdCopy_Click()
On Error GoTo ErrorHandler
Dim cbo As Access.ComboBox
Dim intType As Integer
Set cbo = Me![cboSelectTableOrQuery]
strTemplate = Nz(Me![txtTemplate].Value)
strRecordSource = Nz(cbo.Column(0))
intType = Nz(cbo.Column(1))
If strTemplate <> “” Then
strTitle = “Question”
strPrompt = “Strip old doc properties first?”
intReturn = MsgBox(prompt:=strPrompt, _
buttons:=vbQuestion + vbYesNoCancel, _
Title:=strTitle)
If intReturn = vbYes Then
Call StripDocProps(strTemplate)
ElseIf intReturn = vbCancel Then
GoTo ErrorHandlerExit
End If
Call CopyDocProps(strTemplate, strRecordSource, intType)
End If
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox “Error No: ” & Err.Number _
& “; Description: ” & Err.Description
Resume ErrorHandlerExit
End Sub
Private Sub cmdList_Click()
On Error GoTo ErrorHandler
strTemplate = Nz(Me![txtTemplate].Value)
Debug.Print “Selected template: ” & strTemplate
If strTemplate <> “” Then
Call ListDocProps(strTemplate)
End If
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox “Error No: ” & Err.Number _
& “; Description: ” & Err.Description
Resume ErrorHandlerExit
End Sub
Private Sub cmdSelectTemplate_Click()
‘Requires a reference to the Microsoft Office Object Library
On Error GoTo ErrorHandler
Dim fd As Office.FileDialog
Dim varSelectedItem As Variant
Dim txt As Access.TextBox
Dim strTemplatesPath As String
‘Get User Templates path from Word Options dialog
Set appWord = GetObject(, “Word.Application”)
strTemplatesPath = _
appWord.Options.DefaultFilePath(wdUserTemplatesPath) & “”
Debug.Print “Templates folder: ” & strTemplatesPath
‘Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set txt = Me![txtTemplate]
With fd
.AllowMultiSelect = False
.Title = “Browse for Word Template”
.ButtonName = “Select”
.Filters.Clear
.Filters.Add “Documents”, “*.dot; *.dotx; *.dotm”, 1
.InitialView = msoFileDialogViewDetails
.InitialFileName = strTemplatesPath
If .Show = -1 Then
‘Get selected item in the FileDialogSelectedItems collection
‘Have to use collection even if just one item is selected
For Each varSelectedItem In .SelectedItems
txt.Value = CStr(varSelectedItem)
Me![cmdList].Enabled = True
Next varSelectedItem
Else
Debug.Print “User pressed Cancel”
Me![cmdList].Enabled = False
End If
End With
ErrorHandlerExit:
Set fd = Nothing
Exit Sub
ErrorHandler:
If Err = 429 Then
‘Word is not running; open Word with CreateObject
Set appWord = CreateObject(“Word.Application”)
Resume Next
Else
MsgBox “Error No: ” & Err.Number & “; Description: ” _
& Err.Description
Resume ErrorHandlerExit
End If
End Sub
Private Sub CopyDocProps(strTemplate As String, _
strRecordSource As String, intType As Integer)
On Error GoTo ErrorHandler
Set dbs = CurrentDb
If intType = 1 Then
Set tdf = dbs.TableDefs(strRecordSource)
ElseIf intType = 5 Then
Set qdf = dbs.QueryDefs(strRecordSource)
End If
Set appWord = GetObject(, “Word.Application”)
Set docTarget = appWord.Documents.Add(Template:=strTemplate)
Set dps = docTarget.AttachedTemplate.CustomDocumentProperties
appWord.Visible = True
If intType = 1 Then
‘Iterate through table fields and create doc properties
For Each fld In tdf.Fields
strPropName = fld.Name
Debug.Print “Field name: ” & strPropName
Debug.Print “Field data type: ” & fld.Type
If fld.Type = dbBoolean Then
dps.Add Name:=strPropName, LinkToContent:=False, _
Type:=msoPropertyTypeBoolean, Value:=””
Else
On Error Resume Next
dps.Add Name:=strPropName, LinkToContent:=False, _
Type:=msoPropertyTypeString, Value:=””
End If
Next fld
ElseIf intType = 5 Then
If qdf.Fields.Count = 0 Then
strTitle = “No fields”
strPrompt = “This query has no usable fields (it is ” _
& “probably an action query)”
MsgBox prompt:=strPrompt, _
buttons:=vbExclamation + vbOKOnly, _
Title:=strTitle
docTarget.Close savechanges:=False
GoTo ErrorHandlerExit
End If
For Each fld In qdf.Fields
‘Iterate through query fields and create doc properties
strPropName = fld.Name
Debug.Print “Field name: ” & strPropName
Debug.Print “Field data type: ” & fld.Type
If fld.Type = dbBoolean Then
dps.Add Name:=strPropName, LinkToContent:=False, _
Type:=msoPropertyTypeBoolean, Value:=””
Else
On Error Resume Next
dps.Add Name:=strPropName, LinkToContent:=False, _
Type:=msoPropertyTypeString, Value:=””
End If
Next fld
End If
On Error GoTo ErrorHandler
‘Make a dummy change so doc props will be saved
With appWord.Selection
.EndKey Unit:=wdStory
.TypeText Text:=”Dummy text”
.HomeKey Unit:=wdLine, Extend:=wdExtend
.Delete Unit:=wdCharacter, Count:=1
End With
docTarget.AttachedTemplate.Save
docTarget.Close savechanges:=False
strTitle = “Finished!”
strPrompt = “All doc properties from ” & strRecordSource _
& ” copied to ” & strTemplate
MsgBox prompt:=strPrompt, _
buttons:=vbInformation + vbOKOnly, _
Title:=strTitle
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err = 429 Then
‘Word is not running; open Word with CreateObject
Set appWord = CreateObject(“Word.Application”)
Resume Next
Else
MsgBox “Error No: ” & Err.Number & “; Description: ” _
& Err.Description
Resume ErrorHandlerExit
End If
End Sub
Private Sub ListDocProps(strTemplate As String)
On Error GoTo ErrorHandler
Set appWord = GetObject(, “Word.Application”)
strTemplate = Nz(Me![txtTemplate].Value)
Set docTarget = appWord.Documents.Add(Template:=strTemplate)
Set dps = docTarget.AttachedTemplate.CustomDocumentProperties
appWord.Visible = True
With appWord.Selection
.WholeStory
.Delete Unit:=wdCharacter, Count:=1
.Font.Name = “Arial”
.Font.Size = 12
.Font.Bold = True
.TypeText “Document properties in ” & strTemplate
.EndKey Unit:=wdLine
.TypeParagraph
.TypeParagraph
appWord.ActiveDocument.Tables.Add _
Range:=appWord.Selection.Range, _
NumRows:=2, NumColumns:=1, _
DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=wdAutoFitFixed
With appWord.Selection.Tables(1)
.Style = “Table Grid”
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
End With
appWord.ActiveDocument.Tables(1).Select
With appWord.Selection
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Font.Name = “Arial”
.Font.Size = 10
.Font.Bold = False
End With
appWord.Selection.MoveLeft Unit:=wdCharacter, Count:=1
End With
If dps.Count > 0 Then
For Each dp In dps
With appWord.Selection
.TypeText dp.Name
.MoveRight Unit:=wdCell
End With
Next dp
‘Delete last, blank row
With appWord.Selection
.SelectRow
.Rows.Delete
End With
Else
appWord.Selection.TypeText _
“There are no doc properties in this template”
End If
appWord.ActiveDocument.Tables(1).Select
appWord.Selection.Sort ExcludeHeader:=False, _
FieldNumber:=”Column 1″, _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
appWord.Activate
appWord.Selection.HomeKey Unit:=wdStory
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err = 429 Then
‘Word is not running; open Word with CreateObject
Set appWord = CreateObject(“Word.Application”)
Resume Next
Else
MsgBox “Error No: ” & Err.Number & “; Description: ” _
& Err.Description
Resume ErrorHandlerExit
End If
End Sub
Private Sub StripDocProps(strTemplate As String)
On Error GoTo ErrorHandler
Set appWord = GetObject(, “Word.Application”)
strTemplate = Nz(Me![txtTemplate].Value)
Set docTarget = appWord.Documents.Add(Template:=strTemplate)
Set dps = docTarget.AttachedTemplate.CustomDocumentProperties
appWord.Visible = True
For Each dp In dps
Debug.Print “Deleting ” & dp.Name
dp.Delete
Next dp
‘Make a dummy change so changes will be saved
With appWord.Selection
.EndKey Unit:=wdStory
.TypeText Text:=”Dummy text”
.HomeKey Unit:=wdLine, Extend:=wdExtend
.Delete Unit:=wdCharacter, Count:=1
End With
docTarget.AttachedTemplate.Save
docTarget.Close savechanges:=False
ErrorHandlerExit:
Set appWord = Nothing
Exit Sub
ErrorHandler:
If Err = 429 Then
‘Word is not running; open Word with CreateObject
Set appWord = CreateObject(“Word.Application”)
Resume Next
Else
MsgBox “Error No: ” & Err.Number & “; Description: ” _
& Err.Description
Resume ErrorHandlerExit
End If
End Sub
Notes
If you select an action query, you will get a message that there are no usable fields (a few make-table queries are included in the database, for testing). This is because only select queries have usable fields. If you need to use data in an action query, run the action query, and then use the table it created (or modified) for creating the doc properties. The tables in the sample database with the “tmak” prefix were created by running make-table queries.
Since Word doc properties can’t contain spaces, make sure that the Access fields also contain no spaces. If necessary, you can create a query that aliases field names with new names that don’t contain spaces, to prevent problems when creating doc properties.
References
The code in the sample database needs the following references (in addition to the default references):
Microsoft DAO 3.6 Object Library
Microsoft Word 11.0 Object Library
Microsoft Office 11.0 Object Library
If you import code or objects into a database of your own, you may need to set one or more of these references. The version number may differ, depending on your Office version; check the version you have. References are set in the References dialog, opened from the VBA window. For more information on working with references, see Access Archon #107, Working with References.
Supporting Files
The zip file containing this article, in Word 97-2003 format, plus the supporting file(s), may be downloaded from the Access Archon page of my Web site, as accarch174.zip, which is the last entry in the table of Access Archon columns for Access Watch.
|
Document Name |
Document Type |
Place in |
|
Doc Props (AA 174).mdb |
Access 2002-2003 database |
Wherever you want |
|
Doc Props (AA 174).accdb |
Access 2007 database |
Wherever you want |
|
White Paper — Adding Custom Doc Properties to a Word Template.doc |
Word 97-2003 document |
Wherever you want |
