Access to Word

P

pinkis4girls

New member
Local time
Today, 15:09
Joined
Mar 24, 2007
Messages
9
From Form to Word template - Help with code please

Hi,

This is my First post - so please be kind. I'm quite new at coding things and have learnt almost every thing from this forum so far by search old posts but can't find the answer to the below. I know how frustrating it must be to answer the same question over and over again so if this has been answered before please accept my appologies and if you could direct me to the old post I'll pick it up from there.

I have managed to get my DB to output to Excel using the below code:

Set Xl = CreateObject("Excel.Application")
Xl.Visible = True
Xl.Workbooks.Open ("C:\TEMP\PACL\PACL - Blank") ',,True

Xl.range("C8").Value = [Text78]
Xl.range("C9").Value = [tender name]
Xl.range("C10").Value = [Request Number]
Xl.range("F10").Value = [Accepted offer]
Xl.range("C14").Value = [Site Status]
Xl.range("C16").Value = [Accepted offer SPO]
Xl.range("C17").Value = [Type]
Xl.range("C19").Value = [Mpan]
Xl.range("C20").Value = [HH MOP]
Xl.range("C32").Value = [Payment Terms]
Xl.range("C13").Value = [No of sites]
Xl.range("C4").Value = [Text173]
Xl.range("A47").Value = [Additional comments]

I now need to do the same for word;

I have managed:

Dim oApp As Object

Set oApp = CreateObject("Word.Application")
oApp.Visible = True
oApp.Documents.Open ("C:\TEMP\Quatation") ',,True

but I have no idea how to get the info held in field [tender name] in my database into the Ln 5, col 10 in my word document.

I hope this makes sense, any help will be greatly received as I am very new at this and very eager to learn.
 
Last edited:
One way is to set up bookmarks.

here is an example

' Go to the bookmark named "Tel"
Set WordRange = WordDoc.Goto(What:=wdGoToBookmark, Name:="Tel")
WordRange.InsertAfter "9999 999-999 Ext 999"
 
Thank you - I've looked into Bookmarks but this doesn't really seam the way to go for me as the Word template I have to use will not allow this.

I'll have to keep working at it. Thank you for your help.

If it's not possible I'll just have to move it into an Excel template or an Email instead.
 
I won't go into the details here (way too much and a few things you don't need to know), but if you have insurance, you have a provider directory (the phonebook like thing you use to find a doctor), and you happen to have a certain huge insurance carrier as your insurance company, this might just be the code I wrote that makes the bulk of those directories.

