393 lines
15 KiB
VB.net
393 lines
15 KiB
VB.net
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
|