revise 11-9
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