Cacher is the code snippet organizer for pro developers

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 = "rui.ke@mdpi.com"
    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
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