Cacher is the code snippet organizer for pro developers

Sub Sort1_InsertRefTemp()
    Dim myRan As Range
    Dim i As Long, p As Long
    Dim strtemp As String
    
    Application.ScreenUpdating = False

    If selection.Range = "" Then
        MsgBox "No text selected! Please select all reference entries."
        Exit Sub
    ElseIf MsgBox("Have you selected every reference item in the document?", vbYesNo) = vbNo Then
        Exit Sub
    End If

    ActiveDocument.Content.HighlightColorIndex = wdNoHighlight
    Set myRan = selection.Range
    selection.collapse Direction:=wdCollapseStart
    p = myRan.Paragraphs.count

    For i = 1 To p
        myRan.Paragraphs(i).Range.Words(1).Select
        selection.collapse (wdCollapseEnd)
        ActiveDocument.Bookmarks.Add Range:=selection.Range, _
                                     name:="refTemp" & i
    Next
    
    MsgBox p & " bookmarks added. Proceed to step 2 please.", vbInformation

End Sub
Sub liyuan_decl_foot()
selection.Paragraphs(1).Alignment = wdAlignParagraphJustify
  selection.ParagraphFormat.LeftIndent = CentimetersToPoints(0.75)
  selection.ParagraphFormat.RightIndent = CentimetersToPoints(0.75)
End Sub
Sub liyuan_decl_one_foot()
selection.Paragraphs(1).Alignment = wdAlignParagraphCenter
End Sub


Sub Sort2_NumCrossRef()
    'On Error Resume Next
    ActiveWindow.View.ShowRevisionsAndComments = False
    Dim strtemp As String, i As Integer
    i = 0
    selection.HomeKey wdStory
    
    With selection.Find
        .ClearFormatting
        .Text = "<[0-9]@>"
        .MatchWildcards = True
        .Highlight = True
        .Wrap = wdFindStop
        .Replacement.Text = ""
        .Execute
    End With

    Do While selection.Find.Found
        i = i + 1
        strtemp = selection.Text
        selection.InsertCrossReference ReferenceType:=wdRefTypeBookmark, ReferenceKind:= _
                                       wdNumberNoContext, ReferenceItem:="refTemp" & strtemp, _
                                       InsertAsHyperlink:=True
        selection.Find.Execute
    Loop
 
    MsgBox "Cross-reference added for " & i & " items.", vbInformation

End Sub
Sub Sort3_RearrangeTheRefs()


    Dim sCompare As String
    Dim aNum() As String, bNum() As String
    Dim i As Long, laCount As Long, lbCount As Long

    Application.ScreenUpdating = False
    Application.ActiveWindow.View.ShowFieldCodes = True
    ' Collect the cite numbers in the paper
    With ActiveDocument
        For i = 1 To .Fields.count
            If .Fields(i).Type = wdFieldRef And _
               InStr(.Fields(i).Code.Text, "refTemp") > 0 Then
                ReDim Preserve aNum(laCount)
                aNum(laCount) = PickNum(.Fields(i).Code.Text)
                laCount = laCount + 1
            End If
        Next i
    End With

    ' Delete duplicate cite numbers

    For i = LBound(aNum) To UBound(aNum)
        If Not InStr(sCompare, "*" & aNum(i) & "#") > 0 Then
            ReDim Preserve bNum(lbCount)
            bNum(lbCount) = aNum(i)
            lbCount = lbCount + 1
        End If
        sCompare = sCompare & "*" & aNum(i) & "#"
    Next

    selection.EndKey wdStory
    selection.TypeText Text:=vbCrLf
    selection.TypeParagraph

    For i = LBound(bNum) To UBound(bNum)
        With selection
            ActiveDocument.Bookmarks("refTemp" & bNum(i)).Range.Paragraphs(1).Range.Select
            .Cut
            .EndKey Unit:=wdStory
            .Paste
        End With
    Next
    Application.ActiveWindow.View.ShowFieldCodes = False
    With selection
        .WholeStory
        .Fields.Update
        .EndKey Unit:=wdStory
    End With
    MsgBox "Check if the references are in good order now." & vbCrLf & vbCrLf & _
            "If necessary, delete redundant reference entry and refresh all field codes throughout the document.", vbInformation

End Sub

Function PickNum(strtemp As String) As String

    Dim i As Long, j As Long, s As String
    For i = 1 To Len(strtemp)
        For j = 48 To 57
            If Mid(strtemp, i, 1) = Chr(j) Then
            PickNum = PickNum & Chr(j)
            End If
        Next
    Next

End Function




Sub DeleteReftempBookMarks()

    Call layout_tools.track_changes_and_show_final
    
    Dim bkm As Bookmark, i As Long, f As Field
    '删除书签
