By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
432,247 Members | 871 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 432,247 IT Pros & Developers. It's quick & easy.

Access table OutPutTo Word bookmark

P: n/a
Gday,

I have a set of Access 2000 tables that I would like to export into a
MS Word 2000 template at specific bookmark locations that I've set up.

Would anyone know the code to achieve something like this? I've heard
about using the OutPutTo method, but I'm not sure if it can output to a
specific bookmark location.

Any thoughts?

Thanks,
Keith

Jan 12 '06 #1
Share this Question
Share on Google+
2 Replies


P: n/a
On 12 Jan 2006 00:23:29 -0800, fo******@gmail.com wrote:
Gday,

I have a set of Access 2000 tables that I would like to export into a
MS Word 2000 template at specific bookmark locations that I've set up.

Would anyone know the code to achieve something like this? I've heard
about using the OutPutTo method, but I'm not sure if it can output to a
specific bookmark location.

I have just made it, using automatation. Following sub opens a new word
document file, based on template with the appropiate bookmarks and other
fixed stuf.

<vba_code>

Enum wordCommand
gotoBMIns
indent
indentBack
gotoBM
ins
insFootNote
End Enum

'1 arg: array of word commands and their content
'2 arg: destination file for new word document
'3 arg: template source
Public Function MergetoWord(mergeContent, _
Optional destFile$ =
"C:\usr\benny\work\jobs\kontakt\Systemmatiseret\an s.doc", _
Optional Skabelon$ = "E:\Program Files\Microsoft
Office\Skabeloner\jobans.dot")
' This method creates a new document in MS Word 97 using Automation.
On Error Resume Next
Dim rsCust As Recordset, cI%, cBound%, indent As New Stack
Dim WordObj As Word.Application

indent.push 0
DoCmd.Hourglass True

Set WordObj = GetObject(, "Word.Application.8")
If err.Number <> 0 Then
Set WordObj = CreateObject("Word.Application.8")
End If

WordObj.Visible = True

WordObj.Documents.Add Template:=Skabelon, NewTemplate:=False

cBound = UBound(mergeContent)
cI = 0
Do
Select Case mergeContent(cI)
Case wordCommand.gotoBMIns:
WordObj.Selection.Goto What:=wdGoToBookmark,
Name:=mergeContent(cI + 1)
WordObj.Selection.TypeText mergeContent(cI + 2)
cI = cI + 3
Case wordCommand.indent
indent.push mergeContent(cI + 1)
WordObj.Selection.ParagraphFormat.LeftIndent =
WordObj.CentimetersToPoints(indent.pop)
cI = cI + 2
Case wordCommand.indentBack
indent.pop
WordObj.Selection.ParagraphFormat.LeftIndent =
WordObj.CentimetersToPoints(indent.pop)
cI = cI + 1
Case wordCommand.gotoBM
WordObj.Selection.Goto What:=wdGoToBookmark,
Name:=mergeContent(cI + 1)
cI = cI + 2
Case wordCommand.ins
WordObj.Selection.TypeText mergeContent(cI + 1)
cI = cI + 2
Case wordCommand.insFootNote
With WordObj.ActiveDocument.Bookmarks
.Add Range:=WordObj.Selection.Range, Name:="fodn"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
WordObj.ActiveDocument.Footnotes.Add
Range:=WordObj.Selection.Range, Reference:=""
WordObj.Selection.TypeText mergeContent(cI + 1)
WordObj.Selection.Goto What:=wdGoToBookmark, Name:="fodn"
WordObj.Selection.MoveRight Unit:=wdCharacter, Count:=1
cI = cI + 2
Case Else:
'nothing
End Select
Loop Until cI > cBound

WordObj.ActiveDocument.SaveAs fileName:=destFile, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
DoEvents
WordObj.Activate

Set WordObj = Nothing

DoCmd.Hourglass False

Exit Function

TemplateError:
WordObj.Quit
Set WordObj = Nothing
Exit Function

End Function
</vba_code>

The array: Mergecontent is made by retrive table content using vba. This is
specific to my use and i won't explain the table content part. I use a
function showByAnsId(ansId%) to make Mergecontent, and the way i use it (in
a form click buttom event) is:


<vba_code>

Private Sub CWord_Click()
Dim arr
On Error Resume Next
arr = showByAnsId(Ans!id)
If oneBeyondUBound(arr) Then
MergetoWord arr
End If
End Sub
</vba_code>


Just to illustate is here the funstion.

<vba_code>
Function showByAnsId(ansId%)
Dim rs As Recordset, bmArr(), fa$, content$, headline$
Set rs = CurrentDb.OpenRecordset( _
"SELECT " & _
"Firma.navn, Firma.adresse, Kontakt.kontaktperson, Ans.headline, "
& _
"par.abr, Par.content, Ans.id, parliste.id AS parid " & _
"FROM " & _
"firma, Jobopslag, Ans, Parliste, Par, Kontakt " & _
"WHERE " & _
"Firma.ID=Jobopslag.firma and " & _
"Jobopslag.ID=Ans.jobOpslId and " & _
"Parliste.ansId=Ans.id and " & _
"Par.id=Parliste.parId and " & _
"Kontakt.ansId=Ans.id and " & _
"Ans.id=" & ansId & _
" order by parliste.id" _
)
If Not rs.EOF Then
fa = rs![adresse]
headline = rs![headline]
add2BookMarkList bmArr, _
wordCommand.gotoBMIns, "firma", rs![navn], _
wordCommand.gotoBMIns, "att", rs![kontaktperson], _
wordCommand.gotoBMIns, "FirmaAdrL1", Trim$(Split(fa,
",")(0)), _
wordCommand.gotoBMIns, "FirmaAdrL2", Trim$(Split(fa,
",")(1)), _
wordCommand.gotoBMIns, "headline", rs![headline], _
wordCommand.gotoBMIns, "dato", Format(Date, "d") & ". " &
MonthName(Month(Date))
End If

Dim spaceDelim$
While Not rs.EOF
If (Right$(content, 1) = ">") Or (Left$(rs![content], 1) = "<") Or
_
Len(content) = 0 Then
spaceDelim = ""
Else
spaceDelim = " ": End If
content = content & spaceDelim & rs![content]
rs.MoveNext
Wend

Dim angelBBeg%, attVal%, tag As Collection

If Len(content) Then
add2BookMarkList bmArr, wordCommand.gotoBM, "content"
Set tag = firstTag(content)
While tag.item(hasTagsKey)
angelBBeg = tag.item("<")
If angelBBeg > 1 Then
add2BookMarkList bmArr, wordCommand.ins, Left$(content,
angelBBeg - 1): End If
Select Case tag.item(tagKey)
Case "br", "br/", "/br"
add2BookMarkList bmArr, wordCommand.ins, vbCrLf
Case "indent"
attVal = valOrNull(tag, "length")
If Not IsNull(attVal) Then
add2BookMarkList bmArr, wordCommand.indent, attVal:
End If
Case "/indent"
add2BookMarkList bmArr, wordCommand.indentBack
Case "mailId/"
add2BookMarkList bmArr, wordCommand.insFootNote, _
"From:Be************@it.dk, subj:'" & headline &
"',dato:" & Left$(Now, 16)
Case Else
'nothing
End Select
content = Right$(content, Len(content) - tag.item(">"))
Set tag = Nothing
Set tag = firstTag(content)
Wend
If Len(content) Then
add2BookMarkList bmArr, wordCommand.ins, content: End If: End
If
rs.Close
Set rs = Nothing
showByAnsId = bmArr
End Function
</vba_code>


Preceding vba code has some dependency. The following is what catches my
eyes, but just ask again if you are interested and i have missed something.


<vba_code>
Const tagKey$ = "tag"
Const hasTagsKey$ = "hasTags"

Sub add2BookMarkList(bmArr, ParamArray bMContentPairs())
Dim i%
For i = 0 To UBound(bMContentPairs)
add2list bmArr, bMContentPairs(i)
Next
End Sub

Sub add2list(V, i)
On Error GoTo Err
ReDim Preserve V(UBound(V) + 1)
V(UBound(V)) = i
Exit Sub
Err:
ReDim V(0)
Resume Next
End Sub

Function oneBeyondUBound&(Var)
On Error Resume Next
oneBeyondUBound = 1 + UBound(Var)
End Function

Function firstTag(str$) As Collection
Dim tBegP%, tEndp%, inBracket$
Dim attPairs, tagContenSpcDelItem, maxCI%, tagCI%
Set firstTag = New Collection
tBegP = InStr(str, "<")
If tBegP Then
firstTag.Add -1, hasTagsKey
tEndp = InStr(tBegP, str, ">")
If tEndp > tBegP + 1 Then
inBracket = Replace(Trim(Mid(str, tBegP + 1, tEndp - tBegP -
1)), " ", " ")
tagContenSpcDelItem = Split(inBracket, " ")
maxCI = UBound(tagContenSpcDelItem)
If maxCI > -1 Then
firstTag.Add tagContenSpcDelItem(0), tagKey
If maxCI > 0 Then
For tagCI = 1 To maxCI
attPairs =
Split(Replace(Replace(tagContenSpcDelItem(tagCI), """", ""), "'", ""), "=")
If UBound(attPairs) = 0 Then
firstTag.Add 0, attPairs(0)
Else
firstTag.Add attPairs(1), attPairs(0): End If:
Next: End If: End If: End If
firstTag.Add tBegP, "<"
If tEndp > tBegP Then
firstTag.Add tEndp, ">": End If
Else
firstTag.Add 0, hasTagsKey: End If
End Function
</vba_code>

And finaly, my references includes 'Microsoft word 8.0 object libary' and i
use access2000 and word97

--
Regards
Benny Andersen
Jan 12 '06 #2

P: n/a
<fo******@gmail.com> wrote:
I have a set of Access 2000 tables that I would like to export into a
MS Word 2000 template at specific bookmark locations that I've set up.

Would anyone know the code to achieve something like this? I've heard
about using the OutPutTo method, but I'm not sure if it can output to a
specific bookmark location.


The following will do what you want, I think, however, It is not nearly as
efficient nor as elegant as Albert Kallal's method here:

http://www.members.shaw.ca/AlbertKal.../msaccess.html
--------------------------
Dim mWord As Object
Dim cnxn As ADODB.Connection
Dim rL As ADODB.Recordset
Set cnxn = CurrentProject.Connection
Set rL = New ADODB.Recordset
Set mWord = CreateObject("Word.Application")
mWord.Documents.Add "C:\odis\odis_PPS_100_CaseClosing.dot"
With mWord.ActiveDocument
.Bookmarks("off_name").Range.Fields(1).Result.Text =
GetOffenderName()
rL.Open "current_sup", cnxn, adOpenForwardOnly, adLockReadOnly,
adCmdTableDirect
If Not rL.EOF Then
..Bookmarks("cs_open_date").Range.Fields(1).Result .Text =
rL.Fields("cs_open_date")
rL.Close
.Bookmarks("sup_adjustment").Range.Fields(1).Resul t.Text =
Nz(Forms("SupervisionForm")!memAdjustment, "")
.Bookmarks("Today").Range.Fields(1).Result.Text = Date
End With
mWord.Visible = True
Set mWord = Nothing
-----------------------

--
Darryl Kerkeslager
Jan 12 '06 #3

This discussion thread is closed

Replies have been disabled for this discussion.