原创：实现word自定义新域及一键更新域

浪乘风 · 发表于 2008-9-26 14:13

Public Sub UpdateFields()
On Error Resume Next
ActiveWindow.View.ShowFieldCodes = False
fic = ActiveDocument.Fields.Count
For counts = 0 To fic - 1
coun = fic - counts
typ = ActiveDocument.Fields(coun).Type
If typ = 64 Then
zfc = ActiveDocument.Fields(coun).Code.Text
cfs = ActiveDocument.Fields(coun).Code.Fields.Count
If cfs > 0 Then
        ksb = Mid(zfc, ActiveDocument.Fields(coun).Code.Fields(1).Code.Start - ActiveDocument.Fields(coun).Code.Start, 1)
        jis = Mid(zfc, ActiveDocument.Fields(coun).Code.Fields(1).Code.End - ActiveDocument.Fields(coun).Code.Start + 1, 1)
        zfc = Replace(zfc, ksb, "{")
        zfc = Replace(zfc, jis, "}")

End If
For rs = 1 To cfs
zfc = Replace(zfc, "{" & ActiveDocument.Fields(coun).Code.Fields(rs).Code.Text & "}", ActiveDocument.Fields(coun).Code.Fields(rs).Result.Text)
Next rs
hanscc = Split(zfc, "\$")
If UBound(hanscc) > 0 Then
    hanscc(1) = Trim(hanscc(1))
    For s = 1 To 20
    hanscc(1) = Replace(hanscc(1), " ", " ")
    Next s
    hanscc(1) = Trim(Replace(hanscc(1), "\* MERGEFORMAT", ""))
    hanscs = Split(Mid(hanscc(1), 2, Len(hanscc(1)) - 2), ",")
    hansm = Trim(hanscs(0))
    hanscs(0) = ""
    hansc = Mid(Join(hanscs, ","), 2)

    If Right(hansm, 2) = "()" Then
       If UBound(hanscs) > 0 Then
         susc = Application.Run(Left(hansm, Len(hansm) - 2), hansc)
        Else
         susc = Application.Run(Left(hansm, Len(hansm) - 2))
        End If

     wdbl = Trim(Replace(UCase(hanscc(0)), "DOCVARIABLE", ""))
    Num = 0
    For Each aVar In ActiveDocument.Variables
         If aVar.Name = wdbl Then
                  Num = aVar.Index
                  Exit For
         End If
    Next aVar
    If Num = 0 Then
          ActiveDocument.Variables.Add Name:=wdbl, Value:=susc
    Else
         ActiveDocument.Variables(Num).Value = susc
    End If
    End If
    End If
End If
Next counts
ActiveDocument.Fields.Update

End Sub
Public Function choose(zf)
chooses = Split(zf, ",")
wz = Val(chooses(0))
cou = UBound(chooses)
If wz > cou Or wz = 0 Then
choose = " "
Else
choose = chooses(wz)
End If
End Function
Sub MailMergeNextRecord()
'
' MailMessageNext 宏
' 定位至下一个邮件
'
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
If ActiveDocument.MailMerge.DataSource.ActiveRecord < ActiveDocument.MailMerge.DataSource.RecordCount Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
Else
MsgBox "已经到达末记录!"
End If
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
UpdateFields
End Sub
Sub MailMergePrevRecord()
'
' MailMergePrevRecord 宏
' 显示当前邮件合并数据源的上一个记录
'
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
If ActiveDocument.MailMerge.DataSource.ActiveRecord <> ActiveDocument.MailMerge.DataSource.FirstRecord Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdPreviousRecord
Else
MsgBox "已经到达首记录!"
End If
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
UpdateFields
End Sub
Sub MailMergeFirstRecord()
'
' MailMergeFirstRecord 宏
' 显示当前邮件合并数据源中的首记录
'
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
UpdateFields

End Sub
Sub MailMergeLastRecord()
'
' MailMergeLastRecord 宏
' 显示当前邮件合并数据源中的末记录
'
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdLastRecord
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
UpdateFields

End Sub
如何使用？
例如：在ｗｏｒｄ文档中，插入文档变量域，文档变量任意指定，切换域代码，在代码的文档变量后,\* MERGEFORMAT之前添加\$"choose(),1,456,789,1236"，choose(),表示选择函数，1表示选择列表的第几个选项，456，789，1236表示选择列表。将上述宏代码复制到norml模板下的宏模块下面，就可以了。更新任意域，就可以完成整篇文档域的更新。

[此贴子已经被作者于2008-10-13 8:44:18编辑过]

浪乘风 · 发表于 2008-9-26 14:21

