'In module called AutoOpen
Option Explicit 
 
 'Main Sub in AutoOpen module that will fire on opening a document
Sub Main() 
    frmContacts.Show 
End Sub 
 
Public Sub FillBookmark(sText As String, sBookmark As String) 
    Dim oRange As Word.Range 
     
    With Application.ActiveDocument 
         'Set oRange to start and end of bookmark sBookmark's range
        Set oRange = .Bookmarks(sBookmark).Range 
         'Fill the text of oRange with the value of sText
        oRange.Text = sText 
         'Create bookmark to range the text [ ]
        .Bookmarks.Add Name:=sBookmark, Range:=oRange 
         'Clean up
        Set oRange = Nothing 
    End With 
End Sub 
 
 'In UserForm called frmContacts
Option Explicit 
 
 'Add Reference to Microsoft DAO 3.6 Object Library
Private Sub UserForm_Initialize() 
    Dim dbs As DAO.Database 
    Dim rst As DAO.Recordset 
     
     'Establish connection
    Set dbs = OpenDatabase(ActiveDocument.Path & "\Contacts.mdb") 
     'Fill recordset
    Set rst = dbs.OpenRecordset("Select Name FROM Contacts;") 
     
     'Fill combo by looping through the recordset
    Do While Not rst.EOF 
        Me.cboContacts.AddItem rst("Name") 
        rst.MoveNext 
    Loop 
     
     'Clean up
    Set rst = Nothing 
    Set dbs = Nothing 
End Sub 
 
Private Sub cmdInsert_Click() 
    Dim dbs As DAO.Database 
    Dim rst As DAO.Recordset 
     
     'If no selection was made exit sub
    If Me.cboContacts.ListIndex = -1 Then 
        Beep 
        MsgBox "Make a choice first", 64, "Choose from list" 
         
        Exit Sub 
    Else 
         
         'Hide form
        Me.Hide 
         
         'Establish connection
        Set dbs = OpenDatabase(ActiveDocument.Path & "\Contacts.mdb") 
         
         'Fill recordset with data matching the text of combo cboContacts
        Set rst = dbs.OpenRecordset("Select * FROM Contacts WHERE Name = '" & _ 
        Me.cboContacts.Text & "';") 
         
         'Write values of Recordset fields to bookmarks in the document
        Call FillBookmark("" & rst.Fields("Company"), "bmCompany") 
        Call FillBookmark("" & rst.Fields("Name"), "bmName") 
        Call FillBookmark("" & rst.Fields("Address"), "bmAddress") 
        Call FillBookmark("" & rst.Fields("Postal") & Chr$(32) & rst.Fields("City"), "bmCity") 
         '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        Call FillBookmark("" & rst.Fields("Phone"), "bmPhone") 
        Call FillBookmark("" & rst.Fields("Mobile"), "bmMobile") 
        Call FillBookmark("" & rst.Fields("Fax"), "bmFax") 
        Call FillBookmark("" & rst.Fields("Website"), "bmwww") 
        Call FillBookmark("" & rst.Fields("Email"), "bmEmail") 
        Call FillBookmark("" & rst.Fields("Language"), "bmLanguage") 
        Call FillBookmark("" & rst.Fields("Memo"), "bmMemo") 
         
        ActiveDocument.Fields.Update 'Update linked fields
    End If 
     
     'Clean up
    Unload Me 'give resources back to the system
    Set rst = Nothing 
    Set dbs = Nothing 
End Sub