-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathvb version 3
121 lines (99 loc) · 4.22 KB
/
vb version 3
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
121
Sub CheckSTEWordCheck()
Dim doc As Document
Dim incorrectWord As Variant
Dim replacementWord As String
Dim correctionsDict As Object
Dim wordRange As Range
Dim excelApp As Object, workbook As Object, sheet As Object
Dim row As Long, lastRow As Long
Dim excelFilePath As String
Dim selectedRange As Range
Dim updateCount As Long
Dim userEmail As String
Dim logFilePath As String
Dim logFileName As String
' Ensure there is a selection
If Selection.Type = wdNoSelection Then
MsgBox "Please select the text to be checked.", vbExclamation
Exit Sub
End If
' Set the active document and selected range
Set doc = ActiveDocument
Set selectedRange = Selection.Range
' Specify the Excel file path containing corrections
excelFilePath = "\\path\to\your\corrections\file\grammatical_corrections.xlsx"
' Initialize the dictionary
Set correctionsDict = CreateObject("Scripting.Dictionary")
' Open Excel
On Error Resume Next
Set excelApp = CreateObject("Excel.Application")
If excelApp Is Nothing Then
MsgBox "Excel could not be started. Make sure Excel is installed.", vbCritical
Exit Sub
End If
excelApp.Visible = False
Set workbook = excelApp.Workbooks.Open(excelFilePath)
On Error GoTo 0
If workbook Is Nothing Then
MsgBox "The specified Excel file could not be opened. Please check the file path.", vbCritical
excelApp.Quit
Set excelApp = Nothing
Exit Sub
End If
' Load corrections into the dictionary
Set sheet = workbook.Sheets(1)
lastRow = sheet.Cells(sheet.Rows.Count, 1).End(-4162).Row ' -4162 is xlUp
For row = 2 To lastRow
incorrectWord = Trim(LCase(sheet.Cells(row, 1).Value))
replacementWord = Trim(sheet.Cells(row, 2).Value)
If Not correctionsDict.Exists(incorrectWord) Then
correctionsDict.Add incorrectWord, replacementWord
End If
Next row
' Close Excel
workbook.Close False
excelApp.Quit
Set excelApp = Nothing
' Initialize counters
updateCount = 0
' Main loop for grammar check
For Each wordRange In selectedRange.Words
' Process only words that are not filled with yellow (already corrected)
If wordRange.Shading.BackgroundPatternColor <> wdColorYellow Then
Dim coreWord As String
coreWord = Trim(LCase(wordRange.Text))
' Check if word is in corrections dictionary and hasn't already been corrected
If correctionsDict.Exists(coreWord) Then
Dim originalText As String
originalText = Trim(wordRange.Text)
' Replace text and apply color formatting
wordRange.Text = originalText & " (" & correctionsDict(coreWord) & ")"
' Add a trailing space if needed
If Not Right(wordRange.Text, 1) = " " Then
wordRange.Text = wordRange.Text & " "
End If
' Apply color: original word in yellow, correction in green
wordRange.Shading.BackgroundPatternColor = wdColorGreen
' Highlight the appended correction text in yellow
wordRange.MoveEnd wdCharacter, -Len(correctionsDict(coreWord)) - 3 ' Moves to the correction
wordRange.Shading.BackgroundPatternColor = wdColorYellow
End If
End If
' Increment counter and allow Word to process events
updateCount = updateCount + 1
If updateCount Mod 10 = 0 Then DoEvents
Next wordRange
' Final cleanup
Application.ScreenUpdating = True
Application.StatusBar = "Grammar check completed."
' Log completion details
userEmail = Environ("UserName") & "@company.com" ' Replace with method to get actual email if needed
logFilePath = "\\path\to\your\log\folder\"
logFileName = "STE_Macro_Run_Log.txt"
' Log the macro run with timestamp and user information
Open logFilePath & logFileName For Append As #1
Print #1, "User: " & userEmail & ", Document: " & doc.Name & ", Date: " & Now
Close #1
' Display completion message
MsgBox "Grammar check completed. A summary has been logged.", vbInformation
End Sub