[求助]如何用VBA--将尾注文本变为普通文本?

ssq1109

一文档中有尾注，但又不是都集中放在文尾，而是分几处插在正文中（见附件中的NEW.DOC），如果将这样的文档另存为文本文件，在所得的文本文件中，尾注文本又都集中到文尾了（见NEW1.TXT）。

现要求：

1. 将这篇文档中的尾注文本都变成普通文本，且还是放在尾注文本原来所在页面的位置，这样就可保证再另存为文本文件后，尾注文本和原文档页面布局是相同的（见NEW2.TXT）。且要求实现这种转换后，原文中的尾注序号不丢失，或者干脆将其也变为普通的上标格式文本。

2. 如果原正文和尾注文本间有尾注分隔符（即有一条横线），将这条线变为[line]。

不知这种要求能否实现？请高人相助。谢谢！

UJnRtlW2.rar (16.48 KB, 下载次数: 47)

2006-9-23 20:34 上传

点击文件名下载附件
[求助]如何用VBA--将尾注文本变为普通文本?

守柔

这个问题问得我好累，从昨天开始考虑到收稿，近4小时。

以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2006-9-24 9:20:40
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0075^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub GetEndNotes()
    Dim myRange As Range, oSection As Section
    Dim NewDoc As Document
    Dim intCount As Integer, rngStart As Range, rngEnd As Range
    Application.ScreenUpdating = False    '关闭屏幕更新
    Set NewDoc = Documents.Add    '新建一个文档
    For Each oSection In ThisDocument.Sections    '本文档节中循环
        With oSection
            '定义一个Range对象为新文档的文档结束标记前一个插入点位置
            Set myRange = NewDoc.Range(NewDoc.Content.End - 1, NewDoc.Content.End - 1)
            myRange.InsertAfter .Range.Text    '插入节文本
            If .Range.Endnotes.Count = 0 Then    '如果没有尾注
            Else
                myReplace myRange, .Index, True    '执行指定的查找与替换
                ' 定义一个Range对象为新文档的文档结束标记前一个插入点位置
                Set myRange = NewDoc.Range(NewDoc.Content.End - 1, NewDoc.Content.End - 1)
                '如果具有尾注分隔符
               

守柔

 If Asc(.Range.Endnotes.Separator.Text) = 3 Then
                    '插入指定标记文本
                    myRange.InsertAfter "[line]" & Chr(13)
                    '定义一个Range对象为新文档的文档结束标记前一个插入点位置
                    Set myRange = NewDoc.Range(NewDoc.Content.End - 1, NewDoc.Content.End - 1)
                    intCount = .Range.Endnotes.Count    '取得本节尾注数量
                    Set rngStart = .Range.Endnotes(1).Range    '定义一个起始Range对象
                    Set rngEnd = .Range.Endnotes(intCount).Range    '定义一个结束Range对象
                    rngStart.SetRange rngStart.Start - 1, rngEnd.End    '重新定义一个Range对象,为本节尾注区域
                    myRange.InsertAfter rngStart.Text    '插入尾注文本
                    myReplace myRange, .Index, False    '执行指定的查找与替换
                End If
            End If
        End With
    Next
    NewDoc.Fields.Update    '更新SEQ域
    Application.ScreenUpdating = True    '恢复屏幕更新
End Sub
'----------------------

守柔

