Word 使用宏根据文件名实现文件版本号自动更新_rev02

继续更新宏代码，实现文档页眉/页脚所有相关文件信息的自动更新和自动插入。

Modules文件doku.bas代码：

Attribute VB_Name = "Doku"
Option Explicit

Public posIssueNo As Byte

Sub Update()
'
' NS_New Macro
' Macro created 03/08/2012 by Vico Song
'
    ''''''''''''''''''''''''''''''''''''''''''''
    ''' Define variables  ''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''
    Dim vAuthors, vCheckers, v As Variant
    Dim b As Boolean
    Dim s As String
    
    ''''''''''''''''''''''''''''''''''''''''''''
    ''' Initial variables  '''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''
    ''' Add author to the list below (prepared/modified)
    vAuthors = Array("Luke Wang", _
                    "Vico Song", _
                    "Joey Yang")
    ''' add checker to the list below (checked/released)
    vCheckers = Array("Jason Li", _
                    "Kino Zhang", _
                    "Larry Yu", _
                    "Luke Wang", _
                    "Sean Lee", _
                    "Kupfer M.")

    Call Init(True)
    
    ''''''''''''''''''''''''''''''''''''''''''''
    ''' Initial components of frm_docInput   '''
    ''''''''''''''''''''''''''''''''''''''''''''
    b = False
    s = ActiveDocument.CustomDocumentProperties("_Prepared/Modified")
    frm_docInput.cmb_Author.Clear
    For Each v In vAuthors
        frm_docInput.cmb_Author.AddItem (v)
        ''' set current default property value as combo box default value
        If v = s Then
            frm_docInput.cmb_Author.Value = v
            b = True
        End If
    Next
    ''' If current value of document property does not exist in the list,
    ''' add it into list and set it as combo box default value
    If Not b Then
        frm_docInput.cmb_Author.AddItem (s)
        frm_docInput.cmb_Author.Value = s
    End If
    
    b = False
    s = ActiveDocument.CustomDocumentProperties("_Checked/Released")
    frm_docInput.cmb_Checker.Clear
    For Each v In vCheckers
        frm_docInput.cmb_Checker.AddItem (v)
        ''' set current default property value as combo box default value
        If v = s Then
            frm_docInput.cmb_Checker.Value = v
            b = True
        End If
    Next
    ''' If current value of document property does not exist in the list,
    ''' add it into list and set it as combo box default value
    If Not b Then
        frm_docInput.cmb_Checker.AddItem (s)
        frm_docInput.cmb_Checker.Value = s
    End If

    s = ActiveDocument.CustomDocumentProperties("_pmDate")
    v = Date
    frm_docInput.cmb_pmDate.Clear
    If Not v = s Then frm_docInput.cmb_pmDate.AddItem (v)
    frm_docInput.cmb_pmDate.AddItem (s)
    frm_docInput.cmb_pmDate.Value = s
    
    s = ActiveDocument.CustomDocumentProperties("_crDate")
    v = Date
    frm_docInput.cmb_crDate.Clear
    If Not v = s Then frm_docInput.cmb_crDate.AddItem (v)
    frm_docInput.cmb_crDate.AddItem (s)
    frm_docInput.cmb_crDate.Value = s
    
    frm_docInput.txt_docNo = Left(ActiveDocument.Name, posIssueNo - 2)
    frm_docInput.txt_issueNo = Mid(ActiveDocument.Name, posIssueNo, 2)

    frm_docInput.Show
End Sub
Public Sub Init(ByVal b As Boolean)
    If Not b Then
        Exit Sub
    End If
    ''''''''''''''''''''''''''''''''''''''''''''
    ''' Define variables  ''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''
    Dim i, lenDocName As Integer
    Dim vProperties, vDefaultPropertyValue As Variant
    
    ''''''''''''''''''''''''''''''''''''''''''''
    ''' Initial variables  '''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''
    vProperties = Array("_DocuName", _
                    "_IssueNumber", _
                    "_Prepared/Modified", _
                    "_Checked/Released", _
                    "_pmDate", _
                    "_crDate")
    vDefaultPropertyValue = Array("DD***xXXXXExx", _
                    "xx", _
                    "_AUTHOR_", _
                    "_CHECKER_", _
                    Date, _
                    Date)

    ''' Check the document name
    lenDocName = Len(ActiveDocument.Name)
    If lenDocName < 21 Then
        MsgBox ("E01: The file name is not defined by NEW or COPE numbering system!")
        End
    End If
    
    If UCase(Left(ActiveDocument.Name, 2)) = "DD" And _
      UCase(Mid(ActiveDocument.Name, 9, 1)) = "E" And _
      IsNumeric(Mid(ActiveDocument.Name, 10, 2)) And _
      IsNumeric(Mid(ActiveDocument.Name, 13, 2)) Then
        posIssueNo = 13 ''' Numbering System NEW
    ElseIf UCase(Left(ActiveDocument.Name, 2)) = "DD" And _
      UCase(Mid(ActiveDocument.Name, 11, 1)) = "E" And _
      IsNumeric(Mid(ActiveDocument.Name, 12, 2)) And _
      IsNumeric(Mid(ActiveDocument.Name, 15, 2)) Then
        posIssueNo = 15 ''' Numbering System COPE
    Else
        MsgBox ("E02: The file name is not defined by NEW or COPE numbering system!")
        End
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''
    ''' Check and create document properties '''
    ''''''''''''''''''''''''''''''''''''''''''''
    If UBound(vProperties) = UBound(vDefaultPropertyValue) Then
        For i = 0 To UBound(vProperties)
            Call CreateProperty(vProperties(i), vDefaultPropertyValue(i))
        Next
    Else
        MsgBox ("Error!!!" & vbCrLf & vbCrLf & "Please check VBA code!" & vbCrLf & vbCrLf & _
            "Tip: UBound(vProperties) != UBound(vDefaultPropertyValue)")
        Exit Sub
    End If
End Sub

Public Sub CreateProperty(ByVal sPropertyName As String, ByVal sDefaultValue As String)
'
' CreateProperty Macro
' Macro created 03/08/2012 by Vico Song
'
    Dim b As Boolean
    Dim p As DocumentProperty
    
    b = False
    ''' Check all existed properties, if current property already exist
    For Each p In ActiveDocument.CustomDocumentProperties
        If p.Name = sPropertyName Then b = True
    Next

    ''' If current property does not exist, create.
    If Not b Then
        ActiveDocument.CustomDocumentProperties.Add _
            Name:=sPropertyName, LinkToContent:=False, Value:=sDefaultValue, _
            Type:=msoPropertyTypeString
    End If
End Sub


Sub ShowAll()
'
' ShowAll Macro
' Macro created 02/29/2012 by songv
'
    ActiveWindow.View.ShowAll = True
End Sub
Sub HideAll()
'
' ShowAll Macro
' Macro created 02/29/2012 by songv
'
    ActiveWindow.View.ShowAll = False
End Sub

Sub AutoInsert()
    Dim myRange As Range
    Dim i, iCounter As Long
    Dim v As Variant
    
    Call Init(True)
    
    On Error GoTo errHandler
    Application.ScreenUpdating = False
    ''' check if there is table in wdFirstPageFooterStory
    iCounter = 0
    On Error GoTo continue01
    For Each v In ActiveDocument.StoryRanges(wdFirstPageFooterStory).Tables
        iCounter = iCounter + 1
    Next
