vbscript 1.检测字里面作者名和邮箱是否跟管理平台上面一致

Posted 2021-05-21

Sub checkConsistRedmineAuthorMail()
    '首先拿到word里面的作者名和邮箱
Dim wordAuthor, wordMail, RedmineAE As String
Dim Author, Email
Dim i, j As Integer
wordAuthor = thisAuthors
wordMail = thisMail
 '拿到redmind上的作者名和邮箱
RedmineAE = getRedmineAuthorEmail
Author = Split(wordAuthor, ",")
Email = Split(wordMail, " ")
For i = LBound(Author) To UBound(Author)
    If InStr(RedmineAE, Author(i)) = 0 Then
        gotoSelectionAddComment (CStr(Author(i)))
    End If
Next

For j = LBound(Email) To UBound(Email)
    If InStr(RedmineAE, Email(j)) = 0 Then
        gotoSelectionAddComment (CStr(Email(j)))
        
    End If
Next
End Sub
Function getRedmineAuthorEmail() As String
On Error GoTo kr
Dim ie
Dim doc
Dim element
Dim htMent
Dim htmlDoc
Dim FT
    
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = False
    ie.Navigate "https://redmine.mdpi.com"
    Do Until ie.ReadyState = 4
    Loop
    Set htmlDoc = ie.Document
    
    Set doc = ie.Document
    Set element = doc.getElementsByName("username")
    element.Item(0).value = "[e-mail]"
    Set element = doc.getElementsByName("password")
    element.Item(0).value = "KR7860328"
    Set element = doc.getElementsByName("login")   '填写用户名密码 并单击提交 登录
    element.Item(0).Click

delay (300)
'获取稿子ID
kr:
    ie.Navigate "https://redmine.mdpi.com/search?q=" + WordId
    Do Until ie.ReadyState = 4
    Loop

Do Until ie.Busy = False
   DoEvents
Loop

htMent = ie.Document.getElementById("search-results").innerHTML
FT = getLayoutId(CStr(htMent))

'获取作者名字
ie.Navigate "https://redmine.mdpi.com/issues/" + FT
    Do Until ie.ReadyState = 4
    Loop
    
Do Until ie.Busy = False
   DoEvents
Loop

aimT = ie.Document.getElementById("content").innerHTML
AuthorEmail = getLayoutAuthorEmail(CStr(aimT))
getRedmineAuthorEmail = onlineAuthorName(CStr(AuthorEmail))

ie.Quit
Set element = Nothing
Set doc = Nothing
Set ie = Nothing
End Function
Function getLayoutId(str As String) As String
    Dim reg As New RegExp
    Dim matches
    With reg
        .Global = True
        .Pattern = "[Ll]ayout.+? #(\d+) "
        Set matches = .Execute(str)
    End With
    getLayoutId = matches(0).SubMatches(0)
End Function
Function getLayoutAuthorEmail(str As String) As String
    Dim reg As New RegExp
    Dim matches
    With reg
        .Global = True
        .Pattern = "Authors:.+?<br"
        Set matches = .Execute(str)
    End With
    getLayoutAuthorEmail = matches(0)
End Function
Function WordId() As String
    arr = Split(ActiveDocument.name, "-")
    WordId = arr(0) + "-" + arr(1)
End Function
Function onlineAuthorName(str As String) As String
    Dim reg As New RegExp
    With reg
        .Global = True
        .Pattern = "<.+?>"
    onlineAuthorName = .Replace(str, "")
    End With
End Function
Function thisAuthors() As String
Dim matches
Dim t As String
Dim reg As New RegExp
 t = Replace(ActiveDocument.Paragraphs(3).Range.Text, ChrW(11), "")

 If InStr(t, ", ") = 0 Then '一个作者
 
    If InStr(t, " and ") = 0 Then '一个作者
       thisAuthors = Left(t, Len(t) - 2) + ","
    Else   '两个作者
        With reg
            .Global = True
            .Pattern = " [^ ]+? and "
             thisAuthors = .Replace(t, " ")
             thisAuthors = thisAuthors + ","
        End With
    End If
    
Else '两个以上作者
        With reg
            .Global = True
            .Pattern = " [^ ]+? and "
             newAuthors = .Replace(t, ",")
        
        End With
        newAuthors = newAuthors + ","
        
        With reg
            .Global = True
            .Pattern = "[A-Z].+?\,"
            Set matches = .Execute(newAuthors)
        
        End With
        
        For Each m In matches
            thisAuthors = thisAuthors + Left(m, Len(m) - 3) + ","
        Next
        thisAuthors = Replace(thisAuthors, " ,", ",")
End If

End Function
Function thisMail()
Dim reg As New RegExp
Selection.HomeKey wdStory
With Selection.Find
    .ClearFormatting
    .Text = "Received: "
    .MatchWildcards = False
    .Replacement.Text = ""
    .Execute
End With
Dim myrange As Range
Set myrange = ActiveDocument.Range(ActiveDocument.Paragraphs(4).Range.End, Selection.Range.Start)
     With reg
            .Global = True
            .Pattern = "[\w-\.]+@([\w-]+\.)+[a-z]{2,3}"
            Set matches = .Execute(myrange.Text)
        
        End With
        
        For Each m In matches
            thisMail = thisMail + m + " "
        Next
        Selection.HomeKey wdStory
End Function
Sub gotoSelectionAddComment(str As String)
    With Selection.Find
        .ClearFormatting
        .Text = str
        .MatchWildcards = False
        .Replacement.Text = ""
        .Wrap = wdFindContinue
        .Execute
        If .Found Then
            Selection.Range.HighlightColorIndex = wdYellow
            Selection.comments.Add Selection.Range, str + "is different from redmind"
        End If
    End With
    
End Sub