revise 11-6
Sub detectBallotBox()
Dim i As Integer
Dim str
Dim arr As String
arr = "9633,9744"
str = Split(arr, ",")
i = 0
Do While (i < 2)
With Selection.Find
.ClearFormatting
.Text = ChrW(CInt(str(i)))
.MatchWildcards = False
Do
.Execute
If Not .Found Then
Exit Do
Else
If InputBox("Is this Ballot Box?", "Replace Ballot Box", "yes", 300, 300) = "yes" Then
Selection.Text = " □"
Else
Selection.MoveRight wdCharacter, 1
End If
End If
Loop
End With
i = i + 1
Loop
End Sub
Sub putEquationIntoTable()
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.MatchWildcards = False
Do
.Execute
If Not .Found Then
Exit Do
Else
Dim aimT As String
aimT = Selection.Text
Selection.Range.Delete
Selection.Range.Font.name = "Palatino Linotype"
Selection.TypeText aimT
End If
Loop
End With
End Sub
Function q(str As String)
Dim reg As New RegExp
reg.Pattern = "text=" + ChrW(34) + "(.+?)" + ChrW(34)
reg.Global = True
Dim match
Set match = reg.Execute(str)
q = match(0).SubMatches(0)
End Function
Sub putEquationIntoTablea()
Dim myMath As OMath
Dim myField As Field
For Each myMath In ActiveDocument.OMaths
myMath.Range.Select
If FunctionGroup.isParagraph(Selection.Paragraphs(1).Range.Text) = False Then
Call formatEquation
End If
Next
For Each myField In ActiveDocument.Fields
myField.Select
If Selection.Type = 7 Then
Call formatEquation
End If
Next
End Sub
Function formatEquation()
If Selection.Information(wdWithInTable) Then
Selection.Tables(1).Select
Selection.Style = ActiveDocument.Styles("MDPI_equationFram")
Else
If FunctionGroup.isParagraph(Selection.Paragraphs(1).Range.Text) = False Then
Selection.Cut
Call EquationFrameNo
Selection.MoveDown wdLine, 1
End If
End If
End Function
Sub qwr()
Dim i As Integer
i = 1
Do While i < 198
Selection.HomeKey wdLine
Selection.TypeText CStr(i) + "!"
Selection.MoveDown wdParagraph
i = i + 1
Loop
End Sub
Sub Macro1()
'
' Macro1 Macro
'
Selection.InsertCrossReference ReferenceType:=wdRefTypeBookmark, ReferenceKind:= _
wdNumberNoContext, ReferenceItem:="refTemp" & strtemp, _
InsertAsHyperlink:=True
Selection.InsertCrossReference ReferenceType:="Numbered item", _
ReferenceKind:=wdNumberRelativeContext, ReferenceItem:="1", _
InsertAsHyperlink:=True, IncludePosition:=False, SeparateNumbers:=False, _
SeparatorString:=" "
End Sub
Sub Macro2()
'
Selection.Orientation = wdTextOrientationDownward
Selection.Orientation = wdTextOrientationUpward
Selection.Orientation = wdTextOrientationHorizontal
Selection.Orientation = wdTextOrientationDownward
Selection.Orientation = wdTextOrientationUpward
Selection.Orientation = wdTextOrientationHorizontal
Selection.SelectCell
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
Selection.Cells.VerticalAlignment = wdCellAlignVerticalTop
Selection.SelectCell
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Cells.VerticalAlignment = wdCellAlignVerticalTop
End Sub
Sub Macro3()
Dim objRange As Range
Dim objEq As OMath
Set objRange = Selection.Range
objRange.Text = "Celsius = (5/9)(Fahrenheit - 32)"
Set objRange = Selection.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.BuildUp
End Sub
Sub Macro4()
With Selection.Find
.Text = "\*[A-Z][!^13]@. "
.Replacement.Text = ""
.MatchWildcards = True
Do
DoEvents
.Execute
If .Found Then
If InputBox("yes", "yes", "yes", 300, 300) = "yes" Then
Dim myrange As Range
Set myrange = ActiveDocument.Range(Selection.Range.Start + 1, Selection.Range.End - 2)
myrange.Select
Dim str, first, last, name As String
Dim arr, brr
str = Selection.Text
arr = Split(Selection.Text, "; ")
Dim i As Integer
i = 0
name = ""
Do While i < UBound(arr) + 1
brr = Split(arr(i), ", ")
first = FunctionGroup.convertUpper(CStr(brr(0)))
last = Left(brr(1), "1") + "."
If InStr(brr(1), " ") > 0 Then
crr = Split(brr(1), " ")
last = ""
For j = LBound(crr) To UBound(crr)
last = last + Left(crr(j), 1) + "."
Next
If j = UBound(crr) Then
name = name + first + ", " + last
Else
name = name + first + ", " + last + "; "
End If
Else
name = name + first + ", " + last + "; "
End If
i = i + 1
Loop
Else
Selection.MoveRight wdCharacter, 1
name = ""
End If
Else
Exit Do
End If
Selection.Text = name
Selection.MoveRight wdCharacter, 1
Loop
End With
End Sub
Sub laTexRefOrder()
Dim dict
Dim i, last_called_ref As Integer
i = 1: last_called_ref = 0
Set dict = CreateObject("Scripting.Dictionary")
With Selection.Find
.Text = "\\bibitem\[?@\]"
.MatchWildcards = True
Do
DoEvents
.Execute
If .Found Then
Selection.Collapse wdCollapseEnd
Selection.MoveEndUntil "{"
Selection.MoveRight wdCharacter, 1
Selection.MoveEndUntil "}"
dict.Add Trim(Selection.Text), CStr(i)
Else
Exit Do
End If
i = i + 1
Selection.MoveRight wdCharacter, 1
Loop
End With
Selection.HomeKey wdStory
With Selection.Find
.Text = "\\cit[a-z]@\{"
.MatchWildcards = True
.Replacement.Text = ""
Do
DoEvents
.Execute
If Not .Found Then
Exit Do
Else
Selection.Collapse wdCollapseEnd
Selection.MoveEndUntil "}"
If Left(Selection.Paragraphs(1).Range.Text, "1") = "%" Then
GoTo kr
End If
Dim arr
arr = Split(Selection.Text, ",")
Dim j As Integer
Dim aimT As String
aimT = ""
For j = LBound(arr) To UBound(arr)
If aimT > dict(Trim(arr(j))) Then
aimT = dict(Trim(arr(j))) + "," + aimT
Else
aimT = aimT + dict(Trim(arr(j))) + ","
End If
Next
last_called_ref = parse_ref_call(aimT, last_called_ref)
End If
kr:
Selection.MoveRight wdCharacter, 1
Loop
End With
If ActiveDocument.comments.count = 0 Then
MsgBox "No problem was detected"
End If
End Sub
Function parse_ref_call(AnyStr As String, last_call As Integer)
Dim i As Integer
Dim RegEx, dict
Set RegEx = CreateObject("vbscript.regexp")
Set dict = CreateObject("Scripting.Dictionary") 'prepare look-up hash pair for valid ranges, e.g., 8-14, when checking sequence the code knows to look for after 8
Set sql = RegEx.Execute(Selection.Text) ' find en dash connected ranges
With RegEx
.Global = True
.Pattern = "\d+"
End With
Set sql = RegEx.Execute(AnyStr)
For i = 0 To sql.count - 1
If Val(sql(i)) > last_call + 1 Then
Selection.comments.Add Range:=Selection.Range, Text:="incorrect ref order, " & sql(i) & " detected after " & last_call & ". You jumped the numbers in between."
Else
If dict.Exists(CStr(sql(i))) Then 'cstr ensures the sql(i) is converted from IMatch2 to string, therefore returns dict look up value
If Val(dict(CStr(sql(i)))) > last_call Then ' do not merge this if with the parent if. I am worried the dict(key) call will automatically add entry and mess up the conditional, even with ordered AND
last_call = Val(dict(CStr(sql(i))))
End If
Else
If Val(sql(i)) > last_call Then
last_call = Val(sql(i))
End If
End If
End If
If i + 1 <= sql.count - 1 Then
If Val(sql(i)) >= Val(sql(i + 1)) Then
Selection.comments.Add Range:=Selection.Range, Text:="detected " & sql(i) & " before " & sql(i + 1) & ". This is wrong order."
End If
End If
Next i
parse_ref_call = last_call
Set RegEx = Nothing
Set dict = Nothing
End Function
Sub ottttttttttttttttt()
End Sub
Sub oneKeyPublish()
publishDate
publishFooterHeader
publishDate
detectCopyright
End Sub
Sub publishDate()
With Selection.Find
.ClearFormatting
.Text = "; Published:"
.MatchWildcards = False
.Execute
End With
With Selection
.Collapse wdCollapseEnd
.MoveEndUntil ChrW(13)
.TypeText " " + IIf(Left(day(Date), 1) = "0", Left(day(Date), 1), Right(day(Date), 1)) + " " + FunctionGroup.convertYear(CStr(Month(Date))) + " " + CStr(year(Date))
End With
End Sub
Sub publishFooterHeader()
Selection.HomeKey wdStory
Dim doi, aimT, articleNum, volume As String
'If ActiveWindow.View.SplitSpecial <> wdPaneNone Then ActiveWindow.Panes(2).Close
'doi = InputBox("please insert doi number", "get doi number", , 300, 300)
doi = "doi:10.3390/ijms19113413"
Dim reg As New RegExp
Dim matches
With reg
.Global = True
.Pattern = "\d{8}$"
Set matches = reg.Execute(doi)
End With
aimT = matches(0)
If Left(volume, 1) = "0" Then
volume = Right(volume, 1)
Else
volume = Left(aimT, 2)
End If
articleNum = Right(aimT, 4)
'MsgBox year(Date)
'MsgBox Month(Date)
'MsgBox day(Date)
WordBasic.ViewFooterOnly
Call publishFormat(CStr(year(Date)) + ", " + volume + ", " + articleNum + "; " + doi)
WordBasic.ViewheaderOnly
ActiveWindow.ActivePane.View.NextHeaderFooter
Call publishFormat(CStr(year(Date)) + ", " + volume + ", " + articleNum)
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub detectCopyright()
Dim aimT, testT As String
testT = "by the authors. Submitted for possible open access"
With Selection.Find
.ClearFormatting
.Text = ChrW(169) & " 2"
.Replacement.Text = ""
.Replacement.ClearFormatting
.Execute
End With
aimT = Selection.Paragraphs(1).Range.Text
If InStr(aimT, testT) = 0 Then
Selection.Collapse wdCollapseEnd
MsgBox "copyright incorrect"
End If
End Sub
Sub suppleLink()
Dim doi, volume, aimT
getfootertext = ActiveDocument.Sections(1).Footers(wdHeaderFooterFirstPage).Range.Text
doi = Mid(getfootertext, InStr(getfootertext, ";") + 1, InStr(getfootertext, "www") - InStr(getfootertext, ";"))
Dim reg As New RegExp
Dim matches
With reg
.Global = True
.Pattern = "\d{8}"
Set matches = reg.Execute(doi)
End With
aimT = matches(0)
If Left(volume, 1) = "0" Then
volume = Right(volume, 1)
Else
volume = Left(aimT, 2)
End If
issue = Mid(aimT, 2, 2)
articleNum = Right(aimT, 4)
Selection.Text = "http://www.mdpi.com/" + FunctionGroup.getISSN() + "/" + volume + "/" + issue + "/" + articleNum
End Sub
Sub deleteChicagoNameYear()
Call kr_deck.aselect_whole_reference
Dim paraNum, i As Integer
i = 0
paraNum = Selection.Paragraphs.count
Selection.Collapse wdCollapseStart
Do While (i < paraNum)
Selection.MoveEndUntil ")"
Selection.MoveRight wdCharacter, 2, wdExtend
Selection.Delete
Selection.Move 4
i = i + 1
Loop
End Sub
Sub soushou()
Dim wrd As Range
Dim searT, url As String
searT = ""
For Each wrd In Selection.Range.Words
searT = searT + "+" + Trim(wrd.Text)
Next
searT = Right(searT, Len(searT) - 1)
url = "https://www.google.com.hk/search?q=" + searT
Shell ("C:\Program Files (x86)\Google\Chrome\Application\Chrome.exe -url " + url)
End Sub
Sub qwwqer()
If DateValue("2010/10/4") > DateValue("2010/8/19") Then
MsgBox "s"
End If
End Sub
Sub ooooppppqqq()
MsgBox ActiveDocument.Range.Information(wdNumberOfPagesInDocument)
End Sub
Sub detectEmailCount()
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Text = "Received: "
.MatchWildcards = True
.Replacement.Text = ""
.Execute
End With
Dim myrange As Range
Set myrange = ActiveDocument.Range(ActiveDocument.Paragraphs(3).Range.End, Selection.Range.Start)
myrange.Select
If FunctionGroup.emailCount(myrange.Text) <> FunctionGroup.authorCount(ActiveDocument.Paragraphs(3).Range.Text) Then
myrange.comments.Add myrange, "The number of authors does not match the number of email"
End If
End Sub
Sub timeOrder()
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Text = "Received: "
.MatchWildcards = True
.Replacement.Text = ""
.Execute
End With
Selection.Paragraphs(1).Range.Select
If InStr(Selection.Text, "Received") > 0 And InStr(Selection.Text, "Accepted") > 0 And InStr(Selection.Text, "Published") > 0 Then
arr = Split(Selection.Text, "; ")
If UBound(arr) <> 2 Then
Selection.Range.HighlightColorIndex = wdRed
Selection.comments.Add Selection.Range, "Please check if date is missing"
Exit Sub
End If
Received = Right(arr(0), Len(arr(0)) - InStr(arr(0), ": ") - 1)
Accepted = Right(arr(1), Len(arr(1)) - InStr(arr(1), ": ") - 1)
Published = Right(arr(2), Len(arr(2)) - InStr(arr(2), ": ") - 1)
If DateValue(Received) < DateValue(Accepted) And DateValue(Accepted) < DateValue(Published) Then
Else
Selection.Range.HighlightColorIndex = wdRed
Selection.comments.Add Selection.Range, "Please check if date is missing"
Exit Sub
End If
Else
Selection.Range.HighlightColorIndex = wdRed
Selection.comments.Add Selection.Range, "Please check if date is missing"
Exit Sub
End If
End Sub
Sub ppoo()
If DateValue("12 July 2018") > DateValue("13 December 2018") Then
MsgBox "s"
End If
End Sub
Sub getsss()
Dim i As Long, url As String
Dim S
Dim rxp As String
Dim getId As String
Dim xhttp As Object, rx As Object, maches As Object
Set xhttp = CreateObject("MSXML2.XMLHTTP")
url = "https://redmine.mdpi.com/projects/production-editing/search?utf8=%E2%9C%93&issues=1&q=religions-354795"
xhttp.Open "get", url, False
delay (3000)
xhttp.Send
delay (300)
Do While xhttp.ReadyState <> 4
DoEvents
Loop
S = xhttp.ResponseText
Selection.TypeText S
End Sub
Sub Main()
Dim strText As String
Dim strCookie As String
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Option(6) = False ' 禁止重定向,以获取原网页信息
.Open "GET", "https://redmine.mdpi.com/projects/production-editing/search?utf8=%E2%9C%93&issues=1&q=religions-354795", False
.Send
strText = .GetAllResponseHeaders '获取所有的回应头信息
Selection.TypeText strText '在立即窗口里查看头信息
'取出Cookie值
End With
'在同一个winhttp对象里能保留cookie,为了体现设置cookie的作用,启用一个新的winhttp对象
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "http://www.gzgczj.com:8080/costRegulatory/project.do?method=showProjectList&isVisitor=1&f_id=11011&t1413902083242", False
.SetRequestHeader "Referer", "http://www.gzgczj.com:8080/costRegulatory/user.do?method=changeIndex&fareaId=1"
.SetRequestHeader "Cookie", strCookie '模拟Cookie
.Send
strText = .ResponseText
Debug.Print strText
End With
End Sub
Option Explicit
Option Explicit
Sub Test_ehawaii_gov()
Dim sUrl, sRespHeaders, sRespText, aSetHeaders, aList
' example for https://energy.ehawaii.gov/epd/public/energy-projects-map.html
' get cookies
sUrl = "https://redmine.mdpi.com/projects/production-editing/search?utf8=%E2%9C%93&issues=1&q=religions-354795"
XmlHttpRequest "GET", sUrl, Array(), "", sRespHeaders, sRespText
ParseResponse "^Set-(Cookie): (\S*?=\S*?);[\s\S]*?$", sRespHeaders, aSetHeaders
' get projects list
sUrl = "https://energy.ehawaii.gov/epd/public/energy-projects-list.json?sEcho=2&iColumns=5&sColumns=&iDisplayStart=1&iDisplayLength=0&mDataProp_0=0&mDataProp_1=1&mDataProp_2=2&mDataProp_3=3&mDataProp_4=4&sSearch=&bRegex=false&sSearch_0=&bRegex_0=false&bSearchable_0=true&sSearch_1=&bRegex_1=false&bSearchable_1=true&sSearch_2=&bRegex_2=false&bSearchable_2=true&sSearch_3=&bRegex_3=false&bSearchable_3=true&sSearch_4=&bRegex_4=false&bSearchable_4=true&iSortCol_0=0&sSortDir_0=asc&iSortingCols=1&bSortable_0=true&bSortable_1=true&bSortable_2=true&bSortable_3=true&bSortable_4=true"
XmlHttpRequest "GET", sUrl, aSetHeaders, "", "", sRespText
' parse project names
ParseResponse "\[""([\s\S]*?)""", sRespText, aList
Debug.Print Join(aList, vbCrLf)
End Sub
Sub XmlHttpRequest(sMethod, sUrl, aSetHeaders, sPayload, sRespHeaders, sRespText)
Dim aHeader
With CreateObject("MSXML2.ServerXMLHTTP")
.SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
.Open sMethod, sUrl, False
For Each aHeader In aSetHeaders
.SetRequestHeader aHeader(0), aHeader(1)
Next
.Send (sPayload)
sRespHeaders = .GetAllResponseHeaders
sRespText = .ResponseText
End With
End Sub
Sub ParseResponse(sPattern, sResponse, aData)
Dim oMatch, aTmp, sSubMatch
aData = Array()
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.Pattern = sPattern
For Each oMatch In .Execute(sResponse)
If oMatch.SubMatches.count = 1 Then
PushItem aData, oMatch.SubMatches(0)
Else
aTmp = Array()
For Each sSubMatch In oMatch.SubMatches
PushItem aTmp, sSubMatch
Next
PushItem aData, aTmp
End If
Next
End With
End Sub
Sub PushItem(aList, vItem)
ReDim Preserve aList(UBound(aList) + 1)
aList(UBound(aList)) = vItem
End Sub
Sub Macro5()
i = 1
Do While (i < 150)
Do
Selection.MoveEndUntil ","
If existTitle(Selection.Text) = False Then
oriL = Len(Selection.Text)
Selection.MoveRight wdCharacter, 2, wdExtend
Selection.MoveEndUntil ","
nowL = Len(Selection.Text)
Else
Selection.MoveLeft wdCharacter, nowL - oriL, wdExtend
Selection.MoveRight wdCharacter, 1, wdExtend
If InputBox("Is this ncbi?", "NCBI", "yes", 300, 300) = "yes" Then
Call layout_feifei_liu.sFormatBibtexName
End If
Exit Do
End If
Loop
Selection.Move 4
i = i + 1
Loop
End Sub
Function existTitle(str As String) As Boolean
Dim reg As Object
Set reg = CreateObject("VBScript.Regexp")
Dim is_exist As Boolean
With reg
.Global = True
.Pattern = " \w+ "
is_exist = .test(str)
End With
existTitle = is_exist
End Function
Sub dectectSectionCite()
'
With Selection.Find
.ClearFormatting
.Replacement.Text = ""
.Text = "Section [0-9]"
.MatchWildcards = True
.Execute
Selection.MoveEndUntil " "
arr = Split(Selection, " ")
T = arr(1)
If existSection(CStr(T), FunctionGroup.dotCount(Selection.Text) + 1) = False Then
End If
End With
'
End Sub
Function existSection(str As String, level As Integer) As Boolean
existSection = False
With ActiveDocument.Content.Find
.Text = str
.MatchWildcards = False
.ParagraphFormat.OutlineLevel = level
.Execute
If .Found Then
existSection = True
End If
End With
End Function
Sub Macro7()
'
' Macro7 Macro
'
'
With Selection.HeaderFooter.PageNumbers
.NumberStyle = wdPageNumberStyleArabic
.HeadingLevelForChapter = 0
.IncludeChapterNumber = False
.ChapterPageSeparator = wdSeparatorHyphen
.RestartNumberingAtSection = True
.StartingNumber = 11
End With
End Sub
Sub detectSectionTitleOrder(ByVal control As IRibbonControl)
Call sectionTitleOrder(1)
Call sectionTitleOrder(2)
Call sectionTitleOrder(3)
End Sub
Sub sectionTitleOrder(level As Integer)
Dim lastCall, selectNum As Integer
lastCall = 0
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = False
.Replacement.Text = ""
.ParagraphFormat.OutlineLevel = level
Do
.Execute
If Not .Found Then
Exit Do
Else
If FunctionGroup.isSectionTitle(Selection.Text) Then
selectNum = CInt(sectionNum(Selection.Text))
If selectNum > lastCall Then
If selectNum - lastCall = 1 Then
Else
Selection.Range.HighlightColorIndex = wdYellow
End If
lastCall = selectNum
Selection.Collapse wdCollapseEnd
Else
If selectNum = 1 Then
lastCall = 1
Selection.Collapse wdCollapseEnd
Else
Selection.Range.HighlightColorIndex = wdYellow
End If
Selection.Collapse wdCollapseEnd
End If
End If
End If
Loop
End With
End Sub
Function sectionNum(str As String) As String
Dim reg As New RegExp
Dim matches
With reg
.Global = 1
.Pattern = "\d(?=\. )"
Set matches = .Execute(str)
End With
sectionNum = matches(0)
End Function
Function incrementedOne(str As String) As Boolean
If CInt(str) > lastCall Then
If CInt(str) - lastCall = 1 Then
incrementedOne = True
Else
incrementedOne = False
End If
lastCall = CInt(str)
Else
incrementedOne = False
End If
End Function