continue01:
    If iCounter < 1 Then
        MsgBox "Error: There is no table in wdFirstPageFooterStory!"
        End
    End If
    On Error GoTo errHandler
    ''' issue number table cell of wdFirstPageFooterStory
    Set myRange = ActiveDocument.StoryRanges(wdFirstPageFooterStory).Tables(1).Cell(2, 1).Range
    myRange.Select
    myRange.Text = "Issue No."
    myRange.InsertParagraphAfter
    myRange.InsertParagraphAfter
    myRange.InsertParagraphAfter '''insert one more paragraph to avoid select the last paragraph
    myRange.Paragraphs(1).Range.Font.Italic = True
    myRange.Paragraphs(2).Range.Font.Size = 5
    myRange.Paragraphs(3).Range.Font.Bold = True
    myRange.Paragraphs(3).Range.Select
'    myRange.Paragraphs(3).Range.Text = ""
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _IssueNumber ", PreserveFormatting:=True

    ''' prepared/modified table cell
    Set myRange = ActiveDocument.StoryRanges(wdFirstPageFooterStory).Tables(1).Cell(2, 2).Range
    myRange.Select
    myRange.Text = "prepared/modified"
    myRange.InsertParagraphAfter
    myRange.InsertParagraphAfter
    myRange.Paragraphs(1).Range.Font.Italic = True
    myRange.Paragraphs(2).Range.Font.Italic = False
    myRange.Paragraphs(2).Range.Font.Bold = True
    myRange.Paragraphs(2).Range.Select
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _pmDate ", PreserveFormatting:=True
    myRange.InsertParagraphAfter
    myRange.InsertParagraphAfter
    myRange.Paragraphs(3).Range.Font.Bold = True
    myRange.Paragraphs(3).Range.Font.Italic = False
    myRange.Paragraphs(3).Range.Select
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _Prepared/Modified ", PreserveFormatting:=True
        
    ''' checked/released table cell
    Set myRange = ActiveDocument.StoryRanges(wdFirstPageFooterStory).Tables(1).Cell(2, 3).Range
    myRange.Select
    myRange.Text = "checked/released"
    myRange.InsertParagraphAfter
    myRange.InsertParagraphAfter
    myRange.Paragraphs(1).Range.Font.Italic = True
    myRange.Paragraphs(2).Range.Font.Bold = True
    myRange.Paragraphs(2).Range.Font.Italic = False
    myRange.Paragraphs(2).Range.Select
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _crDate ", PreserveFormatting:=True
    myRange.InsertParagraphAfter
    myRange.InsertParagraphAfter
    myRange.Paragraphs(3).Range.Select
    myRange.Paragraphs(3).Range.Font.Bold = True
    myRange.Paragraphs(3).Range.Font.Italic = False
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _Checked/Released ", PreserveFormatting:=True

    ''' doc name table cell
    iCounter = 0
    On Error GoTo continue02
    ActiveDocument.StoryRanges(wdFirstPageFooterStory).Tables(1).Cell(3, 2).Range.Select
    For Each v In ActiveDocument.StoryRanges(wdFirstPageFooterStory).Tables(1).Cell(3, 2).Range.Paragraphs
        iCounter = iCounter + 1
    Next
continue02:
    If iCounter < 1 Then
        MsgBox "Error: There is no paragraph in Document No. cell!"
        End
    End If
    On Error GoTo errHandler
    Set myRange = ActiveDocument.StoryRanges(wdFirstPageFooterStory).Tables(1).Cell(3, 2).Range
    myRange.InsertParagraphAfter
    myRange.Paragraphs(iCounter).Range.Select
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _DocuName ", PreserveFormatting:=True

    ''' check if there is table in wdPrimaryHeaderStory
    iCounter = 0
    On Error GoTo continue03
    For Each v In ActiveDocument.StoryRanges(wdPrimaryHeaderStory).Tables
        iCounter = iCounter + 1
    Next
