'定義Word應用對象及文檔對象
Private wdApp As New Word..Application()
Private wdDoc As New Word.Document()
'所處理的Word模板文件
Private FileName As String
'域的個數及對應的數組
Dim FieldCount As Int16
Dim MyField()
'Word是否已運行
Private IsWordRunning As Boolean
'是否已經插入了表格行
Private IsInsertRow As Boolean  
'Word工具欄對象及菜單欄對象數組
Dim CommandBarIndex() As Integer
Dim SaveCommandBarMenuIndex() As Integer

Public Sub OpenWordDocument(ByVal FileName As String)
        wdApp = CreateObject("Word。Application")
        wdApp.Documents。Open(FileName)
        wdDoc = wdApp.ActiveDocument
        wdDoc.ActiveWindow.DocumentMap = False
        wdApp.Visible = True
        IsWordRunning = True
 End Sub

Public Sub SaveWordDocument()
        wdDoc.SaveAs(FileName)
 End Sub

Public Sub SetWordSize(ByVal Left As Integer， ByVal top As Integer， 
    ByVal width As Integer， ByVal height As Integer)
        wdApp。WindowState = Word.WdWindowState.wdWindowStateNormal
        wdApp。Left = Left
        wdApp。Top = top
        wdApp。Width = width
        wdApp。Height = height
    End Sub

'在文檔中插入域
    'KeyWord:域的關鍵字
    Public Function InsertField(ByVal KeyWord As String) As Integer
        Dim mySelection As Selection
        Dim Code As String
        Dim MyField As Field
        Dim myRange As Range
        wdApp。Selection。Collapse(Direction:=wdCollapseEnd)
        mySelection = wdApp。Selection      '插入點
        If KeyWord。Chars(KeyWord。Length - 1) = "F" Then
            If IsCell(mySelection) <> True Then
                MsgBox("該位置不是單元格，請選擇單元格"， vbOKOnly + vbExclamation)
                Exit Function
            End If
        End If
        If IsCell(mySelection) = True Then
            If CellFieldCount(mySelection) > 0 Then
                If MsgBox("該單元格已有域，是否覆蓋?"， vbYesNo) = 6 Then
                    mySelection.Cells.Item(1).Select()
                    mySelection.Delete()
                Else
                    Exit Function
                End If
            End If
        End If
        MyField = wdDoc.Fields.Add(Range:=mySelection.Range， Type:=wdFieldAddin)
        MyField.Data = KeyWord
    End Function

'選擇點(光標)是否是單元格。
    Private Function IsCell(ByVal mySelection As Selection) As Boolean
        If mySelection.Tables.Count > 0 Then
            Return True
        Else
            Return False
        End If
    End Function
    '計算選擇點(光標)的單元格的域數
    Private Function CellFieldCount(ByVal mySelection As Selection) As Integer
        CellFieldCount = mySelection.Cells.Item(1).Range.Fields.Count
End Function
'記錄插入域代碼及關鍵字。這里主要是調用上面的InsertField方法。
    Public Function InsertFieldByKeyWord(ByVal KeyWord As String) As Integer
        Dim ID As Integer
        FieldCount = FieldCount + 1
        ReDim MyField(FieldCount)
        ID = InsertField(KeyWord)
        MyField(FieldCount).ID = ID
        MyField(FieldCount).KeyWord = KeyWord
    End Function

'用關鍵字對應的值插入值，在文檔中在有域的地方插入對應的值
    Public Function InsertValue() As Boolean
        Dim i， Count As Integer
        Dim KeyWord As String
        Dim Value， Data
        Dim mySelection As Selection
        Count = wdDoc.Fields.Count
        For i = 1 To Count
            If wdDoc.Fields.Item(i).Type = 81 Then
                KeyWord = wdDoc.Fields.Item(i).Data
                If Right(KeyWord， 1) <> "F" Then
                    Value = clsDB.GetFieldValues("工程"， KeyWord)
                    wdDoc.Fields.Item(i).Select()
                    mySelection = wdApp.Selection      '插入點
                    If mySelection.Tables.Count <> 0 Then
                        'clear  text
                        mySelection.Cells.Item(1).Select()
                        mySelection.Delete() 
                        '還原原域
                        InsertField(KeyWord)
                    End If
                    wdDoc.Fields.Item(i).Result.Text = Value(0).itemarray(0)
                End If
            End If
        Next
    End Function