Function myReplace(oRange As Range, RC As Integer, TF As Boolean)
    Dim FieldText1 As String, FieldText2 As String, FieldText As String
    Dim FieldRange As Range, wdNR As WdNumberingRule
    With ThisDocument
        wdNR = .Endnotes.NumberingRule    '取得尾注编号类型
        If wdNR = wdRestartContinuous Then    '继续编号
            FieldText1 = "SEQ A"
            FieldText2 = "SEQ B"
        ElseIf wdNR = wdRestartSection Then    '每节开始重新编号
            FieldText1 = "SEQ " & Chr(64 + RC)
            FieldText2 = "SEQ _" & Chr(64 + RC)
        End If
        Set FieldRange = .Range(0, 0)    '定义一个Range对象
        FieldText = VBA.IIf(TF = True, FieldText1, FieldText2)    '域代码文本
        .Fields.Add FieldRange, wdFieldEmpty, FieldText, False    '插入域
        FieldRange.SetRange 0, Len(FieldText) + 6    '重新定义Range对象,注意2003中的域标记长度为4而非2
        With FieldRange    '此处设置编号格式
            '        .Select'
            .Font.Superscript = True    '上标
            .Font.Name = "Tahoma"    '字体
            .Cut
        End With
        With oRange.Find    '查找与替换
            .ClearFormatting
            .Execute findtext:="^2", replacewith:="^c", Replace:=wdReplaceAll
        End With
    End With
End Function
'----------------------

[此贴子已经被作者于2006-9-24 9:23:43编辑过]

ssq1109

非常谢谢守柔大侠！

我仔细看了代码，再回想我最初试图解决的思路，反倒使我感到要把VBA学到能解决较复杂问题的水平还很有些难度。

经测试，非常好，完全达到要求。

cbyqpy

对守柔的程序进行了修改，应该可以适合更多的人


'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2006-9-24 9:20:40
'* modfied by dengyixiang@gmail.com 2011-8-9 16:52:03
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0075^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit

'尾注均放在文档末尾

Sub 尾注转化为文本()
    Dim orng As Range, sec As Section
    Dim odoc As Document
    Dim intCount As Integer, rngStart As Range, rngEnd As Range
   
    Application.ScreenUpdating = False    '关闭屏幕更新
    Set odoc = Documents.Add    '新建一个文档
    ThisDocument.Range.Copy
    odoc.Range.Paste
    odoc.Fields.Unlink
    Call myReplace(odoc.Range, 1, True)    '执行指定的查找与替换
   
    For Each sec In ThisDocument.Sections    '本文档节中循环
        With sec
            '定义一个Range对象为新文档的文档结束标记前一个插入点位置
            Set orng = odoc.Range(odoc.Content.End - 1, odoc.Content.End - 1)
'            orng.InsertAfter sec.Range.Text    '插入节文本
            
'            sec.Range.Copy
'            orng.Paste
            
            
            If sec.Range.Endnotes.Count = 0 Then    '如果没有尾注
            Else
'                Call myReplace(orng, sec.Index, True)    '执行指定的查找与替换
'
'                ' 定义一个Range对象为新文档的文档结束标记前一个插入点位置
'                Set orng = odoc.Range(odoc.Content.End - 1, odoc.Content.End - 1)
               
                '如果具有尾注分隔符
               
               
               
                If Asc(sec.Range.Endnotes.Separator.Text) = 3 Or sec.Range.Endnotes.Separator.Text = "" Then
                        
                        '插入指定标记文本
'                        orng.InsertAfter "[line]" & Chr(13)
                        
                        '定义一个Range对象为新文档的文档结束标记前一个插入点位置
                        Set orng = odoc.Range(odoc.Content.End - 1, odoc.Content.End - 1)
                        
                        intCount = sec.Range.Endnotes.Count    '取得本节尾注数量
                        Set rngStart = sec.Range.Endnotes(1).Range    '定义一个起始Range对象
                        Set rngEnd = sec.Range.Endnotes(intCount).Range    '定义一个结束Range对象
                        
                        rngStart.SetRange rngStart.Start - 1, rngEnd.End    '重新定义一个Range对象,为本节尾注区域
                        'orng.InsertAfter rngStart.Text    '插入尾注文本
                        rngStart.Copy
                        orng.Paste
                        
                        Call myReplace(orng, sec.Index, False)    '执行指定的查找与替换
                End If
            End If
        End With
    Next
   
    odoc.Fields.Update    '更新SEQ域
    odoc.Fields.Unlink
    Call 替换连续数字(ThisDocument, odoc)
    Application.ScreenUpdating = True    '恢复屏幕更新
