This commit is contained in:
@@ -0,0 +1,392 @@
|
||||
Option Explicit On
|
||||
|
||||
Module Cmt
|
||||
'Private App As Word.Application
|
||||
Public Function AddColor(sType As String) As Boolean
|
||||
'Highlight the current selection in a manner which identifies what the selection is
|
||||
Dim bReturn As Boolean
|
||||
|
||||
bReturn = True 'default return value
|
||||
With App.Selection.Range
|
||||
App.Selection.Font.Color = Word.WdColor.wdColorBlack
|
||||
If UCase(sType) Like "STEP*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdBrightGreen
|
||||
ElseIf UCase(sType) Like "NOTES*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdAuto
|
||||
ElseIf UCase(sType) Like "NOTE*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdBrightGreen
|
||||
ElseIf UCase(sType) Like "CAUTIONS*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdAuto
|
||||
ElseIf UCase(sType) Like "CAUTION*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdBrightGreen
|
||||
ElseIf UCase(sType) Like "IGNORE" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdGray50
|
||||
ElseIf UCase(sType) Like "SECTION*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdRed
|
||||
ElseIf UCase(sType) Like "FIGURE*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdYellow
|
||||
ElseIf UCase(sType) Like "EQUATION*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdYellow
|
||||
ElseIf UCase(sType) Like "TABLE*" Then
|
||||
.HighlightColorIndex = Word.WdColorIndex.wdYellow
|
||||
Else
|
||||
'don't know what this is so return false
|
||||
bReturn = False
|
||||
End If
|
||||
End With
|
||||
|
||||
AddColor = bReturn
|
||||
|
||||
End Function
|
||||
|
||||
Public Function GetCmtValue(Cmt As Word.Comment, sParam As String) As String
|
||||
Dim sReturn As String
|
||||
|
||||
sReturn = ""
|
||||
|
||||
If Not Cmt Is Nothing Then
|
||||
With Cmt.Range
|
||||
If UCase(Cmt.Author) Like "STEP*" Then
|
||||
Select Case LCase(sParam)
|
||||
Case "level"
|
||||
sReturn = Right(Cmt.Author, 1)
|
||||
Case "style"
|
||||
sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
|
||||
Case "checkoff"
|
||||
sReturn = Replace(.Paragraphs(4).Range.Text, Chr(13), "")
|
||||
End Select
|
||||
Else
|
||||
Select Case UCase(Cmt.Author)
|
||||
Case "SECTION"
|
||||
Select Case LCase(sParam)
|
||||
Case "style"
|
||||
sReturn = Replace(.Paragraphs(2).Range.Text, Chr(13), "")
|
||||
Case "type"
|
||||
sReturn = Replace(.Paragraphs(3).Range.Text, Chr(13), "")
|
||||
Case "number"
|
||||
sReturn = Replace(.Paragraphs(4).Range.Text, Chr(13), "")
|
||||
Case "title"
|
||||
sReturn = Replace(.Paragraphs(5).Range.Text, Chr(13), "")
|
||||
Case "id"
|
||||
sReturn = Replace(.Paragraphs(6).Range.Text, Chr(13), "")
|
||||
End Select
|
||||
Case "CAUTION"
|
||||
Select Case LCase(sParam)
|
||||
Case "style"
|
||||
sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
|
||||
End Select
|
||||
Case "NOTE"
|
||||
Select Case LCase(sParam)
|
||||
Case "style"
|
||||
sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
|
||||
End Select
|
||||
Case "TABLE"
|
||||
Select Case LCase(sParam)
|
||||
Case "style"
|
||||
sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
|
||||
End Select
|
||||
Case "FIGURE"
|
||||
Select Case LCase(sParam)
|
||||
Case "style"
|
||||
sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
|
||||
End Select
|
||||
Case "EQUATION"
|
||||
Select Case LCase(sParam)
|
||||
Case "style"
|
||||
sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
|
||||
End Select
|
||||
End Select
|
||||
End If
|
||||
End With
|
||||
End If
|
||||
|
||||
GetCmtValue = sReturn
|
||||
|
||||
End Function
|
||||
|
||||
Public Sub ModifyComment(ByRef Cmt As Word.Comment, ByVal sMsg As String)
|
||||
Dim rng As Word.Range
|
||||
Dim sAuthor As String
|
||||
|
||||
sAuthor = Cmt.Author
|
||||
Cmt.Scope.Select()
|
||||
Cmt.Delete()
|
||||
|
||||
With App.Selection
|
||||
rng = .Range
|
||||
Cmt = App.ActiveDocument.Comments.Add(Range:= .Range, Text:=sMsg)
|
||||
Cmt.Author = sAuthor
|
||||
rng.Select()
|
||||
End With
|
||||
|
||||
End Sub
|
||||
|
||||
Public Sub MoveComment(ByVal CmtType As String, ByVal Direction As String)
|
||||
Dim bMoved As Boolean
|
||||
Dim sAuthor As String
|
||||
Dim sMsg As String
|
||||
Dim sScope As String
|
||||
Dim Cmt As Word.Comment
|
||||
Dim rng As Word.Range
|
||||
Dim lColor As Long
|
||||
Dim lHighlight As Long
|
||||
|
||||
If App.Selection.Comments.Count > 0 Then
|
||||
Cmt = App.Selection.Comments(1)
|
||||
sAuthor = Cmt.Author
|
||||
If InStr(sAuthor, CmtType) > 0 Then
|
||||
sMsg = Cmt.Range.Text
|
||||
rng = Cmt.Scope
|
||||
lColor = rng.Font.Color
|
||||
lHighlight = rng.HighlightColorIndex
|
||||
|
||||
If Not rng.Font.Italic = False Then
|
||||
'make sure to capture the entire paragraph
|
||||
sScope = rng.Text
|
||||
rng.Expand(Unit:=Word.WdUnits.wdParagraph)
|
||||
'delete original comment
|
||||
Cmt.Delete()
|
||||
rng.Delete()
|
||||
'position range to new location and add paragraph
|
||||
If LCase(Direction) = "up" Then
|
||||
rng.Move(Unit:=Word.WdUnits.wdParagraph, Count:=-1)
|
||||
rng.InsertParagraphBefore()
|
||||
rng = rng.Paragraphs.First.Range
|
||||
Else
|
||||
rng.Move(Unit:=Word.WdUnits.wdParagraph, Count:=1)
|
||||
rng.InsertParagraphAfter()
|
||||
rng = rng.Paragraphs.Last.Range
|
||||
End If
|
||||
'fill new paraagraph with original comment scope
|
||||
rng.ParagraphFormat.Style = App.ActiveDocument.Styles("Normal").NameLocal
|
||||
rng.InsertBefore(sScope)
|
||||
rng.Font.Italic = True
|
||||
'attach comment to new paragraph
|
||||
Cmt = App.ActiveDocument.Comments.Add(Range:=rng, Text:=sMsg)
|
||||
Cmt.Author = sAuthor
|
||||
rng.Font.Color = lColor
|
||||
rng.HighlightColorIndex = lHighlight
|
||||
rng.Select()
|
||||
Else
|
||||
If LCase(Direction) = "up" Then
|
||||
bMoved = MovePrevious
|
||||
Else
|
||||
bMoved = MoveNext
|
||||
End If
|
||||
|
||||
If bMoved = True Then
|
||||
rng.Font.Color = Word.WdColor.wdColorAutomatic
|
||||
rng.HighlightColorIndex = Word.WdColorIndex.wdAuto
|
||||
rng = App.Selection.Range
|
||||
Cmt.Delete()
|
||||
Cmt = App.ActiveDocument.Comments.Add(Range:=rng, Text:=sMsg)
|
||||
Cmt.Author = sAuthor
|
||||
rng.Font.Color = lColor
|
||||
rng.HighlightColorIndex = lHighlight
|
||||
rng.Select()
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Public Function GetComment(rng As Word.Range) As Word.Range
|
||||
'returns the content of the first comment
|
||||
'associated with the range provided
|
||||
Dim rReturn As Word.Range
|
||||
Dim r As Word.Range
|
||||
Dim Cmt As Word.Comment
|
||||
|
||||
rReturn = Nothing
|
||||
If rng.Information(Word.WdInformation.wdInCommentPane) = True Then
|
||||
rReturn = rng.Comments(1).Range
|
||||
Else
|
||||
r = App.ActiveDocument.Range(rng.Start, rng.Start)
|
||||
For Each Cmt In App.ActiveDocument.Comments
|
||||
If r.InRange(Cmt.Scope) Then
|
||||
rReturn = Cmt.Range
|
||||
Exit For
|
||||
End If
|
||||
Next Cmt
|
||||
End If
|
||||
|
||||
GetComment = rReturn
|
||||
|
||||
End Function
|
||||
|
||||
Public Function GoToComment(Optional LimitToPara As Boolean = True) As Boolean
|
||||
'move selection to comment associated with current selection
|
||||
'return true if selection is in comment
|
||||
Dim rng As Word.Range
|
||||
Dim bReturn As Boolean
|
||||
|
||||
If App.Selection.Information(Word.WdInformation.wdInCommentPane) = False Then
|
||||
bReturn = False
|
||||
rng = GetComment(App.Selection.Range)
|
||||
If Not rng Is Nothing Then
|
||||
rng.Select()
|
||||
bReturn = True
|
||||
End If
|
||||
Else
|
||||
bReturn = True
|
||||
End If
|
||||
|
||||
GoToComment = bReturn
|
||||
|
||||
End Function
|
||||
|
||||
Public Function MoveToNextComment(Optional sAuthor As String = "") As Word.Comment
|
||||
Dim rng As Word.Range
|
||||
Dim Cmt As Word.Comment
|
||||
Dim cReturn As Word.Comment
|
||||
Dim bSelectCmt As Boolean
|
||||
Dim I As Integer
|
||||
|
||||
cReturn = Nothing
|
||||
|
||||
If sAuthor <> "" Then
|
||||
If App.Selection.Comments.Count > 0 Then
|
||||
Cmt = App.Selection.Comments(1)
|
||||
sAuthor = Cmt.Author
|
||||
End If
|
||||
End If
|
||||
|
||||
If App.Selection.Information(Word.WdInformation.wdInCommentPane) Then
|
||||
bSelectCmt = True
|
||||
App.Selection.Comments(1).Scope.Select()
|
||||
Else
|
||||
bSelectCmt = False
|
||||
End If
|
||||
|
||||
If App.Selection.End < App.ActiveDocument.Content.End Then
|
||||
rng = App.ActiveDocument.Range(App.Selection.End, App.ActiveDocument.Content.End)
|
||||
With rng.Paragraphs
|
||||
For I = 1 To .Count
|
||||
If .Item(I).Range.Comments.Count > 0 Then
|
||||
Cmt = .Item(I).Range.Comments(1)
|
||||
If (sAuthor = Cmt.Author) Or (sAuthor = "") Then
|
||||
If bSelectCmt = True Then
|
||||
Cmt.Range.Select()
|
||||
Else
|
||||
Cmt.Scope.Select()
|
||||
End If
|
||||
cReturn = Cmt
|
||||
Exit For
|
||||
End If
|
||||
End If
|
||||
Next I
|
||||
End With
|
||||
End If
|
||||
|
||||
MoveToNextComment = cReturn
|
||||
|
||||
End Function
|
||||
|
||||
Public Sub InsertComment(ByVal sAuthor As String, Optional sMsg As String = "")
|
||||
Dim Cmt As Word.Comment
|
||||
Dim rng As Word.Range
|
||||
|
||||
On Error GoTo Err_InsertComment
|
||||
RemoveComments()
|
||||
sAuthor = Trim(sAuthor)
|
||||
If AddColor(sAuthor) = True Then
|
||||
With App.Selection
|
||||
rng = .Range
|
||||
Cmt = App.ActiveDocument.Comments.Add(Range:= .Range, Text:=sMsg)
|
||||
Cmt.Author = sAuthor
|
||||
End With
|
||||
rng.Select
|
||||
End If
|
||||
|
||||
Bye_InsertComment:
|
||||
Exit Sub
|
||||
|
||||
Err_InsertComment:
|
||||
Err.Clear()
|
||||
Resume Bye_InsertComment
|
||||
|
||||
End Sub
|
||||
|
||||
Public Sub RemoveComments(Optional ByVal AskFirst As Boolean = False, Optional CmtType As String = "")
|
||||
Dim rng As Word.Range
|
||||
Dim rStart As Word.Range
|
||||
Dim rEnd As Word.Range
|
||||
Dim Cmt As Word.Comment
|
||||
Dim sMsg As String
|
||||
Dim I As Integer
|
||||
|
||||
If App.Selection.Information(Word.WdInformation.wdInCommentPane) = True Then
|
||||
Cmt = App.Selection.Comments(1)
|
||||
If CmtType <> "" Then
|
||||
If Cmt.Author Like CmtType & "*" Then
|
||||
Cmt.Scope.Select()
|
||||
DeleteComment(Cmt)
|
||||
End If
|
||||
Else
|
||||
Cmt.Scope.Select()
|
||||
DeleteComment(Cmt)
|
||||
End If
|
||||
Else
|
||||
If AskFirst = True Then
|
||||
If App.Selection.Range.Paragraphs.Count > 1 Then
|
||||
sMsg = "Do you wish to delete all Comments within the current selection?"
|
||||
If MsgBox(sMsg, vbYesNo + vbQuestion + vbDefaultButton1, "Remove Comments") = vbYes Then
|
||||
AskFirst = False
|
||||
End If
|
||||
Else
|
||||
AskFirst = False
|
||||
End If
|
||||
End If
|
||||
If AskFirst = False Then
|
||||
With App.Selection
|
||||
rng = .Range
|
||||
.MoveEndWhile(Cset:=Chr(13), Count:=Word.WdConstants.wdBackward)
|
||||
If .Information(Word.WdInformation.wdWithInTable) Then
|
||||
.End = .End - 1
|
||||
End If
|
||||
'locate start and end points of the selection
|
||||
rStart = App.ActiveDocument.Range(.Start, .Start)
|
||||
rEnd = App.ActiveDocument.Range(.End, .End)
|
||||
End With
|
||||
|
||||
For I = App.ActiveDocument.Comments.Count To 1 Step -1
|
||||
Cmt = App.ActiveDocument.Comments(I)
|
||||
If Cmt.Scope.InRange(rng) Or rng.InRange(Cmt.Scope) Or rStart.InRange(Cmt.Scope) Or rEnd.InRange(Cmt.Scope) Then
|
||||
If CmtType <> "" Then
|
||||
If Cmt.Author Like CmtType & "*" Then
|
||||
DeleteComment(Cmt)
|
||||
End If
|
||||
Else
|
||||
DeleteComment(Cmt)
|
||||
End If
|
||||
End If
|
||||
Next I
|
||||
rng.Select
|
||||
End If
|
||||
End If
|
||||
|
||||
End Sub
|
||||
|
||||
Public Sub DeleteComment(ByRef Cmt As Word.Comment)
|
||||
Dim rng As Word.Range
|
||||
Dim I As Integer
|
||||
|
||||
rng = Cmt.Scope
|
||||
Cmt.Delete()
|
||||
|
||||
With rng
|
||||
If Not .Font.Italic = False Then
|
||||
For I = .Paragraphs.Count To 1 Step -1
|
||||
.Paragraphs(I).Range.Delete
|
||||
Next I
|
||||
Else
|
||||
For I = .Paragraphs.Count To 1 Step -1
|
||||
.Paragraphs(I).Range.Font.ColorIndex = Word.WdColorIndex.wdAuto
|
||||
.Paragraphs(I).Range.HighlightColorIndex = Word.WdColorIndex.wdAuto
|
||||
Next I
|
||||
End If
|
||||
End With
|
||||
|
||||
End Sub
|
||||
|
||||
End Module
|
||||
Reference in New Issue
Block a user