'插入多值域
    Public Function InsertCollection() As Boolean
        Dim i， j， Count As Integer
        Dim KeyWord As String
        Dim mySelection As Selection
        Dim rec() As Object
        Dim recCount As Integer

        Count = wdDoc.Fields.Count
        For i = 1 To Count
            If wdDoc.Fields.Item(i).Type = 81 Then
                KeyWord = Trim(wdDoc.Fields.Item(i).Data)
                If Right(KeyWord， 1) = "F" Then
                    KeyWord = Left(KeyWord， Len(KeyWord) - 1)
                    rec = clsDB.GetFieldValues("校核"， KeyWord)
                    '選擇有域的單元格
                    wdDoc.Fields.Item(i).Select()
                    mySelection = wdApp.Selection      '插入點
                    mySelection.Cells.Item(1).Select()
                    '清除原值
                    mySelection.Delete()
                    '還原原域并更新值
                    InsertField(KeyWord + "F")
                    wdDoc.Fields.Item(i).Result.Text = rec(0).itemarray(0)
                    '光標下移
                    mySelection.Select()
                    mySelection.MoveDown(Unit:=wdLine， Count:=1)
                    With rec
                        recCount =.GetLength(0) - 1
                        For j = 1 To recCount - 1
                            If IsInsertRow = False Then
                                Call InsertRow(mySelection， recCount)
                            End If
                            mySelection.Cells.Item(1).Select()
                            mySelection.Delete()
                            mySelection.TypeText(Text:=rec(j).itemarray(0))
                            mySelection.MoveDown(Unit:=wdLine， Count:=1)
                        Next
                    End With
                End If
            End If
        Next
    End Function
    Private Function InsertRow(ByVal mySelection As Selection，
    ByVal recCount As Integer) As Boolean
        Dim InsertRowCount As Integer           '插入的行數
        Dim CurrCell As Cell
        CurrCell = mySelection.Cells.Item(1)
        InsertRowCount = recCount - mySelection.Tables.Item(1).Rows.Count + 1
        If InsertRowCount > 0 Then
            mySelection.InsertRows(InsertRowCount)
            CurrCell.Select()
            mySelection.MoveUp(Unit:=wdLine， Count:=InsertRowCount)
            IsInsertRow = True
        End If
    End Function

'恢復Word環境的所有命令及菜單。 
    Public Sub OpenCommandBar()
        Dim i As Integer
        For i = 0 To UBound(CommandBarIndex) - 1
            wdDoc.CommandBars(i + 1).Visible = True
        Next
        For i = 0 To UBound(SaveCommandBarMenuIndex) - 1
            wdDoc.CommandBars.Item("Menu Bar").Controls(i + 1)。Visible = True
        Next
    End Sub
    '關閉Word環境的所有命令及菜單。 
    Public Sub CloseCommandBar()
        Dim i As Integer
        Dim cBar
        ReDim CommandBarIndex(1)
        ReDim SaveCommandBarMenuIndex(1)
        i = 0
        For Each cBar In wdDoc.CommandBars
            If cBar.Type = 0 And cBar.Enabled = True Then
                If cBar.Visible = True Then
                    ReDim CommandBarIndex(i + 1)
                    CommandBarIndex(i) = cBar.Index
                    i = i + 1
                    cBar.Visible = False
                End If
            End If
        Next
        i = 0
        For Each cBar In wdDoc.CommandBars("Menu Bar").Controls
            If cBar.Visible = True Then
                ReDim SaveCommandBarMenuIndex(i + 1)
                SaveCommandBarMenuIndex(i) = cBar.Index
                i = i + 1
                cBar.Visible = False
            End If
        Next
    End Sub