End Sub



'如果文档有多节，且每节都有尾注，采用此文档

Sub 多节尾注转化为文本()
    Dim orng As Range, sec As Section
    Dim odoc As Document
    Dim intCount As Integer, rngStart As Range, rngEnd As Range
   
    Application.ScreenUpdating = False    '关闭屏幕更新
    Set odoc = Documents.Add    '新建一个文档
   
    For Each sec In ThisDocument.Sections    '本文档节中循环
        With sec
            '定义一个Range对象为新文档的文档结束标记前一个插入点位置
            Set orng = odoc.Range(odoc.Content.End - 1, odoc.Content.End - 1)
'            orng.InsertAfter sec.Range.Text    '插入节文本
            
            sec.Range.Copy
            orng.Paste
            
            
            If sec.Range.Endnotes.Count = 0 Then    '如果没有尾注
            Else
                Call myReplace(orng, sec.Index, True)    '执行指定的查找与替换
               
                ' 定义一个Range对象为新文档的文档结束标记前一个插入点位置
                Set orng = odoc.Range(odoc.Content.End - 1, odoc.Content.End - 1)
               
                '如果具有尾注分隔符
                If Asc(sec.Range.Endnotes.Separator.Text) = 3 Then
                        
                        '插入指定标记文本
'                        orng.InsertAfter "[line]" & Chr(13)
                        
                        '定义一个Range对象为新文档的文档结束标记前一个插入点位置
                        Set orng = odoc.Range(odoc.Content.End - 1, odoc.Content.End - 1)
                        
                        intCount = sec.Range.Endnotes.Count    '取得本节尾注数量
                        Set rngStart = sec.Range.Endnotes(1).Range    '定义一个起始Range对象
                        Set rngEnd = sec.Range.Endnotes(intCount).Range    '定义一个结束Range对象
                        
                        rngStart.SetRange rngStart.Start - 1, rngEnd.End    '重新定义一个Range对象,为本节尾注区域
'                        orng.InsertAfter rngStart.Text    '插入尾注文本
                        rngStart.Copy
                        orng.Paste
                        Call myReplace(orng, sec.Index, False)    '执行指定的查找与替换
                End If
            End If
        End With
    Next
    odoc.Fields.Update    '更新SEQ域
    Application.ScreenUpdating = True    '恢复屏幕更新
End Sub


'将orange中的阈替换为编号
'TF表示是否采用A还是B编号
'RC是为了生成域标志

Function myReplace(oRange As Range, RC As Integer, TF As Boolean)
    Dim txt1 As String, txt2 As String, txt As String
    Dim FieldRange As Range, wdNR As WdNumberingRule
    Dim doc As Document
   
    With ThisDocument
        wdNR = ThisDocument.Endnotes.NumberingRule    '取得尾注编号类型
        If wdNR = wdRestartContinuous Then    '继续编号
            txt1 = "SEQ A"
            txt2 = "SEQ B"
        ElseIf wdNR = wdRestartSection Then    '每节开始重新编号
            txt1 = "SEQ " & Chr(64 + RC)
            txt2 = "SEQ _" & Chr(64 + RC)
        End If
        
        Set FieldRange = ThisDocument.Range(0, 0)    '定义一个Range对象
        txt = VBA.IIf(TF = True, txt1, txt2)    '域代码文本
        
        ThisDocument.Fields.Add FieldRange, wdFieldEmpty, txt, False    '插入域
        
        FieldRange.SetRange 0, Len(txt) + 6    '重新定义Range对象,注意2003中的域标记长度为4而非2
        With FieldRange    '此处设置编号格式
            '        .Select'
            If (TF = True) Then
                .Font.Superscript = True    '上标
            End If
            .Font.Size = 10
            .Font.Name = "Times New Roman"    '字体
            .Cut
        End With
        With oRange.Find    '查找与替换
            .ClearFormatting
            .Execute findtext:="^2", replacewith:="^c", Replace:=wdReplaceAll
        End With
    End With
