vbscript 批量改缩写

Posted 2021-05-21

sub supAbrr
Dim i As Integer
Dim fso, f, jp, jo As Object
Dim nr, aimT, Keys, value, value1, value2 As String
Dim json
Dim myrange As New myrange
Dim rng, wrd As Range

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("C:\haha.json")
nr = f.ReadAll
f.Close

' Convert the string to JSON data

Set json = CreateObject("Scripting.Dictionary")
Set json = JsonConverter.ParseJson(nr)

ActiveDocument.AcceptAllRevisions
ActiveDocument.TrackRevisions = False
ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions

' replace special parse

Set rng = myrange.refPart
rng.Select
Call specialJournalName1(Selection.Range, "New England", "N. Engl.")
Call specialJournalName1(Selection.Range, "New York", "N. Y.")
Call specialJournalName1(Selection.Range, "New Zealand", "N. Z.")

'italic space and year

With Selection.Range.Find
    .Text = "[0-9]{4}"
    .MatchWildcards = True
    .Font.Bold = True
    .Replacement.Font.Italic = True
    .Execute Replace:=wdReplaceAll
End With
With Selection.Range.Find
    .Text = " "
    .MatchWildcards = True
    .Replacement.Font.Italic = True
    .Execute Replace:=wdReplaceAll
End With

' begin replace abbr
Call layout_search_replace.jump_to_reference_section
With Selection.Find
    .ClearFormatting
    .Text = "[A-Z]*[0-9]{4}"
    .Forward = True
    .Font.Italic = True
    .MatchWildcards = True
    .Wrap = wdFindStop
    Do
        .Execute
        If .Found Then
            If Selection.Range.Characters(Len(Selection.Range.Text) - 2).Bold = -1 Then
                If Selection.Range.Words.count > 2 Then
                    Selection.MoveLeft wdCharacter, 4, wdExtend
                    
                    For Each wrd In Selection.Range.Words
                        
                        If Trim(wrd.Text) <> ". " And wrd.Next <> "." Then
                            
                            value = JsonConverter.ConvertToJson(json(FunctionGroup.convertUpper(Trim(wrd.Text))))
                            If InStr(value, """") > 0 Then
                                value = Mid(value, 2, Len(value) - 2)
                            End If
                            
                            Select Case value
                                
                                Case " "
                                wrd.Text = ""
                                GoTo kr
                                
                                Case "n.a."
                                GoTo kr
                                
                                Case ""
                                For i = Len(Trim(wrd.Text)) To 3 Step -1
                                    value1 = JsonConverter.ConvertToJson(json(Left(FunctionGroup.convertUpper(Trim(wrd.Text)), i) + "-"))
                                    value2 = JsonConverter.ConvertToJson(json(Left(FunctionGroup.convertUpper(Trim(wrd.Text)), i)))
                                    
                                    'remove double quatation
                                    If InStr(value1, """") > 0 Then
                                        value1 = Mid(value1, 2, Len(value1) - 2)
                                    End If
                                    If InStr(value2, """") > 0 Then
                                        value2 = Mid(value2, 2, Len(value2) - 2)
                                    End If
                                    'end
                                    
                                    If value1 = "n.a." Or value2 = "n.a." Then
                                        GoTo kr
                                    End If
                                    
                                    If value1 <> "" Then
                                        wrd.Text = FunctionGroup.convertUpper(CStr(value1)) + " "
                                        GoTo kr
                                    End If
                                    
                                    If value2 <> "" Then
                                        wrd.Text = FunctionGroup.convertUpper(value2) + " "
                                        GoTo kr
                                    End If
                                    
                                Next i
                                
                                Case Else
                                wrd.Text = FunctionGroup.convertUpper(CStr(value)) + " "
                                GoTo kr
                            End Select
                        End If
                        kr:
                        
                    Next
                    
                End If
            End If
        Else
            Exit Do
        End If
        Selection.MoveDown wdParagraph, 1
    Loop
End With

'no italic year and space
rng.Select
With Selection.Find
    .Text = "[0-9]{4}"
    .MatchWildcards = True
    .Font.Bold = True
    .Replacement.Font.Italic = False
    .Execute Replace:=wdReplaceAll
End With

With Selection.Find
    .Text = " "
    .MatchWildcards = True
    .Replacement.Font.Italic = False
    .Execute Replace:=wdReplaceAll
End With
MsgBox "done"
End Sub