vba 操作Word-更新word内容

Dim docPath As String
    Dim wordApp As New Word.Application
    Dim wordDoc As New Word.Document
   

Private Sub CmdSelectDic_Click()
 Unload Me
End Sub

Private Sub List_file(oPath As String)
   
          Dim uuFso, uuDir, uuFiles, uuObj
           
          List1.Clear
          Set uuFso = CreateObject("Scripting.FileSystemObject")
          Set uuDir = uuFso.getfolder(oPath)
          Set uuFiles = uuDir.Files
          For Each uuObj In uuFiles
                  Select Case UCase(uuFso.GetExtensionName(uuObj.Name))
                          Case "DOC"
                            If Left(uuObj.Name, 1) <> "~" Then
                                  List1.AddItem uuObj.Name
                            End If
                          Case Else
                  End Select
          Next
End Sub

Private Sub CmdExit_Click()
 End
End Sub

Private Sub cmdShowLog_Click()
    Shell "notepad c:/olog.log", vbMaximizedFocus
End Sub

Private Sub CmdStart_Click()

    If CHECK_TXT = 0 Then
        Exit Sub
    End If
   
    CmdStart.Enabled = False
    CmdExit.Enabled = False
   
    Me.Caption = "正在处理..."
   
    '退出所以word文档 并保存
    wordApp.Quit True
   
    List2.Clear
   
    Me.ProgressBar1.Value = 0
    Dim docNum
    docNum = 0
    Dim maxProcessbar
    maxProcessbar = List1.ListCount
   
    '处理列表框中的每个doc文档
    While List1.ListCount
      
       docNum = docNum + 1

       Process_wordFile docPath & "/" & List1.List(0), CInt(docNum)
      
       List2.AddItem List1.List(0)
      
       List1.RemoveItem (0)
      
       Me.ProgressBar1.Value = 100 * docNum / maxProcessbar
      
       DoEvents
    Wend
   
    Me.Caption = "批量DOC文档处理"
    MsgBox "处理结束", vbInformation, "提示信息"
    CmdStart.Enabled = True
    CmdExit.Enabled = True
   

End Sub

Private Sub Process_wordFile(wfilePath As String, flwID As Integer)

   
    '---------打开word文档-----------------

   ' Set wordApp = CreateObject("Word.Application")
    Dim newStr
    Dim myRange As Object
    Set wordApp = New Word.Application
    wordApp.Visible = False
   
    Set wordDoc = wordApp.Documents.Open(wfilePath)
    Set myRange = wordDoc.Paragraphs(wordDoc.Paragraphs.Count)
'    '图幅编号赋值
'    newStr = "PTQ-" & Mid(wordDoc.Tables(1).Rows(1).Cells(1).Range.Text, 6, 2)
'    newStr = newStr & "-" & Left("0000", 4 - Len(CStr(flwID))) & flwID
'    wordDoc.Tables(1).Rows(4).Cells(2).Range.Text = newStr
'
'    '调查表编号赋值
'    wordDoc.Tables(1).Rows(4).Cells(6).Range.Text = newStr & "B"
'
'
'    '修改面积
'    newStr = wordDoc.Tables(1).Rows(6).Cells(4).Range.Text
'    newStr = Left(newStr, Len(newStr) - 3)
'
'    If IsNumeric(newStr) = True Then
'        newStr = CDbl(newStr) / 15      '亩转换为公顷
'        wordDoc.Tables(1).Rows(6).Cells(4).Range.Text = newStr & "公顷"
'    End If
'
'    newStr = wordDoc.Tables(1).Rows(7).Cells(4).Range.Text
'    newStr = Left(newStr, Len(newStr) - 3)
'
'    If IsNumeric(newStr) = True Then
'        newStr = CDbl(newStr) / 15
'        wordDoc.Tables(1).Rows(7).Cells(4).Range.Text = newStr & "公顷"
'    End If
'
'
'
'    '修改
'     wordDoc.Tables(1).Rows(10).Cells(4).Range.Text = " 是√  否 "
'
'    '修改整个表格内字体颜色
'    wordDoc.Tables(1).Range.Font.Color = wdColorBlack
   
    newStr = "                                测量者：" & Trim(TxtCL.Text) & _
             " 校对人：" & Trim(TxtCL.Text) & " 审核人：" & Trim(TxtSh.Text)

    If wordDoc.Paragraphs(wordDoc.Paragraphs.Count).Range.Words.Count < 5 Then
            writeLog "文件：" & wfilePath & "发生错误，可能是段落末尾含有空段落！"
    End If
   
    wordDoc.Paragraphs(wordDoc.Paragraphs.Count).Range.Text = newStr
   
    wordDoc.Close True
    wordApp.Quit
    Set wordApp = Nothing
    Set wordDoc = Nothing
End Sub

Private Sub Dir1_Change()
     docPath = Dir1.Path
     List_file (docPath)
End Sub

 

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
    docPath = "C:/"
    List_file (docPath)
End Sub

Function RegExpNum(s As String) As String
          Dim p     As String
         
          Dim reg     As RegExp
          Dim mc     As MatchCollection
          Dim m     As Match
          p = "测量者([/s+])"
           
          Set reg = New RegExp
          reg.Pattern = p
          Set mc = reg.Execute(s)
         
          For Each m In mc
                  p = m.Value
          Next m
        '  MsgBox "mc.Count=" & mc.Count
         
          RegExpNum = p
          Set mc = Nothing
           
          Set reg = Nothing
End Function

 

Private Sub TxtCL_GotFocus()
    'MsgBox Left(TxtCL.Text, 1)
    If Left(TxtCL.Text, 1) = "-" Then
        TxtCL.Text = ""
    End If
End Sub

Private Sub TxtCL_LostFocus()
    If Trim(TxtCL.Text) = "" Then
        TxtCL.Text = "-测量者-"
        TxtCL
    End If
End Sub

Private Sub txtjd_gotfocus()
    If Left(TxtJd.Text, 1) = "-" Then
        TxtJd.Text = ""
    End If
End Sub

Private Sub txtjd_lostfocus()
    If Trim(TxtJd.Text) = "" Then
        TxtJd.Text = "-校对人-"
    End If
End Sub

Private Sub txtSh_gotfocus()
    If Left(TxtSh.Text, 1) = "-" Then
        TxtSh.Text = ""
    End If
End Sub

Private Sub txtSh_lostfocus()
    If Trim(TxtSh.Text) = "" Then
        TxtSh.Text = "-审核人-"
    End If
End Sub

Function CHECK_TXT()
    If Left(TxtSh.Text, 1) = "-" Or Left(TxtJd.Text, 1) = "-" Or Left(TxtCL.Text, 1) = "-" Then
   
        MsgBox "信息不完整！", vbInformation, "提示"
        CHECK_TXT = 0
    Else
        CHECK_TXT = 1
    End If
   
End Function

Private Sub writeLog(str As String)
    str = Now() & "  " & str
     
    str = str & vbCrLf & "--------------------" & vbCr
   
    Open "c:/olog.log" For Append As #1
    Write #1, str
    Close #1
End Sub