continue03:
    If iCounter < 1 Then
        MsgBox "Error: There is no table in wdPrimaryHeaderStory!"
        End
    End If
    On Error GoTo errHandler
    ''' doc name and issue number in headers
    Set myRange = ActiveDocument.StoryRanges(wdPrimaryHeaderStory).Tables(1).Cell(1, 1).Range
    myRange.Select
    myRange.Text = ""
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _DocuName ", PreserveFormatting:=True
    Selection.TypeText Text:="_"
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _IssueNumber ", PreserveFormatting:=True
    ''' check if there is table in wdEvenPagesHeaderStory
    iCounter = 0
    On Error GoTo continue04
    For Each v In ActiveDocument.StoryRanges(wdEvenPagesHeaderStory).Tables
        iCounter = iCounter + 1
    Next
continue04:
    If iCounter < 1 Then
        MsgBox "Error: There is no table in wdEvenPagesHeaderStory!"
        End
    End If
    On Error GoTo errHandler
    Set myRange = ActiveDocument.StoryRanges(wdEvenPagesHeaderStory).Tables(1).Cell(1, 2).Range
    myRange.Select
    myRange.Text = ""
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _DocuName ", PreserveFormatting:=True
    Selection.TypeText Text:="_"
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "DOCPROPERTY  _IssueNumber ", PreserveFormatting:=True
    
    ''' headers of sections more than 1
    iCounter = ActiveDocument.Sections.Count
    If iCounter > 1 Then
        Dim s As String
        Dim j As Integer
        
        Set myRange = ActiveDocument.Sections(1).Headers(wdHeaderFooterEvenPages).Range.Tables(1).Cell(1, 1).Range
        s = myRange.Text
        s = Left(s, Len(s) - 2)

        For i = 2 To iCounter
            ''' no DifferentFirstPageHeaderFooter from section 2
            ActiveDocument.Sections(i).PageSetup.DifferentFirstPageHeaderFooter = False
            ''' odd pages header
            Set myRange = ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 1).Range
            myRange.Select
            myRange.Text = ""
            Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "DOCPROPERTY  _DocuName ", PreserveFormatting:=True
            Selection.TypeText Text:="_"
            Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "DOCPROPERTY  _IssueNumber ", PreserveFormatting:=True
            Set myRange = ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 2).Range
            myRange.Select
            myRange.Text = ""
            Selection.TypeText Text:=s

            ''' even pages header
            Set myRange = ActiveDocument.Sections(i).Headers(wdHeaderFooterEvenPages).Range.Tables(1).Cell(1, 2).Range
            myRange.Select
            myRange.Text = ""
            Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "DOCPROPERTY  _DocuName ", PreserveFormatting:=True
            Selection.TypeText Text:="_"
            Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                "DOCPROPERTY  _IssueNumber ", PreserveFormatting:=True
            Set myRange = ActiveDocument.Sections(i).Headers(wdHeaderFooterEvenPages).Range.Tables(1).Cell(1, 1).Range
            myRange.Select
            myRange.Text = ""
            Selection.TypeText Text:=s
        Next
    End If
    ''' set word pane to normal mode
    ActiveWindow.Panes(1).Activate
    If ActiveWindow.View.SplitSpecial = wdPaneNone Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    Else
        ActiveWindow.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    Application.ScreenUpdating = True
    Exit Sub
errHandler:
    MsgBox Err.Description
    End
End Sub

Forms文件frm_docInput.frm文件代码：

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frm_docInput 
   Caption         =   "Input and check information"
   ClientHeight    =   4440
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4470
   OleObjectBlob   =   "frm_docInput.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "frm_docInput"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub btn_Cancel_Click()
    Unload Me
End Sub

Private Sub btn_OK_Click()
    Application.ScreenUpdating = False
    
    ActiveDocument.CustomDocumentProperties("_DocuName") = frm_docInput.txt_docNo.Value
    ActiveDocument.CustomDocumentProperties("_IssueNumber") = frm_docInput.txt_issueNo.Value
    ActiveDocument.CustomDocumentProperties("_Prepared/Modified") = frm_docInput.cmb_Author.Value
    ActiveDocument.CustomDocumentProperties("_Checked/Released") = frm_docInput.cmb_Checker.Value
    ActiveDocument.CustomDocumentProperties("_pmDate") = frm_docInput.cmb_pmDate.Value
    ActiveDocument.CustomDocumentProperties("_crDate") = frm_docInput.cmb_crDate.Value
    
    ActiveDocument.StoryRanges(wdFirstPageFooterStory).Fields.Update
    ActiveDocument.StoryRanges(wdEvenPagesHeaderStory).Fields.Update
    ActiveDocument.StoryRanges(wdPrimaryHeaderStory).Fields.Update
    
    Dim iCounter, i As Integer
    iCounter = ActiveDocument.Sections.Count
    If iCounter > 1 Then
        For i = 2 To iCounter
            ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Fields.Update
            ActiveDocument.Sections(i).Headers(wdHeaderFooterEvenPages).Range.Fields.Update
        Next
    End If
    
    Application.ScreenUpdating = True
    
    Unload Me
End Sub

窗体界面：