MisterTootor M.S., B.S., A.S., A.S.B
Code to add hyperlinks to a word document (wellsr.com)
Sub HyperlinkReferences()
'---------------------------------------------------------------------------------------------------
'---Script: HyperlinkReferences---------------------------------------------------------------------
'---Created by: Ryan Wells (wellsr.com)-------------------------------------------------------------
'---Date: 05/2016-----------------------------------------------------------------------------------
'---Description: THIS SUBMODULE ADDS HYPERLINKS TO REFERENCES CONTAINED IN SQUARE ------------------
'----------------BRACKETS ( ex: [2.1] or [1] ). ----------------------------------------------------------
'---------------------------------------------------------------------------------------------------
'---Instructions:-----------------------------------------------------------------------------------
'-----BLOCK 0---------------------------------------------------------------------------------------
'------1) Change the variable ReferenceSection to whatever your reference section is in your--------
'------ document. Set it equal to "" if you refer to your references like [9] instead of [2.9]----
'-----BLOCK 1---------------------------------------------------------------------------------------
'------2) Add the reference hyperlinks to BLOCK 1.--------------------------------------------------
'------3) Change the *max* in dim ref(1 to *max*) to the number of references in your design calc.--
'------4) If you don't have a link to a reference, set that reference equal to "".------------------
'-----BLOCK 2---------------------------------------------------------------------------------------
'---------Changes to BLOCK 2 should not be required.------------------------------------------------
'---------------------------------------------------------------------------------------------------
Application.ScreenUpdating = False
Dim ReferenceSection As String
Dim rng As Range
'***************************************
'************* BLOCK 0 *************
'***************************************
ReferenceSection = ""
'***************************************
'************* BLOCK 1 *************
'***************************************
Dim ref(1 To 3) As String
ref(1) = ""
ref(2) = "https://inis.iaea.org/search/searchsinglerecord.aspx?recordsFor=SingleRecord&RN=39099974"
ref(3) = "http://rpd.oxfordjournals.org/content/74/3/163"
'***************************************
'************* BLOCK 2 *************
'***************************************
For i = 1 To UBound(ref) 'i = 1 to number of references
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
If ReferenceSection <> "" Then
.Text = "[" & ReferenceSection & "." & i & "]"
Else
.Text = "[" & i & "]"
End If
'.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
While Selection.Find.Execute
If Selection.Hyperlinks.Count > 0 Then
Selection.Hyperlinks(1).Delete
End If
If ref(i) <> "" Then
Set rng = Selection.Range
rng.SetRange Start:=rng.Start + 1, End:=rng.End - 1
Selection.Hyperlinks.Add Anchor:=rng, _
TextToDisplay:=Mid(Selection.Range.Text, 2, Len(Selection.Range.Text) - 2), _
Address:=ref(i)
End If
Wend
Next i
Application.ScreenUpdating = True
End Sub
AI version in creating a hyperlink
Sub AddHyperlink()
Dim hyperlinkText As String
Dim hyperlinkAddress As String
Dim rng As Range
' Define the text and address for the hyperlink
hyperlinkText = "Open ChatGPT"
hyperlinkAddress = "https://www.openai.com/chatgpt"
' Create a range at the current selection
Set rng = Selection.Range
' Insert the hyperlink at the selection
ActiveDocument.Hyperlinks.Add Anchor:=rng, Address:=hyperlinkAddress, TextToDisplay:=hyperlinkText
' Optional: Move the selection to the end of the newly added hyperlink
rng.Collapse Direction:=wdCollapseEnd
rng.Select
End Sub
Code to save word pages as separte PDFS
Option Explicit
Sub SaveAsSeparatePDFs()
'---------------------------------------------------------------------------------------------------
'---Script: SaveAsSeparatePDFs----------------------------------------------------------------------
'---Created by: Ryan Wells--------------------------------------------------------------------------
'---Date: 03/2015-----------------------------------------------------------------------------------
'---Description: This subroutine saves MS Word document pages as separate PDFs with file names------
'----------------formatted like Page_x.pdf.---------------------------------------------------------
'---------------------------------------------------------------------------------------------------
Dim strDirectory As String, strTemp As String
Dim ipgStart As Integer, ipgEnd As Integer
Dim iPDFnum As Integer, i As Integer
Dim vMsg As Variant, bError As Boolean
1:
strDirectory = InputBox("Directory to save individual PDFs? " & _
vbNewLine & "(ex: C:\Users\Public)")
If strDirectory = "" Then Exit Sub
If Dir(strDirectory, vbDirectory) = "" Then
vMsg = MsgBox("Please enter a valid directory.", vbOKCancel, "Invalid Directory")
If vMsg = 1 Then
GoTo 1
Else
Exit Sub
End If
End If
2:
strTemp = InputBox("Begin saving PDFs starting with page __? " & _
vbNewLine & "(ex: 32)")
bError = bErrorF(strTemp)
If bError = True Then GoTo 2
ipgStart = CInt(strTemp)
3:
strTemp = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 37)")
bError = bErrorF(strTemp)
If bError = True Then GoTo 3
ipgEnd = CInt(strTemp)
iPDFnum = ipgStart
On Error GoTo 4:
For i = ipgStart To ipgEnd
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strDirectory & "\Page_" & iPDFnum & ".pdf", ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _
IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False
iPDFnum = iPDFnum + 1
Next i
End
4:
vMsg = MsgBox("Unknown error encountered while creating PDFs." & vbNewLine & vbNewLine & _
"Aborting", vbCritical, "Error Encountered")
End Sub
Private Function bErrorF(strTemp As String) As Boolean
Dim i As Integer, vMsg As Variant
bErrorF = False
If strTemp = "" Then
End
ElseIf IsNumeric(strTemp) = True Then
i = CInt(strTemp)
If i > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Or i <= 0 Then
Call msgS(bErrorF)
End If
Else
Call msgS(bErrorF)
End If
End Function
Private Sub msgS(bMsg As Boolean)
Dim vMsg As Variant
vMsg = MsgBox("Please enter a valid integer." & vbNewLine & vbNewLine & _
"Integer must be > 0 and < total pages in the document (" & _
ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & ")", vbOKCancel, "Invalid Integer")
If vMsg = 1 Then
bMsg = True
Else
End
End If
End Sub
Code to Change your word cursor to a moving banana (works in excel (change 'ThisDocument' to 'ThisWorkbook')
​
https://wellsr.com/vba/2015/word/examples/change-cursor-when-file-open-office-prank/
Change Cursor with VBA
Private Declare Function LoadCursorFromFile Lib "user32.dll" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetSystemCursor Lib "user32.dll" (ByVal hcur As Long, ByVal id As Long) As Long
'---------------------------------------------------------------------------------------------------
'---Script: ChangeCursor----------------------------------------------------------------------------
'---Posted by: Ryan Wells---------------------------------------------------------------------------
'---Date: 03/2015-----------------------------------------------------------------------------------
'---Description: This VBA script chunks a *.ani file and stores the byte strings to the ------------
'----------------Custom Document Properties. After the initial setup, each time the file -----------
'----------------is opened, the *.ani file is recreated on the user's machine and the --------------
'----------------cursor will change to the *.ico file specified in BananaLoc. ----------------------
'---------------------------------------------------------------------------------------------------
Private Enum Cursors
OCR_APPSTARTING = 32650 'The application starting (arrow and hourglass) cursor.
OCR_CROSS = 32515 'The cross-shaped cursor.
OCR_IBEAM = 32513 'The text selection (I-beam) cursor.
OCR_ICON = 32641 'Win NT only: The empty icon cursor.
OCR_NO = 32648 'The "no"-symbol (circle with slash through it) cursor.
OCR_NORMAL = 32512 'The normal arrow cursor.
OCR_SIZE = 32640 'Win NT only: The four-arrow resize/move cursor.
OCR_SIZEALL = 32646
OCR_SIZENESW = 32643
OCR_SIZENS = 32645
OCR_SIZENWSE = 32642
OCR_SIZEWE = 32644
OCR_UP = 32516
OCR_WAIT = 32514
End Enum
Sub ConvertBanana()
'Run this first. Change the string inside StoreBanana to the location of your ani file.
Call StoreBanana("c:\temp\banana.ani")
End Sub
Private Sub StoreBanana(fn As String)
' Store byte strings in your custom document properties
Dim Bytes As String, Bytestring As String
ClearBanana
Open fn For Binary Access Read As #1
Bytes = Space(LOF(1))
Get #1, , Bytes
Close #1
For i = 1 To Len(Bytes)
Bytestring = Bytestring & Asc(Mid(Bytes, i, 1)) & " "
Next
Bytestring = Trim(Bytestring)
Dim d As DocumentProperties
Set d = ThisDocument.CustomDocumentProperties
chunk = 0
While chunk < Len(Bytestring)
d.Add "RyanWellsCursor" & chunk / 255, False, MsoDocProperties.msoPropertyTypeString, Mid(Bytestring, chunk + 1, 255)
chunk = chunk + 255
Wend
Set d = Nothing
End Sub
Sub AutoOpen()
GetBanana
ChangeCursor "c:\temp\banana.ani", False
End Sub
Sub AutoClose()
ChangeCursor "C:\windows\cursors\aero_arrow.cur", False
End Sub
Private Sub ClearBanana()
Dim d As DocumentProperty
For Each d In ThisDocument.CustomDocumentProperties
If d.Name Like "RyanWellsCursor*" Then
ThisDocument.CustomDocumentProperties(d.Name).Delete
End If
Next
End Sub
Private Sub GetBanana()
'Resurrects *.ani file from document properties and saves it as banana.ani
Dim d As DocumentProperty, f As Integer, BananaLoc As String, Banana As String, Bytes
BananaLoc = "c:\temp\banana.ani"
f = FreeFile
If Dir(BananaLoc) <> "" Then Kill BananaLoc
For Each d In ThisDocument.CustomDocumentProperties
If d.Name Like "RyanWellsCursor*" Then
Banana = Banana & d.Value
End If
Next
Bytes = Split(Banana, " ")
Banana = ""
For i = 0 To UBound(Bytes)
Debug.Print i
Banana = Banana & Chr(Int(Bytes(i)))
Next
Open BananaLoc For Binary Access Write As #f
Put #f, , Banana
Close #f
End Sub
Private Sub ChangeCursor(fn As String, alert As Boolean)
'changes cursor
Dim hCursor As Long
Static PeanutButterJellyTime As Boolean
hCursor = LoadCursorFromFile(fn)
If hCursor Then
Call SetSystemCursor(hCursor, Cursors.OCR_NORMAL)
PeanutButterJellyTime = True
If alert Then MsgBox "It's Peanut Butter Jelly Time!", vbOKOnly Or vbExclamation, "WHAT?!"
End If
End Sub
Code to insert a date using the Time field
​
Sub InsertDateTimeMethod()
Dim MyRange As Object
Set MyRange = Selection.Range
' Selection Example:
Selection.InsertDateTime DateTimeFormat:="MMMM dd, yyyy", _
InsertAsField:=True
' Range Example:
MyRange.InsertDateTime DateTimeFormat:="MMM dd, yyyy", _
InsertAsField:=True
End Sub
Sub FutureDate()
Selection.TypeText Text:=Format(Date + 30, "mmmm d, yyyy")
End Sub