Word参考文献著录VBA代码在64位情况下不能正常使用

sjh315

• VBA代码功能简述
  

1、在文中需要插入引文的位置输入“[]”，并对“[]”进行批注，批注为文献著录，以@开头，例如@何龄修.读南明史[J].中国史研究，1998,(3):167-173.
2、在文中需要插入参考文献列表的位置输入"{bibliography}"
3、运行VBA后将按国标文后参考文献著录规则的顺序编码制完成参考文献引用和著录

• 问题描述
  

1、该VBA代码在如下平台运行正常：
Windows 7 32位 & Office 2013 32位
Windows 7 32位 & Office 2010 32位

2、该VBA代码在如下平台不能正常运行：
Windows 7 64位 & Office 2013 64位
Windows 7 64位 & Office 2013 32位

求修改VBA代码，使其能在64位系统下运行，下面两个网页不知道有没有帮助：
http://www.360doc.com/content/14/0905/15/251367_407249837.shtml
https://msdn.microsoft.com/en-us/library/office/ee691831%28v=office.14%29.aspx

• VBA代码
  

Function CollectionSort(ByRef oCollection As Collection, Optional bSortAscending As Boolean = True) As Long
    Dim lSort1 As Long, lSort2 As Long
    Dim vTempItem1 As Variant, vTempItem2 As Variant, bSwap As Boolean
    For lSort1 = 1 To oCollection.Count - 1
        For lSort2 = lSort1 + 1 To oCollection.Count
            If bSortAscending Then
                If oCollection(lSort1) > oCollection(lSort2) Then
                    bSwap = True
                Else
                    bSwap = False
                End If
            Else
                If oCollection(lSort1) < oCollection(lSort2) Then
                    bSwap = True
                Else
                    bSwap = False
                End If
            End If
            If bSwap Then
                'Store the items
                If VarType(oCollection(lSort1)) = vbObject Then
                    Set vTempItem1 = oCollection(lSort1)
                Else
                    vTempItem1 = oCollection(lSort1)
                End If
                 
                If VarType(oCollection(lSort2)) = vbObject Then
                    Set vTempItem2 = oCollection(lSort2)
                Else
                    vTempItem2 = oCollection(lSort2)
                End If
                 
                'Swap the items over
                oCollection.Add vTempItem1, , lSort2
                oCollection.Add vTempItem2, , lSort1
                'Delete the original items
                oCollection.Remove lSort1 + 1
                oCollection.Remove lSort2 + 1
            End If
        Next
    Next
End Function

Function GetResult(ByRef arr As Collection)
    CollectionSort arr
    Dim result As String
    flag = False
    For i = 1 To arr.Count
        If i = arr.Count Then
            result = result & "[" & arr(i) & "]"
            Exit For
        End If
        If flag = False Then
            result = result & "[" & arr(i)
            If arr(i) + 1 = arr(i + 1) Then
                flag = True
                result = result & "-"
            Else
                result = result & "]"
            End If
        Else
            If arr(i) + 1 = arr(i + 1) Then
                If i + 1 = arr.Count Then
                    result = result & arr(i + 1) & "]"
                    Exit For
                End If
            Else
                result = result & arr(i) & "]"
            End If
        End If
    Next
    GetResult = result
End Function

Sub InsBib()   
    With Selection.Find '查找"{bibliography}"以确定参考文献列表插入位置
        .Text = "{bibliography}" '文档中表明插入参考文献列表位置的语句
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Dim result As Range '记录插入参考文献列表位置
    Set result = Selection.Range
    result.Text = ""
    Dim c As Comment
    Dim dic As Object '保存已经出现过的参考文献
    Set dic = CreateObject("Scripting.Dictionary")
    i = 0 '记录标号
    For Each c In ActiveDocument.Comments
        If c.Scope.Text = "[]" Then
            c.Scope.Text = ""
            Dim p As Paragraph
            Dim indexs As Collection
            Set indexs = New Collection
            For Each p In c.Range.Paragraphs
                If Left(p.Range.Text, 1) = "@" Then
                    If Not dic.Exists(p.Range.Text) Then
                        i = i + 1
                        dic(p.Range.Text) = i
                        result.Text = result.Text & "[" & dic(p.Range.Text) & "]" &VBTAB & Right(p.Range.Text, Len(p.Range.Text) - 1)
                    End If
                    indexs.Add dic(p.Range.Text)
                End If
            Next
            c.Scope.Select
            Selection.Text = GetResult(indexs)
            Selection.Font.Superscript = wdToggle
            c.Delete
        End If   
End Sub