Useful VBA utilities for Microsoft Word (Core Eddie-Code):
Author: Eddie Kumar Shrivastava
'******************************************************************************************
'Written by: Eddie Kumar Shrivastava
'Description: Eddie-Tools to speed up the data-processing/editing/formatting etc. for Microsoft Word.
'Readonly link: https://officeapptips.blogspot.com/2021/06/useful-vba-utilities-for-microsoft-word.html
'Editable-Repo: https://www.blogger.com/u/1/blog/posts/5593580733288490407
'Date Created: 05-02-2012
'Last Modified: 23-06-2022
'Version: 4.11
'Version info/Change Log/Subs-List:
'------------------------------------------------------------------------------------------
' SUBs - Keyboard-Shortcuts Assigned
'------------------------------------------------------------------------------------------
'''''''''''''''''''''''' SPELLING & GRAMMAR ''''''''''''''''''''''''
'- Sub IgnoreSpellingAndGrammar() - Alt + i
'- Sub DontIgnoreSpellingAndGrammar() - Ctrl + Shift + Alt + i
'- Sub IgnoreSpellingInBlockBrackets() - Ctrl + Shift + Alt + [
'''''''''''''''''''''''' SPACING ''''''''''''''''''''''''
'- Sub RemoveSpaceAboveBelow() - Alt + R
'- Sub AddSpaceAboveBelow() - Shift + Alt + R
'- Sub AddSpaceAbove() - Ctrl + Shift + Alt + R
'- Sub AddMinorSpaceAbove() -
'- Sub AddSpaceAboveDONOTUSE() -
'- Sub LineSpacing1_3() - Alt + 3
'''''''''''''''''''''''' TABLES ''''''''''''''''''''''''
'- Sub FormatTable() - Ctrl + Shift + Alt + F
'- Sub TabsToTable() - Alt + T / Ctrl + Shift + Alt + T
'''''''''''''''''''''''' HIGHLIGHTING ''''''''''''''''''''''''
'- Sub Highlight1stCharacter() - Ctrl + Shift + Alt + H
'- Sub Caps1stChar() -
'- Sub BoldTopicsInList() - Ctrl + Shift + Alt + B
'- Sub HighlightCodeTillColon() - Ctrl + Shift + Alt + C
'''''''''''''''''''''''' HEADERS ''''''''''''''''''''''''
'- Sub SetHeading4() - Ctrl + Alt + 4 (in line with other Headers' shortcuts)
'- Sub SetHeading5() - Ctrl + Alt + 5 (in line with other Headers' shortcuts)
'''''''''''''''''''''''' Ed-Utilities ''''''''''''''''''''''''
'- Sub WriteSequenceFile() -
'- Sub PasteAsUnformattedText() - Alt + V
'- Sub eq_JiraLinkFromSelection() - Ctrl + Shift + Alt + L
'- Sub eq_7IMBugFromSelection() - Ctrl + Shift + Alt + K
''''''''''''''''''''''''Ed-VBA-Reusable-Code-Assist''''''''''''''''''''''''
'- Sub FlushImmediateWindow() - Ctrl + Shift + Alt + Del
'- Sub ConfirmRun() -
'''''''''''''''''''''''' Export-Utilities ''''''''''''''''''''''''
'- Sub ExportAsPDF() - Ctrl + Shift + Alt + P
'- Sub SaveAsDocx() - Ctrl + Shift + Alt + S
'''''''''''''''''''''''' Ed-Useful-VBA-Code-Sample ''''''''''''''''''''''''
'- Sub ReplaceSomeTextUsingRegExp() -
'- Sub EmptyParagraphsCount() -
'- Sub ParseSentenceInEachParagraph() -
'- Sub RangeSelectionTest() -
'- Sub CatchSpecificError() -
'- Function Clipboard() -
'- Sub ClipboardTest() -
'- Sub getPathCurrentFile() -
'- Sub GetPathsOfCurrentFileWordBinaryAndMyDoc()
'- Sub getUserDesktopPath() -
'******************************************************************************************
'''''''''''''''''''''''' Spalling & Grammar ''''''''''''''''''''''''
'Following disables the "Spelling & Grammar" checks (i.e. ignores spellings/grammar errors) for the selected text:
'Select (a paragraph) then run:
Sub IgnoreSpellingAndGrammar()
Selection.NoProofing = True
End Sub
'Following enables the "Spelling & Grammar" checks for the selected text:
'Select (a paragraph) then run:
Sub DontIgnoreSpellingAndGrammar()
Selection.NoProofing = False
End Sub
'Following disables the "Spelling & Grammar" checks for the text within Square Brackets and formats (main) word preceding to '[' as bold.
'Select a line/paragraph containing text within [block brackets] then run:
Sub IgnoreSpellingInBlockBrackets()
Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticCharacters) 'excludes punctuations.
If cnt <= 0 Then
MsgBox "Nothing selected, please select line(s) to disable the 'Spelling & Grammar' checks for the text within Square Brackets."
End
End If
' For Each l In Selection.Words
' Debug.Print w 'NOT useful as it treats [square brackets] as separate word.
' Next
Dim paras As Paragraphs
Dim para As Paragraph
Dim sents As Sentences
Dim paraText As String
Dim sent As Range
Dim selRng As Range: Set selRng = Selection.Range
Set paras = selRng.Paragraphs 'for selection only
'Set paras = ActiveDocument.Paragraphs 'for whole document
Dim t As String
Dim intStart, intEnd As Integer
Selection.MoveLeft Unit:=wdCharacter, Count:=1
For Each para In paras
paraText = Trim(para.Range.Text)
paraTextLength = Len(paraText)
If (paraTextLength > 1) Then '1 new-line char is always present in each paragraph.
'Debug.Print (paraText)
t = paraText
intStart = InStr(1, t, "[", vbTextCompare)
If (intStart < 1) Then
GoTo NextIteration
End If
'Bold preceding word:
intEnd = intStart - 1
intStart = 1
Debug.Print intEnd
Debug.Print intStart
Selection.MoveRight Unit:=wdCharacter, Count:=(intEnd - intStart), Extend:=wdExtend
Selection.Font.Bold = True
'NoProofing:
intEnd = InStr(intStart, t, "]", vbTextCompare)
intEnd = intEnd + 1
Selection.MoveRight Unit:=wdCharacter, Count:=intStart - 1
Selection.MoveRight Unit:=wdCharacter, Count:=(intEnd - intStart), Extend:=wdExtend
Selection.NoProofing = True
End If
NextIteration:
Selection.MoveDown Unit:=wdParagraph, Count:=1 ', Extend:=wdExtend 'default value is wdLine
Next
selRng.Select
End
'FOLLOWING WORKS FINE BUT NOT USEFUL IN THIS CONTEXT AS LONG & TEDIOUS:
'Count = Selection.Characters.Count
'For i = 1 To Count
' If Selection.Characters(i).Text = "[" Then
' 'Set rStart = Selection.Characters(i).index
' ElseIf Selection.Characters(i).Text = "]" Then
' 'Set rEnd = Selection.Characters(i).Range
' End If
'Next
'Dim rng As Range
'Set rng = ActiveDocument.Range(start:=rStart, End:=rEnd)
'rng.Select
'Selection.Font.Bold = True
'With Selection.Find
'.Forward = True
'.ClearFormatting
'.MatchWholeWord = True
'.MatchCase = False
'.Wrap = wdFindContinue
'.Execute FindText:="["
'End With
'Dim rng As Range
'Set rng = ActiveDocument.Range(start:=ActiveDocument.Paragraphs(1).Range.start, End:=ActiveDocument.Paragraphs(4).Range.End)
'rng.Select
'Selection.Font.Bold = True
End Sub
'Following disables the "Spelling & Grammar" checks for the text within Square Brackets (without bold formatting):
'Select a line/paragraph containing text within [block brackets] then run:
Sub IgnoreSpellingInBlockBracketsWihtoutBoldPreceding()
Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticCharacters) 'excludes punctuations.
If cnt <= 0 Then
MsgBox "Nothing selected, please select line(s) to disable the 'Spelling & Grammar' checks for the text within Square Brackets."
End
End If
' For Each l In Selection.Words
' Debug.Print w 'NOT useful as it treats [square brackets] as separate word.
' Next
Dim paras As Paragraphs
Dim para As Paragraph
Dim sents As Sentences
Dim paraText As String
Dim sent As Range
Dim selRng As Range: Set selRng = Selection.Range
Set paras = selRng.Paragraphs 'for selection only
'Set paras = ActiveDocument.Paragraphs 'for whole document
Dim t As String
Dim intStart, intEnd As Integer
Selection.MoveLeft Unit:=wdCharacter, Count:=1
For Each para In paras
paraText = Trim(para.Range.Text)
paraTextLength = Len(paraText)
If (paraTextLength > 1) Then '1 new-line char is always present in each paragraph.
'Debug.Print (paraText)
t = paraText
intStart = InStr(1, t, "[", vbTextCompare)
If (intStart < 1) Then
GoTo NextIteration
End If
intEnd = InStr(intStart, t, "]", vbTextCompare)
intEnd = intEnd + 1
'Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=intStart - 1
Selection.MoveRight Unit:=wdCharacter, Count:=(intEnd - intStart), Extend:=wdExtend
'Selection.Font.Bold = True
Selection.NoProofing = True
End If
NextIteration:
Selection.MoveDown Unit:=wdParagraph, Count:=1 ', Extend:=wdExtend 'default value is wdLine
Next
selRng.Select
End Sub
'''''''''''''''''''''''' Spacing ''''''''''''''''''''''''
'Following sub removes Paragraph-Spacing from above & below the selected text:
Sub RemoveSpaceAboveBelow()
Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
With Selection.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
End With
End Sub
'Following adds Paragraph-Spacing above & below the selected line:
Sub AddSpaceAboveBelow()
With Selection.ParagraphFormat
.SpaceBefore = 6
.SpaceBeforeAuto = False
.SpaceAfter = 6
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
' .MirrorIndents = False
' .TextboxTightWrap = wdTightNone
' .CollapsedByDefault = False
End With
End Sub
'Following sub adds Paragraph-Spacing above the selected text:
Sub AddSpaceAbove()
Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
With Dialogs(wdDialogFormatParagraph)
.Before = 14
.After = 0
.NoSpaceBetweenParagraphsOfSameStyle = False
.Execute
End With
End Sub
'Following sub adds smaller Paragraph-Spacing above the selected text:
Sub AddMinorSpaceAbove()
With Selection.ParagraphFormat
.SpaceBefore = 4
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
End With
End Sub
'Following uses standard VBA code in attempt to add Paragraph-Spacing above the selected text, however doesn't work see PROBLEM:
Sub AddSpaceAboveDONOTUSE()
With Selection.ParagraphFormat
.SpaceBefore = 8
.SpaceBeforeAuto = False
.SpaceAfter = 2
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
' .MirrorIndents = False
' .TextboxTightWrap = wdTightNone
' .CollapsedByDefault = False
End With
'PROBLEM WITH NoSpaceBetweenParagraphsOfSameStyle RESETS ENTIRE STYLE:
'ActiveDocument.Styles("Normal").NoSpaceBetweenParagraphsOfSameStyle = False
'Selection.Style.NoSpaceBetweenParagraphsOfSameStyle = False
'SOLUTION: use Word Dialogs control (wdDialogFormatParagraph)
End Sub
'Following sub sets the line spacing to 1.3 on selected text and removes Paragraph-Spacing from above & below:
Sub LineSpacing1_3()
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 10
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceMultiple
.LineSpacing = LinesToPoints(1.1)
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = True
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
.CollapsedByDefault = False
.ReadingOrder = wdReadingOrderLtr
End With
End Sub
'''''''''''''''''''''''' TABLES ''''''''''''''''''''''''
'Following formats table (in which cursor is placed):
Sub FormatTable()
If Selection.Information(wdWithInTable) = False Then
MsgBox "Table not found. " & vbNewLine & vbNewLine & "Cursor/Selection must be within a table.", vbInformation, "Format Table"
End
End If
'Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).Style = "Table Grid Light"
Call LineSpacing1_3
End Sub
'Following sub converts tab delimitted lines into a table:
Sub TabsToTable()
'Check if cursor is in existing table:
If Selection.Information(wdWithInTable) = True Then
MsgBox "Table already exists" & vbNewLine & vbNewLine & " OR" & vbNewLine & vbNewLine & "You have selected a Table (instead of set of tab separated values)", vbOKOnly & vbCritical, "Curson in Table"
Exit Sub
End If
'Check if text is selected:
If Not (Selection.Type <> wdSelectionIP) Then
MsgBox "Text not selected." & vbNewLine & vbNewLine & "Please select (set of) tab separated values to convert/format them in to a table.", vbOKOnly & vbExclamation, "Selection not found"
Exit Sub
End If
'Convert Tabs to Table:
Selection.ConvertToTable Separator:=wdSeparateByTabs, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
'.Style = "Table Grid"
.Style = "Table Grid Light"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
'.AutoFitBehavior (wdAutoFitContent)
.Rows(1).Select 'Select 1st Row
End With
Selection.Font.Bold = wdToggle 'Bold selected values (in row)
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 'Centre selected values
'Indent entire table:
Selection.Tables(1).Select
Selection.Paragraphs.Indent
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
End Sub
'''''''''''''''''''''''' HIGHLIGHTING ''''''''''''''''''''''''
'Ver5: (EdChoice) Excludes all non-alphabets & certain words stored in Array elements,
'this array eliminates the need for writing long IF statement comparing each excluded word.
'Also removes boldness from selection, this is important for consistent result.
Sub Highlight1stCharacter()
'Dim cnt As Integer: cnt = Selection.Words.Count ' Not accurate as count includes punctuations & carriage returns signs.
Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticWords) 'more accurate as excludes punctuations.
If cnt <= 0 Then
MsgBox "Nothing selected, please select word(s) to highlight its first letter{(s)."
End
End If
Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp") 'using Late Binding. 'Dim regEx As New RegExp 'requires Early Binding
regEx.Pattern = "[a-zA-Z]" 'requires: VBE>Tools>Reference: "Microsoft VBScript Regular Expressions 5.5".
Dim excl() As String
excl() = Split("and, of, for, to, with, in, on, a, an, the", ", ") 'One-liner array assignment.
'remove boldness from selection, this is important for consistent result:
Selection.Font.Bold = False
'move (without wdExtend) cursor to the left/beginning of the selection:
Selection.MoveLeft Unit:=wdCharacter, Count:=1
'running a loop to select the 1st character then highlight it:
'For Each w In Selection.Words 'this won't work here as we need to alter the Words in selection.
For i = 1 To cnt
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend 'select single word
'MsgBox (Selection) 'check which word
'If (Selection = "of " Or Selection = "for " Or Selection = (Chr(34) & ","))
'postfix-whitespace is essential i.e. "of " instead of "of" otherwise offline/often etc. will be omitted.
For Each x In excl
'If (InStr(Selection, x & " ") > 0) Then 'doesn't work as searches x inString of Selection.
If LCase(Trim(Selection)) = x Then
Selection.MoveRight Unit:=wdWord, Count:=1
GoTo NextIteration
End If
Next x
'above array-iteration replaces need of following Loooooong if statement:
'If (InStr(Selection, "of ") > 0 Or InStr(Selection, "for ") > 0 Or InStr(Selection, "and ") > 0 Or InStr(Selection, "to ") > 0) Then
Selection.MoveLeft Unit:=wdWord, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'check if selected character is an alphabet:
If (regEx.test(Selection)) Then
'Selection.Font.Bold = True
Selection.Font.Bold = wdToggle
Selection.Range.Case = wdUpperCase
End If
Selection.MoveRight Unit:=wdWord, Count:=1
NextIteration:
Next i
End Sub
'ProperCase by macro
Sub Caps1stChar()
'This will convert the case of the first letter of selection into uppercase.
Dim txt As String
txt = ""
For i = 1 To Selection.Words.Count
txt = txt & StrConv(Selection.Words(i), vbProperCase)
Next i
Selection.Text = txt
End Sub
'Following sub highlights/bolds the first part for each sentence (in selection) till colon (:), useful for "list with highlighted topics":
Sub BoldTopicsInList()
Dim lineCount As Integer: lineCount = Selection.Paragraphs.Count
Dim currentPosition As Range
Set currentPosition = Selection.Range 'record current selection / cursor position
Selection.Font.Bold = False 'remove bold from entire selection (for consistent result)
Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticWords) 'more accurate as excludes punctuations.
If cnt <= 0 Then
MsgBox "Nothing selected, please select line(s) to highlight its topic separated by a colon (:)."
End
End If
'For Each p In Selection.Paragraphs
For i = 1 To lineCount
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
linetext = Selection.Range.Text
idx = InStr(linetext, ":")
If idx <= 0 Or Selection.Characters(idx + 1).Text = "\" Then
GoTo NextIteration
End If
idx = idx - 1
Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=idx, Extend:=wdExtend 'select chars till colon
Selection.Font.Bold = True 'Selection.Style = ActiveDocument.Styles("Code highlighted")
NextIteration:
Selection.MoveDown Unit:=wdParagraph, Count:=1 ' move cursor to next paragraph without extending selection.
Next i
currentPosition.Select 'return cursor/selection back to original position.
End Sub
'Following sub highlights the part for each sentence (in selection) till colon (:), useful for "creating a list with highlighted (command-line) Commands":
Sub HighlightCodeTillColon()
Dim lineCount As Integer: lineCount = Selection.Paragraphs.Count
Dim currentPosition As Range
Set currentPosition = Selection.Range 'record current selection / cursor position
Selection.Font.Bold = False 'remove bold from entire selection (for consistent result)
Dim cnt As Integer: cnt = Selection.Range.ComputeStatistics(wdStatisticWords) 'more accurate as excludes punctuations.
If cnt <= 0 Then
MsgBox "Nothing selected, please select line(s) to highlight its topic separated by a colon (:)."
End
End If
'For Each p In Selection.Paragraphs
For i = 1 To lineCount
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
linetext = Selection.Range.Text
idx = InStr(linetext, ":")
If idx <= 0 Then
GoTo NextIteration
End If
idx = idx - 1
Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=idx, Extend:=wdExtend 'select chars till colon
Selection.Style = ActiveDocument.Styles("Code highlighted") 'Selection.Font.Bold = True
'Selection.Style = ActiveDocument.Styles("Code with Background") '"Code highlighted" 'Selection.Font.Bold = True
Selection.NoProofing = True
NextIteration:
Selection.MoveDown Unit:=wdParagraph, Count:=1 ' move cursor to next paragraph without extending selection.
Next i
currentPosition.Select 'return cursor/selection back to original position.
End Sub
'''''''''''''''''''''''' HEADERS ''''''''''''''''''''''''
Sub SetHeading4()
Selection.Style = ActiveDocument.Styles("Heading 4")
End Sub
Sub SetHeading5()
Selection.Style = ActiveDocument.Styles("Heading 5")
End Sub
'''''''''''''''''''''''''Ed-Utilities''''''''''''''''''''
'Following is used for IT-Training Invoice generation via VBA-Form:
Sub WriteSequenceFile()
System.PrivateProfileString("C:\test\id_sequence.txt", "id_sequence", "id") = 1001
End Sub
'Paste as plain text / Paste unformatted text / Paste as Template Text:
Sub PasteAsUnformattedText()
On Error GoTo ErrHndl
Selection.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:=wdInLine, DisplayAsIcon:=False
GoTo Done
ErrHndl:
Select Case Err.Number ' Evaluate error number.
Case 4198 '4198 is usually an unknown/generic error.
Case 4605 '4605 mothod/property is not available because Clipboard is empty or not valid.
MsgBox "Clipboard empty: Nothing to paste.", vbInformation, "Empty Clipboard"
GoTo Done
Case 5342 '5342 is usually when non-textual (pic/audio/video) is in clipboard, so obviously can't be pasted as text.
MsgBox "A non-textual object (such as picture/audio/video) is found/copied to the Clipboard, which can't be pasted as text." _
& vbNewLine & vbNewLine & "Copy text only then try again.", vbInformation, "Non-Textual Object"
GoTo Done
Case Else
MsgBox "Error# " & Err.Number & " : " & Err.Description
On Error GoTo Unicode
End Select
Unicode:
Selection.PasteAndFormat (wdFormatPlainText)
Done:
End Sub
'Following sub converts currently selected text into a hyperlink to "7IM Jira + current selection":
'e.g.: SPP-6415 (as long as text is selected) it will become a link to Editable-Jira ("https://canadalife.atlassian.net/browse/SPP-6415")
'Ctrl+Shift+Alt + L: (L for Link):
Sub eq_JiraLinkFromSelection()
Dim jirano As String: jirano = Selection.Text
Let jirano = UCase(jirano)
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="https://7imhelpdesk.atlassian.net/browse/" & jirano, _
SubAddress:="", ScreenTip:="7IM Jira Link/URL", TextToDisplay:=jirano
End Sub
'Following sub converts currently selected text into a hyperlink to "7IM Read-only-Jira + current selection":
'e.g.: RFC-1514 (as long as text is selected) it will become a link to Read-only-Jira ("https://7imhelpdesk.atlassian.net/servicedesk/customer/portal/6/RFC-1514")
'Ctrl+Shift+Alt + J: (J for Jira):
Sub eq_ReadOnlyJiraLinkFromSelection()
Dim jirano As String
Let jirano = Selection.Text
Let jirano = UCase(jirano)
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="https://7imhelpdesk.atlassian.net/servicedesk/customer/portal/6/" & jirano, _
SubAddress:="", ScreenTip:="7IM Jira Link/URL", TextToDisplay:=jirano
End Sub
'Following sub converts currently selected text into a hyperlink to "7IM Bug + current selection":
'e.g.: 95545 to become: "http://itdevtfs1:8080/tfs/DefaultCollection/Live%20Bugs/_workitems/edit/95545"
'New: 100975 to become: https://azuredevops.7im.co.uk/DefaultCollection/Projects/_workitems/edit/100975
'Ctrl+Shift+Alt + K: (K for worK item):
Sub eq_7IMBugFromSelection()
Dim jirano As String
Let jirano = Selection.Text
Let jirano = UCase(jirano)
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="https://azuredevops.7im.co.uk/DefaultCollection/Projects/_workitems/edit/" & jirano, _
SubAddress:="", ScreenTip:="7IM DevOps Project-WorkItem OR Bug link/URL", TextToDisplay:=jirano
'ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _
'Address:="http://itdevtfs1:8080/tfs/DefaultCollection/Live%20Bugs/_workitems/edit/" & jirano, _
'SubAddress:="", ScreenTip:="7IM DevOps Bug Link/URL", TextToDisplay:=jirano
End Sub
''''''''''''''''''''''''Ed-VBA-Reusable-Code-Assist''''''''''''''''''''''''
'Following code clears the Immediate window pane:
Sub FlushImmediateWindow()
'Debug.Print VBA.String(200, vbNewLine) 'flush its content instead of SnedKeys
SendKeys "^{g}", False
DoEvents
SendKeys "^{Home}", False
SendKeys "^+{End}", False
SendKeys "{Del}", False
SendKeys "{F7}", False
End Sub
Sub ConfirmRun(subName)
Dim ans As String
ans = MsgBox("Would you like to continue with """ & subName & """", vbYesNo, "Confirm Execution")
If ans = vbNo Then
End
End If
End Sub
'''''''''''''''''''''''' Export-Utilities ''''''''''''''''''''''''
'Following module instantly/silently exports the existing document as as PDF - placing it in the current folder of source file (or if unsaved, on the current-user's Desktop):
Sub ExportAsPDF()
Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")
Dim pathToDesktop As String
pathToDesktop = wsh.SpecialFolders("Desktop")
Dim docPath As String
If Len(ActiveDocument.Path) <= 0 Or ActiveDocument.Path Like "http*" Then ' Or ActiveDocument.name Like "Document#" Or ActiveDocument.name Like "Document##"
docPath = pathToDesktop '"C:\temp" 'alternatively use netowrk UNC path.
'docPath = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\temp" '-> returns customised Documents folder (not the User Document folder.)
Else
docPath = ActiveDocument.Path
End If
'If ActiveDocument.Path Like "http*" Then
' docPath = docPath & "/"
'Else
' docPath = docPath & "\"
'End If
docPath = docPath & "\"
Debug.Print docPath
Dim docName As String: docName = ActiveDocument.Name
'docName = docName & "_" & Format(Now, "dd-MM-yyyy_hhnnss") & ".pdf"
Dim fileExt As String: fileExt = Right(docName, 5)
If fileExt = ".docx" Then
docName = Replace(docName, fileExt, ".pdf")
Else
docName = docName & "_" & Format(Now, "dd-MM-yyyy_hhnnss") & ".pdf"
End If
ChangeFileOpenDirectory docPath
ActiveDocument.ExportAsFixedFormat OutputFileName:=docName, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
MsgBox "Document exported as: """ & docName & """" & vbNewLine & vbNewLine & "Saved under: " & docPath
End Sub
'Following module instantly/silently saves/exports the existing document as standard Docx - placing it in the current folder
'of the source file (or if unsaved, places the file into the "C:\Temp\" folder / on the current-user's Desktop):
Sub SaveAsDocx()
Dim docPath As String
If Len(ActiveDocument.Path) <= 0 Or ActiveDocument.Path Like "http*" Then ' Or ActiveDocument.name Like "Document#" Or ActiveDocument.name Like "Document##"
docPath = "C:\temp" 'alternatively use netowrk UNC path.
'Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")
'Dim pathToDesktop As String: pathToDesktop = wsh.SpecialFolders("Desktop")
'pathToDesktop = wsh.SpecialFolders("Desktop")
'docPath = pathToDesktop
'docPath = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\temp" '-> returns customised Documents folder (not the User Document folder.)
Else
docPath = ActiveDocument.Path
End If
'If ActiveDocument.Path Like "http*" Then
' docPath = docPath & "/"
'Else
' docPath = docPath & "\"
'End If
docPath = docPath & "\"
'Debug.Print docPath
Dim docName As String: docName = ActiveDocument.Name
'Debug.Print docName '=> "Document1" if unsaved.
Dim selectedText As String: selectedText = Selection.Text
'If docName = "Document1" Or ActiveDocument.name Like "Document#" Or ActiveDocument.name Like "Document##" Then
'Debug.Print Len(Trim(selectedText)) '"1" if nothing/no text is selected.
If Len(selectedText) > 1 Then
selectedText = Replace(selectedText, vbCr, "")
docName = selectedText
End If
docName = docName & "_" & Format(Now, "yyyy-MM-dd_hhnnss") & ".docx"
Debug.Print docName '=> "Document1_2023-08-08_103958.docx" if unsaved.
ChangeFileOpenDirectory docPath
ActiveDocument.SaveAs2 FileName:=docName, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False ', CompatibilityMode:=15
MsgBox "Document saved as: """ & docName & """" & vbNewLine & vbNewLine & "Placed under: " & docPath
End Sub
'''''''''''''''''''''''''''Ed-Useful-VBA-Code-Sample'''''''''''''''''''''''''
'Following removes the matching RegExp-pattern from each (selected) paragraph/line(s):
Sub ReplaceSomeTextUsingRegExp()
Set strSource = Application.Selection
If Len(strSource) <= 1 Then
MsgBox "Nothing selected." & vbNewLine & _
"Select paragraphs from which matching RegExp-pattern needs to be removed."
End
End If
pat = "[0-9]{1,2}\.\s" 'remove line-number.
Set regEx = CreateObject("VBScript.RegExp") 'Late binding
With regEx
.Pattern = pat
.IgnoreCase = True
.Global = True
.MultiLine = True
End With
If regEx.test(s) Then
Debug.Print (regEx.Replace(strSource, ""))
Else
Debug.Print ("No match found (for specified Pattern)")
End If
End Sub ' "12. Some text" => "Some text" if pattern is: "[0-9]{1,2}\.\s"
Sub EmptyParagraphsCount()
Dim selRng As Range: Set selRng = Selection.Range
Dim paras As Paragraphs: Set paras = selRng.Paragraphs
Dim cnt As Integer: cnt = 0
'For Each tempTable In ActiveDocument.Paragraphs
For Each para In paras
If Len(para.Range.Text) = 1 Then 'para.Range.Editors.Add wdEditorEveryone
cnt = cnt + 1
End If
Next
Debug.Print cnt
End Sub
Sub ParseSentenceInEachParagraph()
Dim paras As Paragraphs
Dim para As Paragraph
Dim sents As Sentences
Dim paraText As String
Dim sent As Range
Dim selRng As Range: Set selRng = Selection.Range
Set paras = selRng.Paragraphs 'for selection only
'Set paras = ActiveDocument.Paragraphs 'for whole document
For Each para In paras
paraText = Len(Trim(para.Range.Text))
If (paraText > 1) Then '1 new-line char is always present in each paragraph.
Set sents = para.Range.Sentences
For Each sent In sents
Debug.Print (sent.Text)
Next
End If
Next
End Sub
Sub RangeSelectionTest()
Dim rng As Range
Set rng = ActiveDocument.Range(Start:=1, End:=3)
rng.Select
Selection.Font.Bold = True
End Sub
Sub CatchSpecificError()
On Error GoTo ErrorHandler ' Enable error-handling routine.
Dim i As Integer
i = 2 / 0 ' Divide by ZERO Error Raises
ErrorHandler: ' Error-handling routine.
Select Case Err.Number ' Evaluate error number.
Case 11 ' Divide by zero error
MsgBox ("You attempted to divide by zero!")
Case Else
MsgBox "Unknown Error- Error# " & Err.Number & " : " & Err.Description
End Select
End Sub
'Following function allows you to both read from the clipboard and write to the
' clipboard depending on if you pass string value to the parameter:
Function Clipboard(Optional StoreText As String) As String
'PURPOSE: Read/Write to Clipboard
'Source: ExcelHero.com (Daniel Ferry)
Dim x As Variant
'Store as variant for 64-bit VBA support
x = StoreText
'Create HTMLFile Object
With CreateObject("htmlfile")
With .parentWindow.clipboardData
Select Case True
Case Len(StoreText)
'Write to the clipboard
.setData "text", x
Case Else
'Read from the clipboard (no variable passed through)
Clipboard = .GetData("text")
End Select
End With
End With
End Function
Sub ClipboardTest()
'Usage:
'Copy text to the clipboard:
Clipboard ("This will be copied to the Clipboard!")
'To read text from the clipboard:
MsgBox Clipboard
End Sub
'Displays the path of current file and copies it to the clipboard:
Sub getPathCurrentFile()
If Len(ActiveDocument.Path) <= 0 Then
docPath = "Unsaved Document!"
Else
docPath = ActiveDocument.Path
End If
x = CStr(docPath & "\" & ActiveDocument.Name)
Clipboard (x)
MsgBox docPath & vbNewLine & vbNewLine & ActiveDocument.Name
'MsgBox "_" & Format(Now, "dd-MM-yyyy_hhnnss")
End Sub
Sub GetPathsOfCurrentFileWordBinaryAndMyDoc()
Dim strPath As String
strPath = ThisDocument.FullName
strPath1 = ThisDocument.Path 'same as: & "CurDir"
strName = ThisDocument.Name
strCurDir = Application.Path
myDocDir = CreateObject("WScript.Shell").SpecialFolders("mydocuments") '-> returns customised Documents folder (not the User Document folder.)
'MsgBox (strName & vbNewLine & vbNewLine & strPath1 & vbNewLine & vbNewLine & strPath & vbNewLine & vbNewLine & strCurDir & vbNewLine & vbNewLine & myDocDir)
MsgBox ("File Name: " & strName & vbNewLine & vbNewLine & "File Path: " & strPath1 & vbNewLine & vbNewLine)
End Sub
Sub getUserDesktopPath()
'WSh - Early binding:
'Dim wsh As WshShell: Set wsh = New WshShell
'MsgBox wsh.SpecialFolders("Desktop") 'MyDocuments
'WSh - Late binding:
Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")
MsgBox wsh.SpecialFolders("Desktop")
End Sub
'------------ x -------------
List of some of my IT blogs:
- Java Exam Notes
- Coding Tips & Techniques
- MySQL Data-types Summary
- HTML Tips & Tricks
- Office Apps Tips & Techniques
- VBA Useful Code Samples
- Useful VBA utilities for Microsoft Excel