(NOTE: I know, it's a lot of code and not a lot will make sense without knowing what the variables are. The idea is that you see how to write to Word and interact with it through various properties and methods, not necessarily follow my code.)

Code: 
Option Compare Database
Option Explicit

Global WordApp As Word.Application
Global WordDoc As Word.Document
Global CurEntry As Integer
Global TtlEntries As Integer
Global CurDirectory As Integer
Global TtlDirectories As Integer
Global CurMarket As Byte
Global CurMeasure As Byte

Sub ConnectToWord()

    Set WordApp = New Word.Application
    WordApp.DisplayAlerts = wdAlertsNone

End Sub

Sub CreateWordDoc()

    Set WordDoc = WordApp.Documents.Add
    WordDoc.ActiveWindow.View = wdPrintView
    
End Sub

Sub SetWordVisible()

    If DLookup("MakeWordVisible", "t_System_ExportOptions") Then
        WordApp.Visible = True
    End If

End Sub

Sub CreateWordHeader(txtHeader As String)

    With WordApp
        WordDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        .Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Selection.Font.Size = 12
        .Selection.TypeText Text:=txtHeader
        'Draw double line across bottom of header
        .Selection.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleThinThickSmallGap
        .Selection.ParagraphFormat.Borders(wdBorderBottom).LineWidth = wdLineWidth150pt
        .Selection.ParagraphFormat.Borders(wdBorderBottom).Color = wdColorAutomatic
        .Selection.ParagraphFormat.Borders.DistanceFromTop = 1
        .Selection.ParagraphFormat.Borders.DistanceFromLeft = 4
        .Selection.ParagraphFormat.Borders.DistanceFromBottom = 1
        .Selection.ParagraphFormat.Borders.DistanceFromRight = 4
        .Selection.ParagraphFormat.Borders.Shadow = False
        .Options.DefaultBorderLineStyle = wdLineStyleThinThickSmallGap
        .Options.DefaultBorderLineWidth = wdLineWidth150pt
        .Options.DefaultBorderColor = wdColorAutomatic
    End With
    
End Sub

Sub CreateWordFooter(txtLegend As String)

    With WordApp
        WordDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
        .Selection.ParagraphFormat.Borders(wdBorderTop).LineStyle = wdLineStyleThinThickSmallGap
        .Selection.ParagraphFormat.Borders(wdBorderTop).LineWidth = wdLineWidth150pt
        .Selection.ParagraphFormat.Borders(wdBorderTop).Color = wdColorAutomatic
        .Selection.ParagraphFormat.Borders.DistanceFromTop = 1
        .Selection.ParagraphFormat.Borders.DistanceFromLeft = 4
        .Selection.ParagraphFormat.Borders.DistanceFromBottom = 1
        .Selection.ParagraphFormat.Borders.DistanceFromRight = 4
        .Selection.ParagraphFormat.Borders.Shadow = False
        'Insert the legend if applicable
        If txtLegend <> "" Then
            .Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
            .Selection.Font.Size = 8
            .Selection.Font.Italic = True
            .Selection.TypeText Text:=txtLegend
        End If
        'Set page number if option selected
        If DLookup("IncludePageNum", "t_System_ExportOptions") Then
            .Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
            .Selection.Font.Size = 9
            .Selection.Font.Italic = False
            If txtLegend = "" Then
                .Selection.TypeText Text:=vbCrLf & vbCrLf
            End If
            .Selection.Fields.Add Range:=.Selection.Range, Type:=wdFieldPage
        End If
        'Draw double line across top of footer
        .Selection.ParagraphFormat.Borders(wdBorderTop).LineStyle = wdLineStyleThinThickSmallGap
        .Selection.ParagraphFormat.Borders(wdBorderTop).LineWidth = wdLineWidth150pt
        .Selection.ParagraphFormat.Borders(wdBorderTop).Color = wdColorAutomatic
        .Selection.ParagraphFormat.Borders.DistanceFromTop = 1
        .Selection.ParagraphFormat.Borders.DistanceFromLeft = 4
        .Selection.ParagraphFormat.Borders.DistanceFromBottom = 1
        .Selection.ParagraphFormat.Borders.DistanceFromRight = 4
        .Selection.ParagraphFormat.Borders.Shadow = False
        .Options.DefaultBorderLineStyle = wdLineStyleThickThinSmallGap
        .Options.DefaultBorderLineWidth = wdLineWidth150pt
        .Options.DefaultBorderColor = wdColorAutomatic
    End With

End Sub

Sub SetWordFormatting()

    With WordApp
        WordDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
        WordDoc.PageSetup.TopMargin = .InchesToPoints(0.9)
        WordDoc.PageSetup.RightMargin = .InchesToPoints(0.5)
        WordDoc.PageSetup.LeftMargin = .InchesToPoints(0.5)
        WordDoc.PageSetup.BottomMargin = .InchesToPoints(0.8)
        WordDoc.PageSetup.FooterDistance = .InchesToPoints(0.3)
        WordDoc.PageSetup.HeaderDistance = .InchesToPoints(0.3)
        WordDoc.PageSetup.TextColumns.Add Width:=.InchesToPoints(2.17), Spacing:=.InchesToPoints(0.5), EvenlySpaced:=False
        WordDoc.PageSetup.TextColumns.Add Width:=.InchesToPoints(2.17), Spacing:=.InchesToPoints(0.5), EvenlySpaced:=False
        WordDoc.DefaultTabStop = .InchesToPoints(0.04)
        .Selection.Font.Size = 9
    End With
    
End Sub

Sub PerformExport()

    Dim rsCurDirectory As Recordset
    Dim txtCurCounty As String
    Dim txtCurProvName As String
    Dim txtCurCity As String
    Dim txtServices As String
    
    Set rsCurDirectory = New Recordset
    rsCurDirectory.Open "SELECT * FROM q_Directory_Data_CombinedMeasures;", CurrentProject.Connection, adOpenKeyset, adLockReadOnly
    
    rsCurDirectory.MoveFirst
    With rsCurDirectory
        While Not .EOF
            CurEntry = CurEntry + 1
            Application.SysCmd acSysCmdSetStatus, "Processing " & CurEntry & " of " & .RecordCount & " directory entries (" & Format(CurEntry / .RecordCount, "0%") & ") " & _
                "in " & CurDirectory & " of " & TtlDirectories & " directories (" & Format(CurDirectory / TtlDirectories, "0%") & ") | Currently On: " & _
                DLookup("Market_Name", "t_Market_Map", "Market_ID=" & CurMarket) & " - " & IIf(CurMeasure <> 255, DLookup("Measure_Nm", "t_Measure_Map", "Measure_ID=" & CurMeasure), "Radiology HT/LT")
            'If the county name changes, add a new county name header; otherwise check for new city information
            If .Fields("County") <> txtCurCounty Then
                WordApp.Selection.ParagraphFormat.SpaceAfter = 4
                WordApp.Selection.Font.Size = 11
                WordApp.Selection.Font.Bold = True
                WordApp.Selection.Font.Underline = wdUnderlineSingle
                WordApp.Selection.TypeText Text:=.Fields("County") & " COUNTY"
                WordApp.Selection.InsertBreak Type:=wdTextWrappingBreak
                WordApp.Selection.ParagraphFormat.SpaceAfter = 0
                WordApp.Selection.Font.Underline = wdUnderlineNone
                WordApp.Selection.Font.Bold = False
                WordApp.Selection.Font.Size = 9
                txtCurCounty = .Fields("County")
                txtCurCity = ""
            End If
            'If the city name changes, add a new city name header; otherwise check for new provider information
            If .Fields("City") <> txtCurCity Then
                WordApp.Selection.ParagraphFormat.LeftIndent = 0
                WordApp.Selection.Font.Size = 2
                WordApp.Selection.TypeText Text:=" "
                WordApp.Selection.InsertBreak Type:=wdTextWrappingBreak
                WordApp.Selection.Font.Size = 10
                WordApp.Selection.Font.Bold = True
                WordApp.Selection.TypeText Text:=vbTab
                WordApp.Selection.Font.Underline = wdUnderlineSingle
                WordApp.Selection.TypeText Text:=.Fields("City")
                WordApp.Selection.InsertBreak Type:=wdTextWrappingBreak
                WordApp.Selection.ParagraphFormat.SpaceAfter = 0
                WordApp.Selection.Font.Underline = wdUnderlineNone
                WordApp.Selection.Font.Bold = False
                WordApp.Selection.Font.Size = 2
                WordApp.Selection.TypeText Text:=" "
                WordApp.Selection.InsertBreak Type:=wdTextWrappingBreak
                WordApp.Selection.Font.Size = 9
                txtCurCity = .Fields("City")
                txtCurProvName = ""
            End If
            'If the provider name changed, add a new provider name header; otherwise format to add additional addresses
            If .Fields("Provider_Name") <> txtCurProvName Then
                WordApp.Selection.Font.Size = 9
                WordApp.Selection.Font.Bold = True
                WordApp.Selection.TypeText Text:=vbTab & .Fields("Provider_Name")
                WordApp.Selection.InsertBreak Type:=wdTextWrappingBreak
                WordApp.Selection.Font.Bold = False
                txtCurProvName = .Fields("Provider_Name")
            Else
                WordApp.Selection.TypeBackspace
            End If
            'Setup address CSZ, etc. formatting
            WordApp.Selection.Font.Underline = wdUnderlineNone
            WordApp.Selection.Font.Bold = False
            WordApp.Selection.Font.Size = 2
            WordApp.Selection.Font.Color = wdColorWhite
            WordApp.Selection.TypeText Text:=.Fields("EPDB_PIN") & ", " & .Fields("AddressID")
            WordApp.Selection.InsertBreak Type:=wdTextWrappingBreak
            WordApp.Selection.Font.Color = wdColorBlack
            WordApp.Selection.Font.Size = 9
            WordApp.Selection.ParagraphFormat.SpaceAfter = 0
            WordApp.Selection.ParagraphFormat.SpaceBefore = 4
            If Nz(.Fields("Addr1"), "") <> "" Then
                WordApp.Selection.TypeText Text:=vbTab & vbTab & .Fields("Addr1") & vbCrLf
            End If
            WordApp.Selection.ParagraphFormat.SpaceBefore = 0
            If Nz(.Fields("Addr2"), "") <> "" And .Fields("Addr2") <> " " Then
                GoBackAndTab
                WordApp.Selection.TypeText Text:=vbTab & vbTab & .Fields("Addr2") & vbCrLf
            End If
            If Nz(.Fields("City"), "") <> "" Then
                GoBackAndTab
                WordApp.Selection.TypeText Text:=vbTab & vbTab & .Fields("City") & ", " & .Fields("State") & "   " & .Fields("Zip") & vbCrLf
            End If
            If Nz(.Fields("Phone"), "") <> "" Then
                GoBackAndTab
                WordApp.Selection.TypeText Text:=vbTab & vbTab & "Phone: " & Left(.Fields("Phone"), 3) & "-" & Mid(.Fields("Phone"), 4, 3) & "-" & Right(.Fields("Phone"), 4) & vbCrLf
            End If
            If Nz(.Fields("Fax"), "") <> "" Then
                GoBackAndTab
                WordApp.Selection.TypeText Text:=vbTab & vbTab & "Fax: " & Left(.Fields("Fax"), 3) & "-" & Mid(.Fields("Fax"), 4, 3) & "-" & Right(.Fields("Fax"), 4) & vbCrLf
            End If
            If Trim(Nz(.Fields("Hours"), "")) <> "" Then
                GoBackAndTab
                WordApp.Selection.TypeText Text:=vbTab & vbTab & "Hours: " & .Fields("Hours") & vbCrLf
            End If
            txtServices = Trim(BuildServices(rsCurDirectory))
            If txtServices = "," Then
                txtServices = ""
            End If
            If Len(txtServices) > 1 Then
                If Right(txtServices, 1) = "," Then
                    txtServices = Left(txtServices, Len(txtServices) - 1)
                End If
                If Right(txtServices, 2) = ", " Then
                    txtServices = Left(txtServices, Len(txtServices) - 2)
                End If
            End If
            If Len(txtServices) > 0 Then
                GoBackAndTab
                WordApp.Selection.TypeText Text:=vbTab & vbTab & "Svcs: " & txtServices & vbCrLf
                txtServices = ""
            End If
            WordApp.Selection.Font.Size = 1
            WordApp.Selection.TypeText Text:=vbCrLf
            WordApp.Selection.Font.Size = 9
            .MoveNext
        Wend
    End With
        
    TtlEntries = TtlEntries + CurEntry
    WordApp.Selection.WholeStory
    With WordApp.Selection
        .ParagraphFormat.KeepTogether = True
    End With

End Sub

Sub SetWordLeaveOpen()

    If DLookup("MakeWordVisible", "t_System_ExportOptions") Then
        WordApp.Visible = True
        WordApp.Activate
    Else
        WordApp.Quit
    End If
    
End Sub

Sub GoBackAndTab()

    WordApp.Selection.TypeBackspace
    WordApp.Selection.InsertBreak Type:=wdTextWrappingBreak

End Sub

Function BuildServices(CurDirectory As Recordset) As String

    With CurDirectory
        BuildServices = Nz(Switch(.Fields("chkMRIClosed") = True, "MR, "), "") & Nz(Switch(.Fields("chkMRIOpen") = True, "OMR, "), "") & Nz(Switch(.Fields("chkCNM") = True, "CNM, "), "") & _
            Nz(Switch(.Fields("chkCT") = True, "CT, "), "") & Nz(Switch(.Fields("chkPET") = True, "PET, "), "") & Nz(Switch(.Fields("chkXRay") = True, "X, "), "") & _
            Nz(Switch(.Fields("chkFluoroscopy") = True, "FL, "), "") & Nz(Switch(.Fields("chkUltrasound") = True, "US, "), "") & Nz(Switch(.Fields("chkSonogram") = True, "S, "), "") & _
            Nz(Switch(.Fields("chkBoneDensity") = True, "BD, "), "") & Nz(Switch(.Fields("chkMammography") = True, "M, "), "") & Nz(Switch(.Fields("chkGeneral") = True, "GEN, "), "") & _
            Nz(Switch(.Fields("chkEndoscopy") = True, "EN, "), "") & Nz(Switch(.Fields("chkInfertility") = True, "INF, "), "") & Nz(Switch(.Fields("chkLithotripsy") = True, "LT, "), "") & _
            Nz(Switch(.Fields("chkOpthalmology") = True, "OPT, "), "") & Nz(Switch(.Fields("chkOrthopedic") = True, "ORP, "), "") & Nz(Switch(.Fields("chkBariatric") = True, "BA, "), "") & _
            Nz(Switch(.Fields("chkUrology") = True, "UR, "), "") & Nz(Switch(.Fields("chkOther") = True, Nz(.Fields("txtAmbSurgOther"), "") & ", "), "")
    End With

End Function

Function BuildHeader(HeaderOpt As Byte, CurMarket As Byte, CurMeasure As Byte, CycleDate As String) As String

    Select Case HeaderOpt
        Case 1
            If CurMeasure <> 255 Then
                BuildHeader = "Aetna " & Chr(&H22) & "Select Provider" & Chr(&O42) & " Directory - " & DLookup("Measure_Nm", "t_Measure_Map", "Measure_ID=" & CurMeasure) & vbCrLf & DLookup("Market_Name", "t_Market_Map", "Market_ID=" & CurMarket) & " - " & Format(CycleDate, "mmmm, yyyy")
            Else
                BuildHeader = "Aetna " & Chr(&H22) & "Select Provider" & Chr(&O42) & " Directory - " & "Radiology" & vbCrLf & DLookup("Market_Name", "t_Market_Map", "Market_ID=" & CurMarket) & " - " & Format(CycleDate, "mmmm, yyyy")
            End If
        Case 2
            BuildHeader = DLookup("HeaderText", "t_System_ExportOptions")
        Case Else
    End Select

End Function

Function BuildLegend(Measure_ID As Byte) As String

    Select Case Measure_ID
        Case 1
            If DLookup("HTServices", "q_Directory_Services_Count") > 0 Then
                BuildLegend = "MR - Closed MRI | OMR - Open MRI | CNM - Cardio Nuclear Medicine | CT - CAT Scan | PET - Positron Emission Tomography" & vbCrLf & vbCrLf
            End If
        Case 2
            If DLookup("LTServices", "q_Directory_Services_Count") > 0 Then
                BuildLegend = "X - X-Ray | FL - Fluoroscopy | US - Ultrasound | S - Sonogram | BD - Bone Density | M - Mammography" & vbCrLf & vbCrLf
            End If
        Case 3
            If DLookup("AmbSurgServices", "q_Directory_Services_Count") > 0 Then
                BuildLegend = "GEN - General Surgery | EN - Endoscopy | INF - Infertility | LT - Lithotripsy | OPT - Opthalmology | ORP - Orthopedics | BA - Bariatric | UR - Urology" & vbCrLf & vbCrLf
            End If
        Case 255
            If DLookup("HTServices", "q_Directory_Services_Count") > 0 Then
                BuildLegend = "MR - Closed MRI | OMR - Open MRI | CNM - Cardio Nuclear Medicine | CT - CAT Scan | PET - Positron Emission Tomography" & vbCrLf
            End If
            If DLookup("LTServices", "q_Directory_Services_Count") > 0 Then
                BuildLegend = BuildLegend & "X - X-Ray | FL - Fluoroscopy | US - Ultrasound | S - Sonogram | BD - Bone Density | M - Mammography" & vbCrLf
            End If
        Case Else
            BuildLegend = ""
    End Select

End Function

Function BuildFilename(FNameOpt As Byte, CurMarket As Byte, CurMeasure As Byte) As String

    Select Case FNameOpt
        Case 1
            If CurMeasure <> 255 Then
                BuildFilename = CurrentProject.Path & "\SelectDirectory_" & Replace(DLookup("Market_Name", "t_Market_Map", "Market_ID=" & CurMarket), " ", "_") & "_" & Replace(DLookup("Measure_Nm", "t_Measure_Map", "Measure_ID=" & CurMeasure), " ", "_") & ".doc"
            Else
                BuildFilename = CurrentProject.Path & "\SelectDirectory_" & Replace(DLookup("Market_Name", "t_Market_Map", "Market_ID=" & CurMarket), " ", "_") & "_Radiology.doc"
            End If
        Case 2
            BuildFilename = DLookup("FilenameText", "t_System_ExportOptions")
        Case Else
    End Select
    
    BuildFilename = Replace(BuildFilename, "/", "_")

End Function

EDIT: I should mention those are all stand-alone routines that are called from a main module. That module (not in its entirety) looks like this:

Code: 
            'Create and output the directory to Word
            Call CreateWordDoc
            Call SetWordVisible
            Call CreateWordHeader(txtHeader)
            Call CreateWordFooter(txtLegend)
            Call SetWordFormatting
            Call PerformExport
            WordDoc.SaveAs txtFilename
            WordDoc.Close

That's modularization of code, and it makes things a ton easier to debug as necessary. For example, if my header isn't coming out right, then I know the subroutine "CreateWordHeader" is at fault, etc. Just thought I'd point that out too. And, of course, don't forget to set object variables to Nothing when you're done (Set WordApp = Nothing).
 
Last edited:
Thank you so much - It's just what I needed.

It will take me some time to go through it, I'm sure I'll work it out with some trial and error - that's the fun of learning!
 
You must log in or register to reply here.

Similar threads

J
Bring Word to the front when opened in ACCESS
Replies
4
Views
1,323
jpl458
J
S
Access VBA to Find Row and Col for found text in MS Word
Replies
3
Views
1,901
sxschech
S
L
Export data from Access to Word with VBA
Replies
12
Views
1,649
arnelgp
arnelgp
L
Your opinion about best way to display Word documents inside an Access form
2
Replies
30
Views
4,973
CJ_London
C
T
Solved Convert amount to words
Replies
18
Views
1,526
Tiprof
T

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom