227 lines
7.3 KiB
QBasic
227 lines
7.3 KiB
QBasic
Attribute VB_Name = "ex_Word"
|
||
'================ Word helper functions =============
|
||
' Shared module version: 20220911
|
||
' Tested in: TestWord
|
||
' Depends on:
|
||
' Required reference:
|
||
Option Private Module
|
||
Option Explicit
|
||
|
||
Public Function WordIntersectRanges(rng1 As Word.Range, rng2 As Word.Range) As Word.Range
|
||
If rng1.Document <> rng2.Document Then _
|
||
Exit Function
|
||
If rng1.Start >= rng2.End Or rng2.Start >= rng1.End Then _
|
||
Exit Function
|
||
If rng1.Start >= rng2.Start Then
|
||
If rng2.End > rng1.Start Then _
|
||
Set WordIntersectRanges = rng1.Document.Range(rng1.Start, IIf(rng1.End > rng2.End, rng2.End, rng1.End))
|
||
Else
|
||
If rng1.End > rng2.Start Then _
|
||
Set WordIntersectRanges = rng1.Document.Range(rng2.Start, IIf(rng1.End > rng2.End, rng2.End, rng1.End))
|
||
End If
|
||
End Function
|
||
|
||
Public Function WordPutText(sText$, iDoc As Word.Document, nWhere&, Optional aStyle$ = vbNullString) As Word.Range
|
||
Set WordPutText = iDoc.Range(nWhere, nWhere)
|
||
With WordPutText
|
||
Call .InsertAfter(sText)
|
||
If aStyle <> vbNullString Then _
|
||
.Style = aStyle
|
||
End With
|
||
End Function
|
||
|
||
Public Function WordAppendTo(sText$, ByRef rWhere As Word.Range, Optional aStyle$ = vbNullString) As Word.Range
|
||
Const ASCII_NEWLINE = 13
|
||
|
||
If rWhere.Characters.Count > 0 Then _
|
||
If AscW(rWhere.Characters.Last) = ASCII_NEWLINE Then _
|
||
Call rWhere.MoveEnd(wdCharacter, -1)
|
||
|
||
Call rWhere.InsertAfter(sText)
|
||
Dim insertedRng As Word.Range: Set insertedRng = rWhere.Duplicate
|
||
insertedRng.Start = rWhere.End - VBA.Len(sText)
|
||
If aStyle <> vbNullString Then _
|
||
insertedRng.Style = aStyle
|
||
Set WordAppendTo = insertedRng
|
||
End Function
|
||
|
||
Public Function WordAddLine(sText$, rWhere As Word.Range, Optional aStyle$ = vbNullString) As Word.Range
|
||
Dim nEnd&: nEnd = rWhere.End
|
||
If rWhere.Tables.Count > 0 Then
|
||
If rWhere.Cells.Count > 0 Then
|
||
Dim theLastCell As Word.Cell: Set theLastCell = rWhere.Cells(rWhere.Cells.Count)
|
||
If nEnd >= theLastCell.Range.End - 1 Then
|
||
Set WordAddLine = AddLineLastInCell(sText, theLastCell, aStyle)
|
||
GoTo SAFE_EXIT
|
||
End If
|
||
End If
|
||
End If
|
||
|
||
Dim nParaEnd&: nParaEnd = rWhere.Paragraphs.Last.Range.End
|
||
If rWhere.End = rWhere.Document.Range.End Then
|
||
Call rWhere.InsertAfter(vbNewLine)
|
||
Set WordAddLine = WordPutText(sText, rWhere.Document, rWhere.End - 1, aStyle)
|
||
Call WordAddLine.MoveEnd(wdCharacter, 1)
|
||
GoTo SAFE_EXIT
|
||
End If
|
||
|
||
If nEnd <> nParaEnd Then
|
||
If rWhere.Next(wdCharacter, 1).End = nParaEnd Then
|
||
Call rWhere.MoveEnd(wdCharacter, 1)
|
||
Else
|
||
Call rWhere.InsertAfter(vbNewLine)
|
||
End If
|
||
End If
|
||
Set WordAddLine = WordPutText(sText & vbNewLine, rWhere.Document, rWhere.End, aStyle)
|
||
|
||
SAFE_EXIT:
|
||
rWhere.End = nEnd
|
||
End Function
|
||
|
||
Public Function WordFindAndReplace(iDoc As Word.Document, findText$, ReplaceText$, _
|
||
Optional mCase As Boolean = False, _
|
||
Optional wildCard As Boolean = False, _
|
||
Optional wholeWord As Boolean = True) As Long
|
||
Dim findRange As Word.Range: Set findRange = iDoc.Range
|
||
Dim nResult&: nResult = 0
|
||
With findRange.Find
|
||
.Text = findText
|
||
.MatchCase = mCase
|
||
.MatchWholeWord = wholeWord
|
||
.MatchWildcards = wildCard
|
||
.Replacement.Text = ReplaceText
|
||
.Format = True
|
||
.Font.Hidden = False
|
||
|
||
Do While .Execute(Replace:=1)
|
||
nResult = nResult + 1
|
||
Call findRange.Collapse(Direction:=wdCollapseEnd)
|
||
Loop
|
||
End With
|
||
WordFindAndReplace = nResult
|
||
End Function
|
||
|
||
Public Function WordDeleteHyperlinks(iDoc As Word.Document) As Long
|
||
On Error Resume Next
|
||
WordDeleteHyperlinks = 0
|
||
Do Until iDoc.Hyperlinks.Count = 0
|
||
Call iDoc.Hyperlinks(1).Delete
|
||
WordDeleteHyperlinks = WordDeleteHyperlinks + 1
|
||
Loop
|
||
End Function
|
||
|
||
Public Function WordStyleExists(iDoc As Word.Document, target$) As Boolean
|
||
WordStyleExists = True
|
||
On Error GoTo RET_FALSE
|
||
Dim aStyle As Word.Style: Set aStyle = iDoc.Styles(target)
|
||
Exit Function
|
||
|
||
RET_FALSE:
|
||
WordStyleExists = False
|
||
End Function
|
||
|
||
' Requires: wordApp should be Application, responsible for both documents (if any or both are open)
|
||
Public Function WordCopyStyle(wordApp As Word.Application, sSource$, sDestination$, sStyle$) As Boolean
|
||
WordCopyStyle = True
|
||
On Error GoTo RETURN_FALSE
|
||
Call wordApp.OrganizerCopy(sSource, sDestination, sStyle, wdOrganizerObjectStyles)
|
||
On Error GoTo 0
|
||
Exit Function
|
||
RETURN_FALSE:
|
||
WordCopyStyle = False
|
||
End Function
|
||
|
||
Public Function WordStyleIsUsed(iDoc As Word.Document, aStyle As Word.Style) As Boolean
|
||
On Error Resume Next
|
||
Dim findRange As Word.Range: Set findRange = iDoc.Range
|
||
With findRange.Find
|
||
.Text = vbNullString
|
||
.Format = True
|
||
.Style = aStyle
|
||
WordStyleIsUsed = .Execute
|
||
End With
|
||
End Function
|
||
|
||
Public Function WordAdjustRange(target As Word.Range) As Word.Range
|
||
Dim rExpansion As Word.Range: Set rExpansion = target.Duplicate
|
||
If Not rExpansion.Characters.First Like "[" & " " & Chr(160) & "]" Then
|
||
Call rExpansion.StartOf(wdWord, wdExtend)
|
||
Call rExpansion.MoveStartWhile("""'<27><><EFBFBD><EFBFBD>", wdBackward)
|
||
End If
|
||
|
||
If rExpansion.Start <> rExpansion.End Then _
|
||
Call rExpansion.EndOf(wdWord, wdExtend)
|
||
|
||
If Not rExpansion.Characters.Last Like "[" & " " & Chr(160) & "]" Then
|
||
Call rExpansion.MoveEndWhile("""'<27><><EFBFBD><EFBFBD>", wdForward)
|
||
Call rExpansion.MoveEndWhile(" " & Chr(160), wdForward)
|
||
End If
|
||
|
||
Set WordAdjustRange = rExpansion
|
||
End Function
|
||
|
||
Public Function AcceptAuthorsRevision(oAuthors As Collection, target As Word.Document) As Long
|
||
AcceptAuthorsRevision = 0
|
||
Dim itemChange As Word.Revision
|
||
For Each itemChange In target.Revisions
|
||
Dim sAuthor As Variant
|
||
For Each sAuthor In oAuthors
|
||
If sAuthor = itemChange.Author Then
|
||
Call itemChange.Accept
|
||
AcceptAuthorsRevision = AcceptAuthorsRevision + 1
|
||
GoTo NEXT_ITEM
|
||
End If
|
||
Next sAuthor
|
||
NEXT_ITEM:
|
||
Next itemChange
|
||
End Function
|
||
|
||
Public Function AcceptFormatRevision(iDoc As Word.Document) As Long
|
||
AcceptFormatRevision = 0
|
||
Dim itemChange As Word.Revision
|
||
Dim theType As WdRevisionType
|
||
For Each itemChange In iDoc.Revisions
|
||
theType = itemChange.Type
|
||
If theType = wdRevisionParagraphProperty Or _
|
||
theType = wdRevisionStyle Or _
|
||
theType = wdRevisionProperty Then
|
||
itemChange.Accept
|
||
AcceptFormatRevision = AcceptFormatRevision + 1
|
||
End If
|
||
Next itemChange
|
||
End Function
|
||
|
||
Public Function StyleByName(sStyle$, iDoc As Word.Document) As Word.Style
|
||
On Error GoTo RETURN_NOTHING
|
||
Set StyleByName = iDoc.Styles(sStyle)
|
||
RETURN_NOTHING:
|
||
End Function
|
||
|
||
Public Function ExtractCommentText(target As Word.Range) As String
|
||
If target.Comments.Count <> 0 Then
|
||
ExtractCommentText = target.Comments(1).Range.Text
|
||
Exit Function
|
||
End If
|
||
|
||
Dim theDoc As Word.Document: Set theDoc = target.Document
|
||
Dim aComment As Word.Comment
|
||
For Each aComment In theDoc.Comments
|
||
If target.InRange(aComment.Scope) Then
|
||
ExtractCommentText = aComment.Range.Text
|
||
Exit Function
|
||
End If
|
||
Next aComment
|
||
ExtractCommentText = vbNullString
|
||
End Function
|
||
|
||
' =====
|
||
Private Function AddLineLastInCell(sText$, whereCell As Word.Cell, aStyle$) As Word.Range
|
||
Dim nWhere&: nWhere = whereCell.Range.End - 1
|
||
If whereCell.Range.Characters.Count > 1 Then
|
||
Call WordPutText(vbNewLine, whereCell.Range.Document, nWhere)
|
||
nWhere = nWhere + 1
|
||
End If
|
||
Set AddLineLastInCell = WordPutText(sText, whereCell.Range.Document, whereCell.Range.End - 1, aStyle)
|
||
End Function
|
||
|