Public Sub new_command()
menucap = "更新域,邮件首记录,邮件上一个,邮件下一个,邮件末记录"
menuact = "update_fields,First_record,Previous_record,next_record,Last_record"
For i = 1 To CommandBars("Tools").Controls.Count
If Not CommandBars("Tools").Controls(i).BuiltIn Then
    CommandBars("Tools").Controls(i).Delete
End If
Next i
menuca = Split(menucap, ",")
menuac = Split(menuact, ",")
For i = 0 To UBound(menuca)
Set newItem = CommandBars("Tools").Controls.Add(Type:=msoControlButton)
With newItem
    .BeginGroup = False
    .Caption = menuca(i)
    .FaceId = 0
    .OnAction = menuac(i)
End With
Next i
End Sub
Public Function update_fields()
fic = ActiveDocument.Fields.Count
For coun = 1 To fic
typ = ActiveDocument.Fields(coun).Type
If typ = 81 Then
sh = ActiveDocument.Fields(coun).Code.Fields.Count
zfc = ActiveDocument.Fields(coun).Code.Text
    If sh > 0 Then
        wb = ""
        ksb = Mid(zfc, ActiveDocument.Fields(coun).Code.Fields(1).Code.Start - ActiveDocument.Fields(coun).Code.Start, 1)
        jis = Mid(zfc, ActiveDocument.Fields(coun).Code.Fields(1).Code.End - ActiveDocument.Fields(coun).Code.Start + 1, 1)
        For st = 1 To sh
             wb = Replace(zfc, ActiveDocument.Fields(coun).Code.Fields(st).Code.Text, ActiveDocument.Fields(coun).Code.Fields(st).Result)
          Next st
          wb = Replace(wb, ksb, "")
          wb = Replace(wb, jis, "")
      Else
        wb = ActiveDocument.Fields(coun).Code.Text
    End If

texs = Split(Trim(Replace(UCase(wb), "ADDIN", "")), ",")
hansm = texs(0)
texs(0) = ""
hansc = Mid(Join(texs, ","), 2)
su = Application.Run(hansm, hansc)
    If coun + sh < fic Then
          typ = ActiveDocument.Fields(coun + sh + 1).Type
          stas = ActiveDocument.Fields(coun + sh + 1).Code.Start
    Else
          typ = 0
          stas = 0
    End If
           If (typ = 35 Or typ = -1) And stas = ActiveDocument.Fields(coun).Code.End + 2 Then
                      ActiveDocument.Fields(coun + sh + 1).Code.Text = " QUOTE " & """" & su & """" & " \* MERGEFORMAT"
                Else
                    Set Range1 = ActiveDocument.Range(ActiveDocument.Fields(coun).Code.End + 1, ActiveDocument.Fields(coun).Code.End + 1)
                    Set myField = ActiveDocument.Fields.Add(Range:=Range1, Type:=wdFieldEmpty, Text:=" QUOTE " & """" & su & """")
                    fic = fic + 1

            End If

End If
Next coun
ActiveDocument.Fields.Update
End Function
Public Function choose(zf)
chooses = Split(zf, ",")
wz = Val(chooses(0))
cou = UBound(chooses)
If wz > cou Or wz = 0 Then
choose = ""
Else
choose = chooses(wz)
End If
End Function
Public Function next_record()
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
If ActiveDocument.MailMerge.DataSource.ActiveRecord < ActiveDocument.MailMerge.DataSource.RecordCount Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
Else
MsgBox "已经到达末记录!"
End If
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
update_fields
End Function
Public Function Previous_record()
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
If ActiveDocument.MailMerge.DataSource.ActiveRecord <> ActiveDocument.MailMerge.DataSource.FirstRecord Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdPreviousRecord
Else
MsgBox "已经到达首记录!"
End If
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
update_fields
End Function
Public Function First_record()
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
update_fields
End Function
Public Function Last_record()
If ActiveDocument.MailMerge.DataSource.RecordCount > -1 Then
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdLastRecord
Else
MsgBox "当前文档没有附加邮件合并数据源！"
End If
update_fields
End Function

FENGJUN · 发表于 2012-4-28 10:59

不错，顶一下

loquat · 发表于 2013-7-30 14:02

这里是自己建立了一个新域word中没有的域？

xyz74sc · 发表于 2013-7-31 09:30

我也被标题骗了，不是新的，word中没有的域

474335950 · 发表于 2013-7-31 10:45

我的天涯，这么博大精深

romanina · 发表于 2018-1-13 23:38

mark。研究一下。

		自动登录	找回密码
密码			免费注册