End Function


Sub 替换连续数字(refdoc As Document, doc As Document)
    Dim p As Paragraph, ch As String, s As String
    Dim i1 As Long, i2 As Long, i As Long
    Dim r As Range
    Dim np As Long
   
   
   
    For np = 1 To refdoc.Paragraphs.Count
    If (refdoc.Paragraphs(np).Range.Endnotes.Count > 1) Then
   
        i1 = -1
        i2 = -1
        For i = doc.Paragraphs(np).Range.Start To doc.Paragraphs(np).Range.End - 1
        
            If (doc.Range(i, i + 1).Text = "[") Then
                i1 = i + 1
            End If
            If (doc.Range(i, i + 1).Text = "]") Then
                i2 = i
                If (i1 > 0 And i2 > 0) Then
                    Set r = doc.Range(i1, i2)
                    
                    With r.Find    '查找与替换
                        .ClearFormatting
                        .Execute findtext:=r.Text, replacewith:=ns(r.Text), Replace:=wdReplaceAll
                    End With
                    
'                    Debug.Print r.Text
                    i1 = -1
                End If
            End If
            
        Next i
   
    End If
    Next np
        
        

End Sub



Function ns(s As String) As String

's = WorksheetFunction.Substitute(s, "：", ";")
's = WorksheetFunction.Substitute(s, "；", ";")
's = WorksheetFunction.Substitute(s, ":", ";")
's = WorksheetFunction.Substitute(s, ";", ";")

s = conNumStr(s, ",")
s = conNumStr(s, "，")
ns = s


'ns = WorksheetFunction.Substitute(ns, "基本项目;", "基本项目:")
'ns = WorksheetFunction.Substitute(ns, "特定项目;", "特定项目:")



End Function

Function conNumStr(s As String, flag As String) As String
Dim s2 As String
Dim i As Integer, j As Integer, n As Integer
Dim ib As Integer, ie As Integer
Dim num1 As Integer, num2 As Integer, nums As String, numstart As Integer
Dim ss(200) As String, nss As Integer, ss2(200) As String


'可以用Function Substitute(Arg1 As String, Arg2 As String, Arg3 As String, [Arg4]) As String进行字符替换

If (Right(s, 1) <> flag) Then s = s & flag
ib = 1
numstart = -1
nss = 0

num1 = 1
For i = 1 To Len(s)

    If (Mid(s, i, 1) = flag) Then
        nss = nss + 1
        ss(nss) = Mid(s, num1, i - num1)
        ss2(nss) = Mid(s, num1, i - num1)
        num1 = i + 1
'        Debug.Print ss(nss)
    End If
Next i



For i = 2 To nss - 1
If (IsNumeric(ss(i)) And IsNumeric(ss(i - 1)) And IsNumeric(ss(i + 1))) Then
If (ss(i - 1) + 1 = ss(i) And ss(i) + 1 = ss(i + 1)) Then
ss2(i) = "-"
End If
End If
Next i

s2 = ss2(1)
For i = 2 To nss
    If (Not (ss2(i) = "-" And ss2(i - 1) = "-")) Then
        If (ss2(i) = "-" Or ss2(i - 1) = "-") Then
            s2 = s2 & ss2(i)
        Else
            s2 = s2 & flag & ss2(i)
        End If
    End If
Next i

conNumStr = s2

End Function

涣若冰释

编译错误：方法和数据成员未找到

涣若冰释

这些代码怎么使用 啊

chendeyan126

守柔 发表于 2006-9-24 09:23
Function myReplace(oRange As Range, RC As Integer, TF As Boolean)&nbsp;&nbsp;&nbsp; Dim FieldText1 A ...

谢谢，非常有用。
但原文档的格式丢失了。