我试图将方括号的内容更改为合并字段。我有80个文档要通过一些没有方括号和一些有几个(没有嵌套)。
我已经设法运行我的代码,它已经适用于一些文件。其他人(大多数)给出了溢出错误。当我检查其中一个文件中发生的事情时,代码正确地拾取内容,它只是将合并字段放在错误的位置,这反过来又导致它继续找到同一组方括号。
Public Function searchFiles(fFile As Variant, rootFolderStr2 As String, rootFolderStr As String)
Dim strTemp As String, mfc As String, msg As String
Dim startStr As Integer, endStr As Integer
Dim objWord As New Word.Application
Dim objDoc As Word.Document
Dim aField As Field, fFolder As String
Dim rng As Variant, myField As Field, oldField As Variant
On Error GoTo ErrorHandler
'open file
'Open fFile For Input As #1
Set objDoc = objWord.Documents.Open(fFile)
objDoc.TrackRevisions = False
strTemp = objDoc.Range(0, objDoc.Range.End)
startStr = InStrRev(strTemp, "[")
endStr = InStrRev(strTemp, "]")
Do While startStr <> 0
'Merge field contents
mfc = Right(Left(strTemp, endStr - 1), endStr - startStr - 1)
Set rng = objDoc.Range(startStr - 1, endStr)
Set myField = objDoc.Fields.Add(Range:=rng, Type:=wdFieldMergeField, Text:=mfc)
strTemp = objDoc.Range(0, objDoc.Range.End)
'Find next merge field
startStr = InStrRev(strTemp, "[")
endStr = InStrRev(strTemp, "]")
If endStr < startStr And endStr <> -1 Then
msg = "Error occured in " & fileName & " " & startStr & " " & endStr
Debug.Print (msg)
startStr = 0
endStr = 0
End If
Loop
'put in right folder
fFolder = Right(objDoc.FullName, Len(objDoc.FullName) - Len(rootFolderStr))
objDoc.SaveAs fileName:=rootFolderStr2 & "\" & fFolder
objDoc.Close
objWord.Quit
ErrorHandler:
If Err.Number <> 0 Then
Debug.Print ("Error occured in file: " & fileName & " " & Err.Description)
Exit Function
End If
End Function
拜托,我正在努力理解单词中的对象是如何工作原谅的。
关于导致这个问题的原因的任何答案都将受到赞赏,或者以更好的方式做任何帮助。
尝试:
Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Call MakeFields(wdDoc)
wdDoc.Close SaveChanges:=True
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Sub MakeFields(wdDoc As Document)
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "\[*\]"
.Execute
End With
Do While .Find.Found
.Characters.First.Text = vbNullString
.Characters.Last.Text = vbNullString
.Fields.Add Range:=.Duplicate, Type:=wdFieldEmpty, Text:="MERGEFIELD " & .Text, Preserveformatting:=False
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End Sub
上面的代码处理所选文件夹中的所有文档。
好。通用建议始终始终将选项显式设置为模块或类的开头。这有助于突出代码中与错误使用语法和未声明变量等相关的错误。在您发布的代码中,有一个未声明的变量“Filename”。
使用Word时,最好尝试找到一种使用单词对象模型而不是提取文本的方法。
您可以通过使用.MoveStart / EndUntil方法替换instrrev来修改现有代码。
我已更新您的代码以使用这些移动方法。
如果您不理解关键字的作用,请将光标放在其上并按F1。这将带您进入MS帮助页面。对于Word对象模型,帮助页面需要仔细阅读。
Option Explicit
' Changed to sub as you are not returning any values
Public Sub searchFiles(fFile As Variant, rootFolderStr2 As String, rootFolderStr As String)
Const FieldOpen As String = "["
Const FieldClose As String = "]"
Dim strTemp As String, mfc As String, msg As String
Dim objWord As New Word.Application
Dim objDoc As Word.Document
' Dim aField As FieldDim
Dim fFolder As String
' Dim rng As Variant
' Dim myField As Field
' Dim oldField As Variant
' Not previously declared
Dim Filename As String
Dim SearchRng As Word.Range
Dim FieldRng As Word.Range
Dim Moved As Long
'open file
'Open fFile For Input As #1
On Error GoTo ErrorHandler
Set objDoc = objWord.Documents.Open(fFile)
objDoc.TrackRevisions = False
'strTemp = objDoc.Range(0, objDoc.Range.End)
Set SearchRng = ActiveDocument.Content
'startStr = InStrRev(strTemp, "[")
Moved = SearchRng.MoveStartUntil(cset:=FieldOpen)
'Do While startStr <> 0
Do Until Moved = 0
'Merge field contents
'mfc = Right(Left(strTemp, endStr - 1), endStr - startStr - 1)
FieldRng.Start = SearchRng.Start + 1
'endStr = InStrRev(strTemp, "]")
' exit if we don't find a closing field marker
' The side effect (which we want) is that the end is also moved
If SearchRng.MoveEndUntil(cset:=FieldClose) = 0 Then GoTo ErrorHandler
FieldRng.End = SearchRng.End + 1
' reduce the FieldRng to just the text
FieldRng.Characters.First.Delete
FieldRng.Characters.Last.Delete
'Set rng = objDoc.Range(startStr - 1, endStr
'Set myField = objDoc.Fields.Add(Range:=rng, Type:=wdFieldMergeField, Text:=mfc)
objDoc.Fields.Add Range:=FieldRng, Type:=wdFieldMergeField, Text:=FieldRng.Text
'strTemp = objDoc.Range(0, objDoc.Range.End)
' We now need to move the start of the search range to after the mergefield
SearchRng.Start = FieldRng.End + 1
'Find next merge field
'startStr = InStrRev(strTemp, "[")
'endStr = InStrRev(strTemp, "]")
Moved = SearchRng.MoveStartUntil(cset:=FieldOpen)
' If endStr < startStr And endStr <> -1 Then
' msg = "Error occured in " & Filename & " " & startStr & " " & endStr
' Debug.Print (msg)
' startStr = 0
' endStr = 0
' End If
Loop
'put in right folder
fFolder = Right(objDoc.FullName, Len(objDoc.FullName) - Len(rootFolderStr))
objDoc.SaveAs Filename:=rootFolderStr2 & "\" & fFolder
objDoc.Close
objWord.Quit
ErrorHandler:
If Err.Number <> 0 Then
Debug.Print ("Error occured in file: " & Filename & " " & Err.Description)
Exit Sub
End If
End Sub
上面的代码编译没有错误,但我没有测试逻辑。我会把它留作“为读者练习”