'    For Each bkm In ActiveDocument.Bookmarks
'        If InStr(1, bkm.name, "refTemp", vbBinaryCompare) > 0 Then
'            bkm.Delete
'            i = i + 1
'        End If
'    Next

    'remove field code for ref text call-out
    For Each f In ActiveDocument.Fields
         If InStr(f.Code.Text, " REF refTemp") > 0 Then f.unlink
    Next
    
    selection.HomeKey wdStory
    With selection.Find
        .ClearFormatting
        .Highlight = True
        .Text = "["
        .Replacement.Text = ""
        .MatchWildcards = False
        .Wrap = wdFindContinue
        Do
            .Execute
            If .Found Then
                selection.MoveEndWhile ("0123456789,")
                If selection.Next(wdCharacter, 1) = "]" And selection.Characters.count > 1 Then
                    selection.MoveEnd wdCharacter, 1
                    If Len(selection.Text) - Len(Replace(selection.Text, ",", "")) > 1 Then
                        'do not send to this function if number of , in string is less than 2
                        selection.Text = collapse_reference_call_out(selection.Text)
                    End If
                    selection.Range.HighlightColorIndex = wdNoHighlight
                End If
                selection.collapse wdCollapseEnd
            Else
                Exit Do
            End If
        Loop
    End With

    Call layout_validator.finish_validate_command_ui_change
    MsgBox "Deleted " & i & " ""refTemp"" bookmarks in total. Cross-referenced fields unlinked. All highlight removed." & vbCrLf & vbCrLf _
            & "Call-out collapse complete. Please check through the individual entries.", vbInformation, "All cleaned up"

End Sub

Function collapse_reference_call_out(refstr As String)
    Dim refs As Variant, i As Integer, j As Integer
    refs = Split(Replace(Mid(refstr, 2, Len(refstr) - 2), " ", ""), ",")
    ' may need to sort all individual refs, bubbling algorithm
    For i = LBound(refs) To UBound(refs)
        For j = 1 To UBound(refs) - i
            If CInt(refs(j - 1)) > CInt(refs(j)) Then
                swap = refs(j)
                refs(j) = refs(j - 1)
                refs(j - 1) = swap
            End If
        Next j
    Next i

    refstr = "[" & refs(0)
    For i = LBound(refs) + 1 To UBound(refs) - 1
        If CInt(refs(i)) = CInt(refs(i - 1)) + 1 And CInt(refs(i)) + 1 = CInt(refs(i + 1)) Then
            If Right(refstr, 1) <> ChrW(8211) Then refstr = refstr & ChrW(8211)
        Else
            refstr = refstr & IIf(Right(refstr, 1) <> ChrW(8211), "," & refs(i), refs(i))
        End If
    Next i

    If Right(refstr, 1) <> ChrW(8211) Then refstr = refstr & ","
    refstr = refstr & refs(UBound(refs)) & "]"
    collapse_reference_call_out = refstr

End Function



Sub HighlightAndExpand()



    ActiveWindow.View.ShowRevisionsAndComments = False
    ActiveWindow.View.ShowFieldCodes = False
    selection.HomeKey wdStory
    With selection.Find
        .ClearFormatting
        '.Text = "\[[0-9^=,]@\]"
        'change to find [ and moveuntil, in case the number bears a field code
        .Text = "["
        .Replacement.Text = ""
        .MatchWildcards = False
        .Wrap = wdFindContinue
        Do
            .Execute
            If .Found Then
                selection.MoveEndWhile ("0123456789," & ChrW(8211))
                If selection.Next(wdCharacter, 1) = "]" And selection.Characters.count > 1 Then
                    selection.MoveEnd wdCharacter, 1
                    If InputBox("Is this a reference call-out?", "Possible Reference Call-out Detected", "yes", 300, 300) = "yes" Then
                       
                        selection.Text = ExpandRefNum(selection.Text)
                        selection.Range.HighlightColorIndex = wdYellow
                    End If
                End If
                selection.collapse wdCollapseEnd
            Else
                Exit Do
            End If
        Loop
    End With
    MsgBox "Call-out expansion complete.", vbInformation
End Sub

Function ExpandRefNum(strtemp As String) As String
'Expand normal ref numbers , like: [1,2,4-5] [9,5,7,8]
'To [1,2,4,5] [5,7,8,9]

    Dim aRefList() As String
    Dim i As Long

    strtemp = Replace(strtemp, " ", "")
    strtemp = Mid(strtemp, 2, Len(strtemp) - 2)
    aRefList = Split(strtemp, ",")
    For i = LBound(aRefList) To UBound(aRefList)
        If CStr(Val(aRefList(i))) <> aRefList(i) Then aRefList(i) = FullRefRange(aRefList(i))
    Next
    ExpandRefNum = "[" & Join(aRefList, ",") & "]"

End Function


Function FullRefRange(strtemp As String) As String
'Expand numbers within hyphen or en dash , like this: 35-36 or 36-35 or 1-4
'To 35,36 or 35,36 or 1,2,3,4

    Dim i As Long, sRefNum As String
    Dim aRefNum() As String
    Dim lStart As Long, lEnd As Long

    For i = 1 To Len(strtemp)
        If IsNumeric(Mid(strtemp, i, 1)) Then
            sRefNum = sRefNum & Mid(strtemp, i, 1)
        Else

            sRefNum = sRefNum & "-"
        End If
    Next
    aRefNum = Split(sRefNum, "-")
    lStart = CLng(aRefNum(LBound(aRefNum)))
    lEnd = CLng(aRefNum(UBound(aRefNum)))
    For i = MIN(lStart, lEnd) To MAX(lStart, lEnd)
        FullRefRange = FullRefRange & "," & i
    Next
    FullRefRange = Right(FullRefRange, Len(FullRefRange) - 1)

End Function

Function MIN(a As Long, b As Long) As Long

    If a <= b Then
        MIN = a
    Else
        MIN = b
    End If

End Function

Function MAX(a As Long, b As Long) As Long

    If a >= b Then
        MAX = a
    Else
        MAX = b
    End If

End Function