-
Notifications
You must be signed in to change notification settings - Fork 3
/
FindAndReplaceCitationHyperlinks
122 lines (102 loc) · 4.57 KB
/
FindAndReplaceCitationHyperlinks
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
Function FindAndReplaceCitationHyperlinks()
'============================================================================
' Name : FindAndReplaceCitationHyperlinks
' Author : Erica L Ingram
' Copyright : 2019, A Quo Co.
' Call command: Call FindAndReplaceCitationHyperlinks
' Description : adds citations and hyperlinks from CitationHyperlinks table in transcript
'============================================================================
Dim qReplaceHyperlink
Dim callWordMerge As Variant
Dim oWordApp As Object, oWordDoc As Object
Dim db As Database
Dim Rng As Range
Dim rstCitationHyperlinks As DAO.Recordset
Dim sFileName As String, sCourtDatesID As String, sQLongCitation As String
Dim sQFindCitation As String, sQCHCategory As String, sQWebAddress As String
sCourtDatesID = Forms![NewMainMenu]![ProcessJobSubformNMM].Form![JobNumberField]
sFileName = "T:\In Progress\" & sCourtDatesID & "\" & sCourtDatesID & "-CourtCover.docx"
Set oWordApp = CreateObject("Word.Application")
oWordApp.Visible = False
If Dir(sFileName) = "" Then
MsgBox "Document not found."
Else
Set oWordApp = CreateObject(Class:="Word.Application")
oWordApp.Visible = True
oWordApp.AutomationSecurity = msoAutomationSecurityLow
Set oWordDoc = oWordApp.Application.Documents.Open(sFileName)
oWordApp.Application.Visible = True
oWordApp.Activate
Set db = CurrentDb
Set rstCitationHyperlinks = db.OpenRecordset("CitationHyperlinks")
If Not (rstCitationHyperlinks.EOF And rstCitationHyperlinks.BOF) Then
rstCitationHyperlinks.MoveFirst
Do Until rstCitationHyperlinks.EOF = True
sQFindCitation = rstCitationHyperlinks.Fields("FindCitation").Value
qReplaceHyperlink = rstCitationHyperlinks.Fields("ReplaceHyperlink").Value
sQLongCitation = rstCitationHyperlinks.Fields("LongCitation").Value
sQCHCategory = rstCitationHyperlinks.Fields("CHCategory").Value
sQWebAddress = rstCitationHyperlinks.Fields("WebAddress").Value
With oWordDoc
.Application.Selection.Find.ClearFormatting
.Application.Selection.Find.Replacement.ClearFormatting
With .Application.Selection.Find
.Text = sQFindCitation
.Replacement.Text = sQFindCitation
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
Do While .Application.Selection.Find.Execute(FindText:=sQFindCitation, Forward:=True) = True
oWordDoc.Hyperlinks.Add Anchor:=.Application.Selection.Range, _
Address:=sQWebAddress, ScreenTip:=sQLongCitation & ":" & Chr(13) & sQWebAddress, _
TextToDisplay:=sQFindCitation
Loop
oWordDoc.TablesOfAuthorities.MarkAllCitations ShortCitation:=sQFindCitation, _
LongCitation:=sQLongCitation, LongCitationAutoText:=sQLongCitation, Category:=sQCHCategory
oWordDoc.Application.Selection.HomeKey Unit:=wdStory
End With
End With
sQFindCitation = ""
qReplaceHyperlink = ""
sQLongCitation = ""
sQCHCategory = ""
sQWebAddress = ""
rstCitationHyperlinks.MoveNext
Loop
End If
oWordDoc.Application.Selection.HomeKey Unit:=wdStory
oWordDoc.Application.ActiveWindow.ActivePane.View.ShowAll = Not oWordDoc.Application.ActiveWindow.ActivePane.View.ShowAll
oWordDoc.Application.Selection.Find.ClearFormatting
oWordDoc.Application.Selection.Find.Replacement.ClearFormatting
With oWordDoc.Application.Selection.Find
.Text = "l [\""](*)[\""] [\\]s [\""](*)[\""]"
.Replacement.Text = "l ""\1"" ^92s ""\1"""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
oWordDoc.Application.Selection.Find.Execute Replace:=wdReplaceAll
oWordDoc.SaveAs filename:=sFileName
oWordDoc.Close
oWordApp.Quit
End If
rstCitationHyperlinks.Close
db.Close
Beep
Err.Clear
FindAndReplace_Exit:
Exit Function
FindAndReplace_Err:
If (Err = 2302) Then
MsgBox "Path is no longer valid. Please revise table.", vbOKOnly
Else
MsgBox Err.Description
End If
Resume Next
End Function