Public Class COleDataAccess
Private mOleCnnDB As New OleDbConnection()
'連接Access數據庫：DBName數據庫名。
    Public Sub ConnAccess(ByVal DBName As String)
        mOleCnnDB.ConnectionString = 
"Provider=Microsoft.Jet.OLEDB.4.0;Password="""
";User ID=Admin;" & _
         "Data Source='" & DBName & "'"
      mOleCnnDB.Open()
    End Sub
    '獲取數據表.strSql查詢條件。
    Public Overloads Function GetDataTable(ByVal strSql As String) As DataTable
        Dim myDataSet As New DataSet()
        Dim myOleDataAdapter As New OleDbDataAdapter()
        myOleDataAdapter.SelectCommand = New OleDbCommand(strSql， mOleCnnDB)
        Try
            myOleDataAdapter.Fill(myDataSet)
        Catch er As Exception
            MsgBox(er.ToString)
        End Try
        Return myDataSet.Tables(0)
    End Function
'由字段名得到字段值的方法:. TableName表名 ; FieldName 字段名
    Public Overloads Function GetFieldValues(ByVal TableName As String，
    ByVal FieldName As String) As Object()
        Dim dr As DataTable
        Dim sql As String
        sql = "select " + FieldName + " from " + TableName
        dr = GetDataTable(sql)
        Dim al(dr.Rows.Count) As Object
        dr.Rows.CopyTo(al， 0)
        Return al
    End Function
End Class

Module Module1
    Public clsDB As New COleDataAccess()
    Sub main()
        clsDB.ConnAccess("工程數據。mdb")
        Dim frm As New frmUserWord()
        frm.ShowDialog()
    End Sub
End Module

Private Sub Form1_Load(ByVal sender As System.Object， ByVal e As 
System.EventArgs) Handles MyBase.Load
        Dim i As Integer
        OpenFileDialog1.Title = "打開文件"
        OpenFileDialog1.Filter = "Word文檔(*.doc)|*.doc|Word文檔模板(*.dot)|*.dot"
        SaveFileDialog1.Title = "保存文件"
        SaveFileDialog1.Filter = "Word文檔(*.doc)|*.doc|Word文檔模板(*.dot)|*.dot"
        Dim dt As New DataTable()
        dt = clsDB.GetDataTable("select * from 工程")
        For i = 0 To dt.Columns.Count - 1
            ComboBox1.Items.Add(dt.Columns.Item(i).ColumnName)
        Next
        dt = clsDB.GetDataTable("select * from 校核")
        For i = 0 To dt.Columns.Count - 1
            ComboBox2.Items.Add(dt.Columns.Item(i).ColumnName)
        Next
    End Sub
   '填充數據
    Private Sub cmdFill_Click(ByVal sender As System.Object， ByVal e As 
System。EventArgs) Handles cmdFill.Click
        clsDoc.InsertValue()
        clsDoc.InsertCollection()
    End Sub
'用戶選擇所插入域的域名，并在光標處插入單值域。
    Private Sub ComboBox1_SelectedIndexChanged(ByVal sender As Object， 
    ByVal e As System.EventArgs) Handles ComboBox1.SelectedIndexChanged
        clsDoc.InsertField(sender.Text)
    End Sub
'用戶選擇所插入域的域名，并在光標處插入多值域。
域所對應多值時，域只能插入表格中。且要與單值域區分，標記為多值插入。
    Private Sub ComboBox2_SelectedValueChanged(ByVal sender As Object，
    ByVal e As System.EventArgs) Handles ComboBox2.SelectedValueChanged
        Dim KeyWord As String
        KeyWord = sender.Text + "F" '標記是多值
        clsDoc.InsertField(KeyWord)
    End Sub
'保存Word文件。
    Private Sub cmdSave_Click(ByVal sender As System.Object，
    ByVal e As System.EventArgs) Handles cmdSave.Click
        clsDoc.SaveWordDocument()
End Sub
'打開Word的命令菜單及工具箱。
Private Sub frmUserWord_Closed(ByVal sender As Object， 
ByVal e As System.EventArgs) Handles MyBase.Closed
        clsDoc.OpenCommandBar()
    End Sub
End Class