Option Explicit
Sub ZoteroAddEditBibliography()
'
' ZoteroAddEditBibliography Macro
'
'
End Sub
' ATK Dec 2023, I think the main function I'm using at the moment is
' Sub AKUpdateQuoteTextBoxes()
' updated to include a few new quotes and only print a substring to the dialog box at end of run
Sub URLlinker()
' Paul Beverley - Version 14.04.22
' Finds all URLs in the text and links them
charsInURLs = "[%./:a-zA-Z0-9_\-\?^38=+]"
Set Rng = ActiveDocument.Range
myFind = "<[wthps]{3,5}>" & charsInURLs & "{1,}"
With Rng.Find
.Text = myFind
.Replacement.Text = ""
.Wrap = wdFindStop
.Forward = True
.MatchWildcards = True
.Execute
End With
Do While Rng.Find.Found = True
Rng.Select
Selection.Collapse wdCollapseStart
stNow = Selection.Start
Selection.MoveLeft , 1
stBefore = Selection.Start
If stNow = stBefore + 1 Then
myAddress = Rng.Text
' rng.Text = Replace(rng.Text, "https://", "")
' rng.Text = Replace(rng.Text, "http://", "")
Rng.Select
Set myLink = ActiveDocument.Hyperlinks.Add(Anchor:=Rng, _
Address:=myAddress, TextToDisplay:=Rng.Text)
Rng.Start = myLink.Range.End
Rng.End = ActiveDocument.Content.End
Else
Rng.Start = Rng.End
End If
Rng.Find.Execute
DoEvents
Loop
Beep
End Sub
Sub Hyperlinker()
Dim Rng As Range
Set Rng = ActiveDocument.Range
With Rng.Find
Do While .Execute(FindText:="https:", Forward:=False) = True
Rng.MoveEndUntil (Chr(13)) ' or Chr(13) or ' '
ActiveDocument.Hyperlinks.Add _
Anchor:=Rng, _
Address:=Rng.Text, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
Do While .Execute(FindText:="http:", Forward:=False) = True
Rng.MoveEndUntil (Chr(13)) ' or Chr(13) or ' '
ActiveDocument.Hyperlinks.Add _
Anchor:=Rng, _
Address:=Rng.Text, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
End With
End Sub
Sub AKDiaryUpdateAllDailyQuotesByBookmark()
'
' AKDiaryUpdateAllDailyQuotes Macro
'
' moved actual quotes to get random quote....
Dim intNumBookmarksInDoc As Integer
Dim intNumQuotes As Integer
' THIS SHOULD FAIL AS I REMOVED STRQUOTES 7 dec 23 when did I write this? ATK
intNumBookmarksInDoc = 16 ' Why 16, what's 16?
Dim intNumBookmarks As Integer
intNumBookmarks = 16
Dim intBookMarkSuffix As Integer
Dim intQuoteChosen As Integer
Dim intLastRandom As Integer
intLastRandom = 999
Dim yesNoResponse
yesNoResponse = YesNoBoxAK("AKDiaryUpdateAllDailyQuotes: This macro will update all quotes on this document. " & " For some reason I think that there should be " & CStr(intNumBookmarksInDoc) & " bookmarks. It tries to updated the bookmarks based on the name. eg bkmarkDailyQuote1, bkmarkDailyQuote2 etc. Do you want to continue?")
If (yesNoResponse = vbNo) Then
Exit Sub ' bad coding to exit here, but hey.
End If
Dim strQuoteChosen, strLastQuoteChosen As String
strQuoteChosen = ""
strLastQuoteChosen = ""
' For each bookmark, set a random quote
For intBookMarkSuffix = 1 To intNumBookmarks
strQuoteChosen = GetRandomQuote()
' added do loop to try to make sure new random is not same as last. This will same quote being next to each other
Do While strQuoteChosen = strLastQuoteChosen
strQuoteChosen = GetRandomQuote()
Loop
strLastQuoteChosen = strQuoteChosen
' MsgBox "random number is " & intQuoteChosen
Call UpdateBookmark("bkmarkDailyQuote" & intBookMarkSuffix, strQuoteChosen)
Next intBookMarkSuffix
MsgBox "Updated " & intBookMarkSuffix - 1 & " daily quotes"
' check if the page count is not divisible by 4
Dim intPageCountTotal As Integer
intPageCountTotal = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
Dim intResult As Integer
intResult = intPageCountTotal Mod 4
If intResult <> 0 Then
MsgBox "Your page count (" & intPageCountTotal & ") is not divisible by four, check if adding quotes pushed a page over. "
End If
End Sub ' AKDiaryUpdateAllDailyQuotes
Function GetRandomQuote()
Dim strQuotes(0 To 23) As String
strQuotes(23) = "Men fall in love with their eyes and women fall in love with their ears"
strQuotes(22) = "Do you want to be a slave to your whims? Jordan Peterson. Compare this with an idea of freedom which means to do whatever we feel. Different to whatever we choose. Implying choice might not be always what we feel like. It struck me at the time Dec 7, 2023"
strQuotes(0) = "Not all those who wander are lost. JRR Tolkien"
strQuotes(1) = "The slower you go the further you get. (Counselling). Nigel Polak"
strQuotes(2) = "There is no try"
strQuotes(3) = "The unexamined life is not worth living. Aurelius"
strQuotes(4) = "'The secret of getting ahead is getting started' – Mark Twain"
strQuotes(5) = "Go confidently in the direction of your dreams. Live the life you have imagined – Henry David Thoreau"
strQuotes(6) = "Take action. An inch of movement will bring you closer to your goals than a mile of intention” – Steve Maraboli"
strQuotes(7) = "We generate fears while we sit. We overcome them by action” – Dr. Henry Link"
strQuotes(8) = "Imagine your life is perfect in every respect; what would it look like?” – Brian Tracy"
strQuotes(9) = "Decide upon your major definite purpose in life and then organize all your activities around it.” – Brain Tracy"
strQuotes(10) = "It is not the critic who counts; not the man who points out how the strong man stumbles, or where the doer of deeds could have done them better. The credit belongs to the man who is actually in the arena... Theodore Roosevelt"
strQuotes(11) = "'Stay away from those people who try to disparage your ambitions. Small minds will always do that, but great minds will give you a feeling that you can become great too.' — Mark Twain"
strQuotes(12) = "'It is only when we take chances, when our lives improve. The initial and the most difficult risk that we need to take is to become honest. —Walter Anderson"
strQuotes(13) = "Success is not final; failure is not fatal: It is the courage to continue that counts. — Winston S. Churchill"
strQuotes(14) = "'Develop success from failures. Discouragement and failure are two of the surest stepping stones to success.' —Dale Carnegie"
strQuotes(15) = "'Don’t let yesterday take up too much of today.' — Will Rogers"
strQuotes(16) = "Tomorrow is a new day with no mistakes in it yet - Anne Shirley"
strQuotes(17) = "'Concentrate all your thoughts upon the work in hand. The sun's rays do not burn until brought to a focus. ' — Alexander Graham Bell"
strQuotes(18) = "'Either you run the day or the day runs you.' — Jim Rohn"
strQuotes(19) = "'I’m a greater believer in luck, and I find the harder I work the more I have of it.' — Thomas Jefferson"
strQuotes(20) = "'When we strive to become better than we are, everything around us becomes better too.' — Paulo Coelho"
strQuotes(21) = "'Opportunity is missed by most people because it is dressed in overalls and looks like work.' — Thomas Edison"
' MOST RECENT QUOTES AT TOP NEAR DECLARATION!!!!!
GetRandomQuote = strQuotes(GetRandomNumber0ToMax(UBound(strQuotes)))
End Function
Function GetRandomNumber0ToMax(intMaxNumberToReturn)
Dim Low As Integer
Low = 0
Randomize
GetRandomNumber0ToMax = Int((intMaxNumberToReturn - Low + 1) * Rnd + Low)
End Function
Function GetRandomNumber(intMin, intMax)
Randomize
GetRandomNumber = Int((intMax - intMin + 1) * Rnd + intMin)
End Function
Sub UpdateBookmark(BmkNm As String, NewTxt As String)
Dim BmkRng As Range
With ActiveDocument
If .Bookmarks.Exists(BmkNm) Then
Set BmkRng = .Bookmarks(BmkNm).Range
BmkRng.Text = NewTxt
.Bookmarks.Add BmkNm, BmkRng
Else
MsgBox "UpdateBookmark: Bookmark named " & BmkNm & " not found."
End If
End With
Set BmkRng = Nothing
End Sub
Sub AKRandomWordSizeFontColourBoldItalic()
'
' AKRandomWordSizeFontColourBoldItalic Macro
'
'
Dim oDoc As Document
Dim oText As Range
Dim nList As Long, nSize As Long, iChar As Long
Dim FontList As Variant, FontSize As Variant
'only want this to work on selection and change font colour etc on new line
Dim wd As Word.Application
Set wd = GetObject(, "Word.Application")
Set oDoc = ActiveDocument
Set oText = oDoc.Range
FontList = Array("Arial", "Times New Roman", "DejaVu Sans", "Century Gothic")
' for selection. if no select exit
Dim intMaxParagraphs, intCounter As Integer
intMaxParagraphs = 100
Dim para As Paragraph
Dim intMinFontSize, intMaxFontSize As Integer
intMinFontSize = 14
intMaxFontSize = 46
intMinFontSize = GetIntegerOrDefault(intMinFontSize, "Please enter min font size.")
intMaxFontSize = GetIntegerOrDefault(intMaxFontSize, "Please enter max font size.")
' Check if we are in a table...
If Selection.Information(wdWithInTable) Then
'Selection.Collapse Direction:=wdCollapseStart
StatusBar = "FYI we are in a table - not coded yet for this - change to para then change back. Soz. "
End If
Dim mySelection As Selection
Set mySelection = wd.Selection
intCounter = 0
For Each para In mySelection.Paragraphs
intCounter = intCounter + 1
If (intCounter < 100) Then
' MsgBox (para.Range.Text + " Len " + Str(Len(para.Range.Text)))
'If Len(para.Range.Text) <> 1 Then
para.Range.Font.Name = GetRandomFontName()
para.Range.Font.Size = GetRandomFontSize(intMinFontSize, intMaxFontSize)
'End If ' don't change empty paragraphs.. maybe I could this might be ok...
ElseIf (intCounter = 100) Then
MsgBox ("Only first one hundred phrases converted")
End If ' only 100
Next para
End Sub 'AK Random words font size colur etc
Function GetRandomFontName()
GetRandomFontName = "Calibri"
End Function
Function GetIntegerOrDefault(intDefaultFontSize, strMessage)
Dim intFontSize As Integer
intFontSize = intDefaultFontSize
Dim sTitle As String
Dim sDefault As String
Dim strFontSize As String
sTitle = "Enter number"
sDefault = CStr(intDefaultFontSize)
strFontSize = InputBox(strMessage, sTitle, sDefault)
If IsNumeric(strFontSize) Then
intFontSize = CInt(strFontSize)
End If
GetIntegerOrDefault = intFontSize
End Function
Function GetRandomFontSize(intMinFontSize, intMaxFontSize)
GetRandomFontSize = GetRandomNumber(intMinFontSize, intMaxFontSize)
End Function
Sub AKSetAllTables100Percent()
'
' AKSetAllTables100Percent Macro
'
StatusBar = "Starting: Setting all tables to 100%"
Dim oTbl As Table
Dim intCounter As Integer
intCounter = 0
For Each oTbl In ActiveDocument.Tables
' oTbl.AutoFitBehavior wdAutoFitFixed
With ActiveDocument.PageSetup
oTbl.PreferredWidthType = wdPreferredWidthPercent
oTbl.PreferredWidth = 50
intCounter = intCounter + 1
StatusBar = "... Processing table number: " + CStr(intCounter)
End With
Next oTbl
StatusBar = "Finished: Setting all tables to 100% - did this many tables: " + CStr(intCounter)
End Sub
' ================================================
Sub AKInsertSameTextIntoProjectTextBoxes()
'================================================
'
' AKInsertIntoTextBoxNamedSomething Macro
' updates all shapes that dont have project ie length 10 or don't have quote at start "
'
Dim aTextBox As Shape
Dim oShp As Shape
Dim strContinue As String, strNewProjectText As String
Dim strBoxText As String
Dim intTextLength As Integer, intUpdatedCount As Integer
Dim intAscLeftMost As Integer, intAsc2ndLeftMost As Integer
Dim strLeftMostChar As String, str2ndLeftMostChar As String
' =========================================================
' Count how many I will upate
' ========================================================
Dim intCountToUpdate As Integer, intCountWillNotUpdate As Integer
intCountToUpdate = 0
intCountWillNotUpdate = 0
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Then
StatusBar = "Looping through text boxes to count. This one named: - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' looks like I only update if the first character is a quote character
' MessageBoxAK ("left most string is ASC '" + CStr(Asc(Left(strBoxText, 1))) + "'. Full text is " + strBoxText)
' asc 145-148 are all quotes ' or " or the accented/italic looking ones.
' 147 is double quote "
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, dont update taht one
intCountWillNotUpdate = intCountWillNotUpdate + 1
Else
' should be project information
intCountToUpdate = intCountToUpdate + 1
End If ' left is ", ie is for quotes
Else
StatusBar = "Will not update this text:" + oShp.TextFrame.TextRange.Text
intCountWillNotUpdate = intCountWillNotUpdate + 1
End If ' length is 10, ie PROJECTS
End If ' is msg box type
Next ' for each shape
Dim yesNoResponse
yesNoResponse = YesNoBoxAK("AKInsertSameTextIntoProjectTextBoxes: This macro will update all text boxes on this document that don't have PROJECT in the text and that DON'T start with a "" (double quote character). Will update " & CStr(intCountToUpdate) & " and ignore " & CStr(intCountWillNotUpdate) & ". Do you want to continue?")
If (yesNoResponse = vbNo) Then
Exit Sub ' bad coding to exit here, but hey.
End If
intUpdatedCount = 0
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Then
StatusBar = "Looping through text boxes - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' asc 145-148 are all quotes ' or " or the accented/italic looking ones.
' 147 is double quote "
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, dont update taht one
intCountWillNotUpdate = intCountWillNotUpdate + 1
Else
' should be project information
intCountToUpdate = intCountToUpdate + 1
If (strNewProjectText = "") Then
strNewProjectText = PromptGetString("Please enter new project text", oShp.TextFrame.TextRange.Text)
End If
If strNewProjectText <> "" Then
oShp.TextFrame.TextRange.Text = strNewProjectText
intUpdatedCount = intUpdatedCount + 1
End If ' text is blank
End If ' left is ", ie is for quotes
End If ' length is 8, ie PROJECTS
End If ' is msg box type
Next ' for each shape
MessageBoxAK ("Updated " + CStr(intUpdatedCount) + " project box texts")
End Sub ' SetAllProjectTextBoxes
'================================================
'================================================
Sub AKUpdateQuoteTextBoxes()
'================================================
'================================================
'
' AKInsertIntoTextBoxNamedSomething Macro
' update by shapes
'
' Dec 2023 - ATK added max quote length for substring to dialog at end of sub
' also added text to stop same quote appearing directly after itself.
Dim aTextBox As Shape
Dim oShp As Shape
Dim strContinue As String
Dim strBoxText As String, strRandomQuote As String, strAllQuotes As String
Dim strLastQuote As String
Dim intTextLength As Integer, intUpdatedCount As Integer
Dim intAscLeftMost As Integer, intAsc2ndLeftMost As Integer
Dim strLeftMostChar As String, str2ndLeftMostChar As String
intUpdatedCount = 0
Dim LENGTH_OF_QUOTE_FOR_DIALOG As Integer
LENGTH_OF_QUOTE_FOR_DIALOG = 53
strLastQuote = ""
' =========================================================
' Count how many I will upate
' ========================================================
Dim intCountToUpdate As Integer, intCountWillNotUpdate As Integer
Dim intCountShapesNOTTextBoxes As Integer
intCountShapesNOTTextBoxes = 0
intCountToUpdate = 0
intCountWillNotUpdate = 0
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Or oShp.Type = msoAutoShape Then
StatusBar = "Looping through text boxes to count. This one named: - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' looks like I only update if the first character is a quote character
' MessageBoxAK ("left most string is ASC '" + CStr(Asc(Left(strBoxText, 1))) + "'. Full text is " + strBoxText)
' asc 145-148 are all quotes ' or " or the accented/italic looking ones.
' 147 is double quote "
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, update it()
intCountToUpdate = intCountToUpdate + 1
Else
intCountWillNotUpdate = intCountWillNotUpdate + 1
End If ' left is ", ie is for quotes
Else
StatusBar = "Will not update this text:" + oShp.TextFrame.TextRange.Text
intCountWillNotUpdate = intCountWillNotUpdate + 1
End If ' length is 10, ie PROJECTS
Else
StatusBar = "This shape is not a text box"
intCountShapesNOTTextBoxes = intCountShapesNOTTextBoxes + 1
End If ' is msgbox type
Next ' for each shape
Dim yesNoResponse
yesNoResponse = YesNoBoxAK("AKUpdateQuoteTextBoxes: This macro will update all " & _
" text boxes on this document that don't have PROJECT in the text and that start " & _
" with a "" (double quote character). Will update " & CStr(intCountToUpdate) & _
" and ignore " & CStr(intCountWillNotUpdate) & "textboxes and " & CStr(intCountShapesNOTTextBoxes) & _
"that are shapes but NOT textboxes. Do you want to continue?")
If (yesNoResponse = vbNo) Then
Exit Sub ' bad coding to exit here, but hey.
End If
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Or oShp.Type = msoAutoShape Then
StatusBar = "Looping through text boxes - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' MessageBoxAK ("left most string is ASC '" + CStr(Asc(Left(strBoxText, 1))) + "'. Full text is " + strBoxText)
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, update it()
strRandomQuote = GetRandomQuote()
While strRandomQuote = strLastQuote
strRandomQuote = GetRandomQuote()
Wend
strLastQuote = strRandomQuote
If Len(strRandomQuote) < 76 Then
oShp.TextFrame.TextRange.Text = Chr(13) + """" + strRandomQuote + """"
Else
oShp.TextFrame.TextRange.Text = """" + strRandomQuote + """"
End If ' less than 76 add blank line
strAllQuotes = strAllQuotes + AbbreviateStringWithElipses(strRandomQuote, LENGTH_OF_QUOTE_FOR_DIALOG) + Chr(13)
' let's only show the start of the quote as not all quotes can fit on screen if we have say 7x4 quotes, 28.
intUpdatedCount = intUpdatedCount + 1
End If ' left is ", ie is for quotes
End If ' length is 10, ie PROJECTS
End If ' is msg box type
Next ' for each shape
MessageBoxAK ("Updated " + CStr(intUpdatedCount) + " quote box texts. " + strAllQuotes)
End Sub ' SetAllProjectTextBoxes
Function AbbreviateStringWithElipses(strToAbbreviate As String, intMaxLength As Integer)
If Len(strToAbbreviate) > (intMaxLength + 3) Then
strToAbbreviate = Left(strToAbbreviate, intMaxLength) + "..."
' if it is not bigger then intMaxLenght then do not abbreviate at all, and do not add add ...
End If ' Len
AbbreviateStringWithElipses = strToAbbreviate
End Function
Sub MessageBoxAK(strMessage As String)
' display a message in a box
Dim intYesNo As Integer
intYesNo = MsgBox(strMessage, vbInformation + vbOK + vbDefaultButton2, "MessageBoxAK")
End Sub
Function PromptGetString(strQuestion As String, strDefault As String)
Dim Title
Title = "Input" ' Set title.
' Display message, title, and default value.
PromptGetString = InputBox(strQuestion, Title, strDefault)
End Function
Function YesNoBoxAK(strMessage As String)
Dim Style, Title, Help, Ctxt, Response, MyString
Style = vbYesNo Or vbCritical Or vbDefaultButton2 ' Define buttons.
Title = "Message" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(strMessage, Style, Title, Help, Ctxt)
YesNoBoxAK = Response
' to check return
' if if yesNoReturn = vbNo
Rem vbOK 1 OK
'vbCancel 2 Cancel
'vbAbort 3 Abort
'vbRetry 4 Retry
'vbIgnore 5 Ignore
'vbYes 6 Yes
'vbNo
End Function ' PromptBoxAK
Sub SetCurrentTable100PerCent()
'
' SetCurrentTable100PerCent Macro
'
'
Selection.Tables(1).Select
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
'Selection.Tables(1).Rows.HeightRule = wdRowHeightExactly
'Selection.Tables(1).Rows.Height = CentimetersToPoints(0.5)
' Selection.Tables(1).Columns(1).PreferredWidthType = _
' wdPreferredWidthPercent
'Selection.Tables(1).Columns(1).PreferredWidth = 2
' Selection.Tables(1).Columns(2).PreferredWidth = 2
End Sub
Sub SetCurrentTableRowHeight7PerCent()
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
'Selection.Tables(1).Rows.HeightRule = wdRowHeightExactly
'Selection.Tables(1).Rows.Height = CentimetersToPoints(0.5)
End Sub
Sub CalendarMaker()
Dim ActiveSheet
Dim Range
Dim MyInput
' Unprotect sheet if had previous calendar to prevent error.
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
Scenarios:=False
' Prevent screen flashing while drawing calendar.
Application.ScreenUpdating = False
' Set up error trapping.
On Error GoTo MyErrorTrap
' Clear area a1:g14 including any previous calendar.
Range("a1:g14").Clear
' Use InputBox to get desired month and year and set variable
' MyInput.
MyInput = InputBox("Type in Month and year for Calendar ")
' Allow user to end macro with Cancel in InputBox.
If MyInput = "" Then Exit Sub
' Get the date value of the beginning of inputted month.
StartDay = DateValue(MyInput)
' Check if valid date but not the first of the month
' -- if so, reset StartDay to first day of month.
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & _
Year(StartDay))
End If
' Prepare cell for Month and Year as fully spelled out.
Range("a1").NumberFormat = "mmmm yyyy"
' Center the Month and Year label across a1:g1 with appropriate
' size, height and bolding.
With Range("a1:g1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.Font.Size = 18
.Font.Bold = True
.RowHeight = 35
End With
' Prepare a2:g2 for day of week labels with centering, size,
' height and bolding.
With Range("a2:g2")
.ColumnWidth = 11
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.Font.Size = 12
.Font.Bold = True
.RowHeight = 20
End With
' Put days of week in a2:g2.
Range("a2") = "Sunday"
Range("b2") = "Monday"
Range("c2") = "Tuesday"
Range("d2") = "Wednesday"
Range("e2") = "Thursday"
Range("f2") = "Friday"
Range("g2") = "Saturday"
' Prepare a3:g7 for dates with left/top alignment, size, height
' and bolding.
With Range("a3:g8")
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.Font.Size = 18
.Font.Bold = True
.RowHeight = 21
End With
' Put inputted month and year fully spelling out into "a1".
Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
' Set variable and get which day of the week the month starts.
Dim DayofWeek
DayofWeek = Weekday(StartDay)
' Set variables to identify the year and month as separate
' variables.
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
' Set variable and calculate the first day of the next month.
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
' Place a "1" in cell position of the first day of the chosen
' month based on DayofWeek.
Select Case DayofWeek
Case 1
Range("a3").Value = 1
Case 2
Range("b3").Value = 1
Case 3
Range("c3").Value = 1
Case 4
Range("d3").Value = 1
Case 5
Range("e3").Value = 1
Case 6
Range("f3").Value = 1
Case 7
Range("g3").Value = 1
End Select
' Loop through range a3:g8 incrementing each cell after the "1"
' cell.
For Each Cell In Range("a3:g8")
RowCell = Cell.Row
ColCell = Cell.Column
' Do if "1" is in first column.
If Cell.Column = 1 And Cell.Row = 3 Then
' Do if current cell is not in 1st column.
ElseIf Cell.Column <> 1 Then
If Cell.Offset(0, -1).Value >= 1 Then
Cell.Value = Cell.Offset(0, -1).Value + 1
' Stop when the last day of the month has been
' entered.
If Cell.Value > (FinalDay - StartDay) Then
Cell.Value = ""
' Exit loop when calendar has correct number of
' days shown.
Exit For
End If
End If
' Do only if current cell is not in Row 3 and is in Column 1.
ElseIf Cell.Row > 3 And Cell.Column = 1 Then
Cell.Value = Cell.Offset(-1, 6).Value + 1
' Stop when the last day of the month has been entered.
If Cell.Value > (FinalDay - StartDay) Then
Cell.Value = ""
' Exit loop when calendar has correct number of days
' shown.
Exit For
End If
End If
Next
' Create Entry cells, format them centered, wrap text, and border
' around days.
For x = 0 To 5
Range("A4").Offset(x * 2, 0).EntireRow.Insert
With Range("A4:G4").Offset(x * 2, 0)
.RowHeight = 65
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Font.Size = 10
.Font.Bold = False
' Unlock these cells to be able to enter text later after
' sheet is protected.
.Locked = False
End With
' Put border around the block of dates.
With Range("A3").Offset(x * 2, 0).Resize(2, _
7).Borders(xlLeft)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Range("A3").Offset(x * 2, 0).Resize(2, _
7).Borders(xlRight)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _
Weight:=xlThick, ColorIndex:=xlAutomatic
Next
If Range("A13").Value = "" Then Range("A13").Offset(0, 0) _
.Resize(2, 8).EntireRow.Delete
' Turn off gridlines.
ActiveWindow.DisplayGridLines = False
' Protect sheet to prevent overwriting the dates.
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True
' Resize window to show all of calendar (may have to be adjusted
' for video configuration).
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1
' Allow screen to redraw with calendar showing.
Application.ScreenUpdating = True
' Prevent going to error trap unless error found by exiting Sub
' here.
Exit Sub
' Error causes msgbox to indicate the problem, provides new input box,
' and resumes at the line that caused the error.
MyErrorTrap:
MsgBox "You may not have entered your Month and Year correctly." _
& Chr(13) & "Spell the Month correctly" _
& " (or use 3 letter abbreviation)" _
& Chr(13) & "and 4 digits for the Year"
MyInput = InputBox("Type in Month and year for Calendar")
If MyInput = "" Then Exit Sub
Resume
End Sub
Sub AKReplaceCarriageReturnOnlyNearEndOfLine()
'
' AKReplaceCarriageReturnOnlyNearEndOfLine Macro
'
Call FindCharacterPosition
End Sub
'
Sub FindCharacterPosition()
Dim MyRange As Range
Set MyRange = ActiveDocument.Range
MyRange.Find.Execute FindText:=Chr(13)
MsgBox "Position = " & MyRange.Information(wdHorizontalPositionRelativeToPage)
MyRange.Find.Execute FindText:=Chr(13)
MsgBox "Position = " & MyRange.Information(wdHorizontalPositionRelativeToPage)
MyRange.Find.Execute FindText:=Chr(13)
MsgBox "Position = " & MyRange.Information(wdHorizontalPositionRelativeToPage)
End Sub
Sub ZoteroAddEditBibliography()
'
' ZoteroAddEditBibliography Macro
'
'
End Sub
' ATK Dec 2023, I think the main function I'm using at the moment is
' Sub AKUpdateQuoteTextBoxes()
' updated to include a few new quotes and only print a substring to the dialog box at end of run
Sub URLlinker()
' Paul Beverley - Version 14.04.22
' Finds all URLs in the text and links them
charsInURLs = "[%./:a-zA-Z0-9_\-\?^38=+]"
Set Rng = ActiveDocument.Range
myFind = "<[wthps]{3,5}>" & charsInURLs & "{1,}"
With Rng.Find
.Text = myFind
.Replacement.Text = ""
.Wrap = wdFindStop
.Forward = True
.MatchWildcards = True
.Execute
End With
Do While Rng.Find.Found = True
Rng.Select
Selection.Collapse wdCollapseStart
stNow = Selection.Start
Selection.MoveLeft , 1
stBefore = Selection.Start
If stNow = stBefore + 1 Then
myAddress = Rng.Text
' rng.Text = Replace(rng.Text, "https://", "")
' rng.Text = Replace(rng.Text, "http://", "")
Rng.Select
Set myLink = ActiveDocument.Hyperlinks.Add(Anchor:=Rng, _
Address:=myAddress, TextToDisplay:=Rng.Text)
Rng.Start = myLink.Range.End
Rng.End = ActiveDocument.Content.End
Else
Rng.Start = Rng.End
End If
Rng.Find.Execute
DoEvents
Loop
Beep
End Sub
Sub Hyperlinker()
Dim Rng As Range
Set Rng = ActiveDocument.Range
With Rng.Find
Do While .Execute(FindText:="https:", Forward:=False) = True
Rng.MoveEndUntil (Chr(13)) ' or Chr(13) or ' '
ActiveDocument.Hyperlinks.Add _
Anchor:=Rng, _
Address:=Rng.Text, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
Do While .Execute(FindText:="http:", Forward:=False) = True
Rng.MoveEndUntil (Chr(13)) ' or Chr(13) or ' '
ActiveDocument.Hyperlinks.Add _
Anchor:=Rng, _
Address:=Rng.Text, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
End With
End Sub
Sub AKDiaryUpdateAllDailyQuotesByBookmark()
'
' AKDiaryUpdateAllDailyQuotes Macro
'
' moved actual quotes to get random quote....
Dim intNumBookmarksInDoc As Integer
Dim intNumQuotes As Integer
' THIS SHOULD FAIL AS I REMOVED STRQUOTES 7 dec 23 when did I write this? ATK
intNumBookmarksInDoc = 16 ' Why 16, what's 16?
Dim intNumBookmarks As Integer
intNumBookmarks = 16
Dim intBookMarkSuffix As Integer
Dim intQuoteChosen As Integer
Dim intLastRandom As Integer
intLastRandom = 999
Dim yesNoResponse
yesNoResponse = YesNoBoxAK("AKDiaryUpdateAllDailyQuotes: This macro will update all quotes on this document. " & " For some reason I think that there should be " & CStr(intNumBookmarksInDoc) & " bookmarks. It tries to updated the bookmarks based on the name. eg bkmarkDailyQuote1, bkmarkDailyQuote2 etc. Do you want to continue?")
If (yesNoResponse = vbNo) Then
Exit Sub ' bad coding to exit here, but hey.
End If
Dim strQuoteChosen, strLastQuoteChosen As String
strQuoteChosen = ""
strLastQuoteChosen = ""
' For each bookmark, set a random quote
For intBookMarkSuffix = 1 To intNumBookmarks
strQuoteChosen = GetRandomQuote()
' added do loop to try to make sure new random is not same as last. This will same quote being next to each other
Do While strQuoteChosen = strLastQuoteChosen
strQuoteChosen = GetRandomQuote()
Loop
strLastQuoteChosen = strQuoteChosen
' MsgBox "random number is " & intQuoteChosen
Call UpdateBookmark("bkmarkDailyQuote" & intBookMarkSuffix, strQuoteChosen)
Next intBookMarkSuffix
MsgBox "Updated " & intBookMarkSuffix - 1 & " daily quotes"
' check if the page count is not divisible by 4
Dim intPageCountTotal As Integer
intPageCountTotal = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
Dim intResult As Integer
intResult = intPageCountTotal Mod 4
If intResult <> 0 Then
MsgBox "Your page count (" & intPageCountTotal & ") is not divisible by four, check if adding quotes pushed a page over. "
End If
End Sub ' AKDiaryUpdateAllDailyQuotes
Function GetRandomQuote()
Dim strQuotes(0 To 23) As String
strQuotes(23) = "Men fall in love with their eyes and women fall in love with their ears"
strQuotes(22) = "Do you want to be a slave to your whims? Jordan Peterson. Compare this with an idea of freedom which means to do whatever we feel. Different to whatever we choose. Implying choice might not be always what we feel like. It struck me at the time Dec 7, 2023"
strQuotes(0) = "Not all those who wander are lost. JRR Tolkien"
strQuotes(1) = "The slower you go the further you get. (Counselling). Nigel Polak"
strQuotes(2) = "There is no try"
strQuotes(3) = "The unexamined life is not worth living. Aurelius"
strQuotes(4) = "'The secret of getting ahead is getting started' – Mark Twain"
strQuotes(5) = "Go confidently in the direction of your dreams. Live the life you have imagined – Henry David Thoreau"
strQuotes(6) = "Take action. An inch of movement will bring you closer to your goals than a mile of intention” – Steve Maraboli"
strQuotes(7) = "We generate fears while we sit. We overcome them by action” – Dr. Henry Link"
strQuotes(8) = "Imagine your life is perfect in every respect; what would it look like?” – Brian Tracy"
strQuotes(9) = "Decide upon your major definite purpose in life and then organize all your activities around it.” – Brain Tracy"
strQuotes(10) = "It is not the critic who counts; not the man who points out how the strong man stumbles, or where the doer of deeds could have done them better. The credit belongs to the man who is actually in the arena... Theodore Roosevelt"
strQuotes(11) = "'Stay away from those people who try to disparage your ambitions. Small minds will always do that, but great minds will give you a feeling that you can become great too.' — Mark Twain"
strQuotes(12) = "'It is only when we take chances, when our lives improve. The initial and the most difficult risk that we need to take is to become honest. —Walter Anderson"
strQuotes(13) = "Success is not final; failure is not fatal: It is the courage to continue that counts. — Winston S. Churchill"
strQuotes(14) = "'Develop success from failures. Discouragement and failure are two of the surest stepping stones to success.' —Dale Carnegie"
strQuotes(15) = "'Don’t let yesterday take up too much of today.' — Will Rogers"
strQuotes(16) = "Tomorrow is a new day with no mistakes in it yet - Anne Shirley"
strQuotes(17) = "'Concentrate all your thoughts upon the work in hand. The sun's rays do not burn until brought to a focus. ' — Alexander Graham Bell"
strQuotes(18) = "'Either you run the day or the day runs you.' — Jim Rohn"
strQuotes(19) = "'I’m a greater believer in luck, and I find the harder I work the more I have of it.' — Thomas Jefferson"
strQuotes(20) = "'When we strive to become better than we are, everything around us becomes better too.' — Paulo Coelho"
strQuotes(21) = "'Opportunity is missed by most people because it is dressed in overalls and looks like work.' — Thomas Edison"
' MOST RECENT QUOTES AT TOP NEAR DECLARATION!!!!!
GetRandomQuote = strQuotes(GetRandomNumber0ToMax(UBound(strQuotes)))
End Function
Function GetRandomNumber0ToMax(intMaxNumberToReturn)
Dim Low As Integer
Low = 0
Randomize
GetRandomNumber0ToMax = Int((intMaxNumberToReturn - Low + 1) * Rnd + Low)
End Function
Function GetRandomNumber(intMin, intMax)
Randomize
GetRandomNumber = Int((intMax - intMin + 1) * Rnd + intMin)
End Function
Sub UpdateBookmark(BmkNm As String, NewTxt As String)
Dim BmkRng As Range
With ActiveDocument
If .Bookmarks.Exists(BmkNm) Then
Set BmkRng = .Bookmarks(BmkNm).Range
BmkRng.Text = NewTxt
.Bookmarks.Add BmkNm, BmkRng
Else
MsgBox "UpdateBookmark: Bookmark named " & BmkNm & " not found."
End If
End With
Set BmkRng = Nothing
End Sub
Sub AKRandomWordSizeFontColourBoldItalic()
'
' AKRandomWordSizeFontColourBoldItalic Macro
'
'
Dim oDoc As Document
Dim oText As Range
Dim nList As Long, nSize As Long, iChar As Long
Dim FontList As Variant, FontSize As Variant
'only want this to work on selection and change font colour etc on new line
Dim wd As Word.Application
Set wd = GetObject(, "Word.Application")
Set oDoc = ActiveDocument
Set oText = oDoc.Range
FontList = Array("Arial", "Times New Roman", "DejaVu Sans", "Century Gothic")
' for selection. if no select exit
Dim intMaxParagraphs, intCounter As Integer
intMaxParagraphs = 100
Dim para As Paragraph
Dim intMinFontSize, intMaxFontSize As Integer
intMinFontSize = 14
intMaxFontSize = 46
intMinFontSize = GetIntegerOrDefault(intMinFontSize, "Please enter min font size.")
intMaxFontSize = GetIntegerOrDefault(intMaxFontSize, "Please enter max font size.")
' Check if we are in a table...
If Selection.Information(wdWithInTable) Then
'Selection.Collapse Direction:=wdCollapseStart
StatusBar = "FYI we are in a table - not coded yet for this - change to para then change back. Soz. "
End If
Dim mySelection As Selection
Set mySelection = wd.Selection
intCounter = 0
For Each para In mySelection.Paragraphs
intCounter = intCounter + 1
If (intCounter < 100) Then
' MsgBox (para.Range.Text + " Len " + Str(Len(para.Range.Text)))
'If Len(para.Range.Text) <> 1 Then
para.Range.Font.Name = GetRandomFontName()
para.Range.Font.Size = GetRandomFontSize(intMinFontSize, intMaxFontSize)
'End If ' don't change empty paragraphs.. maybe I could this might be ok...
ElseIf (intCounter = 100) Then
MsgBox ("Only first one hundred phrases converted")
End If ' only 100
Next para
End Sub 'AK Random words font size colur etc
Function GetRandomFontName()
GetRandomFontName = "Calibri"
End Function
Function GetIntegerOrDefault(intDefaultFontSize, strMessage)
Dim intFontSize As Integer
intFontSize = intDefaultFontSize
Dim sTitle As String
Dim sDefault As String
Dim strFontSize As String
sTitle = "Enter number"
sDefault = CStr(intDefaultFontSize)
strFontSize = InputBox(strMessage, sTitle, sDefault)
If IsNumeric(strFontSize) Then
intFontSize = CInt(strFontSize)
End If
GetIntegerOrDefault = intFontSize
End Function
Function GetRandomFontSize(intMinFontSize, intMaxFontSize)
GetRandomFontSize = GetRandomNumber(intMinFontSize, intMaxFontSize)
End Function
Sub AKSetAllTables100Percent()
'
' AKSetAllTables100Percent Macro
'
StatusBar = "Starting: Setting all tables to 100%"
Dim oTbl As Table
Dim intCounter As Integer
intCounter = 0
For Each oTbl In ActiveDocument.Tables
' oTbl.AutoFitBehavior wdAutoFitFixed
With ActiveDocument.PageSetup
oTbl.PreferredWidthType = wdPreferredWidthPercent
oTbl.PreferredWidth = 50
intCounter = intCounter + 1
StatusBar = "... Processing table number: " + CStr(intCounter)
End With
Next oTbl
StatusBar = "Finished: Setting all tables to 100% - did this many tables: " + CStr(intCounter)
End Sub
' ================================================
Sub AKInsertSameTextIntoProjectTextBoxes()
'================================================
'
' AKInsertIntoTextBoxNamedSomething Macro
' updates all shapes that dont have project ie length 10 or don't have quote at start "
'
Dim aTextBox As Shape
Dim oShp As Shape
Dim strContinue As String, strNewProjectText As String
Dim strBoxText As String
Dim intTextLength As Integer, intUpdatedCount As Integer
Dim intAscLeftMost As Integer, intAsc2ndLeftMost As Integer
Dim strLeftMostChar As String, str2ndLeftMostChar As String
' =========================================================
' Count how many I will upate
' ========================================================
Dim intCountToUpdate As Integer, intCountWillNotUpdate As Integer
intCountToUpdate = 0
intCountWillNotUpdate = 0
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Then
StatusBar = "Looping through text boxes to count. This one named: - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' looks like I only update if the first character is a quote character
' MessageBoxAK ("left most string is ASC '" + CStr(Asc(Left(strBoxText, 1))) + "'. Full text is " + strBoxText)
' asc 145-148 are all quotes ' or " or the accented/italic looking ones.
' 147 is double quote "
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, dont update taht one
intCountWillNotUpdate = intCountWillNotUpdate + 1
Else
' should be project information
intCountToUpdate = intCountToUpdate + 1
End If ' left is ", ie is for quotes
Else
StatusBar = "Will not update this text:" + oShp.TextFrame.TextRange.Text
intCountWillNotUpdate = intCountWillNotUpdate + 1
End If ' length is 10, ie PROJECTS
End If ' is msg box type
Next ' for each shape
Dim yesNoResponse
yesNoResponse = YesNoBoxAK("AKInsertSameTextIntoProjectTextBoxes: This macro will update all text boxes on this document that don't have PROJECT in the text and that DON'T start with a "" (double quote character). Will update " & CStr(intCountToUpdate) & " and ignore " & CStr(intCountWillNotUpdate) & ". Do you want to continue?")
If (yesNoResponse = vbNo) Then
Exit Sub ' bad coding to exit here, but hey.
End If
intUpdatedCount = 0
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Then
StatusBar = "Looping through text boxes - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' asc 145-148 are all quotes ' or " or the accented/italic looking ones.
' 147 is double quote "
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, dont update taht one
intCountWillNotUpdate = intCountWillNotUpdate + 1
Else
' should be project information
intCountToUpdate = intCountToUpdate + 1
If (strNewProjectText = "") Then
strNewProjectText = PromptGetString("Please enter new project text", oShp.TextFrame.TextRange.Text)
End If
If strNewProjectText <> "" Then
oShp.TextFrame.TextRange.Text = strNewProjectText
intUpdatedCount = intUpdatedCount + 1
End If ' text is blank
End If ' left is ", ie is for quotes
End If ' length is 8, ie PROJECTS
End If ' is msg box type
Next ' for each shape
MessageBoxAK ("Updated " + CStr(intUpdatedCount) + " project box texts")
End Sub ' SetAllProjectTextBoxes
'================================================
'================================================
Sub AKUpdateQuoteTextBoxes()
'================================================
'================================================
'
' AKInsertIntoTextBoxNamedSomething Macro
' update by shapes
'
' Dec 2023 - ATK added max quote length for substring to dialog at end of sub
' also added text to stop same quote appearing directly after itself.
Dim aTextBox As Shape
Dim oShp As Shape
Dim strContinue As String
Dim strBoxText As String, strRandomQuote As String, strAllQuotes As String
Dim strLastQuote As String
Dim intTextLength As Integer, intUpdatedCount As Integer
Dim intAscLeftMost As Integer, intAsc2ndLeftMost As Integer
Dim strLeftMostChar As String, str2ndLeftMostChar As String
intUpdatedCount = 0
Dim LENGTH_OF_QUOTE_FOR_DIALOG As Integer
LENGTH_OF_QUOTE_FOR_DIALOG = 53
strLastQuote = ""
' =========================================================
' Count how many I will upate
' ========================================================
Dim intCountToUpdate As Integer, intCountWillNotUpdate As Integer
Dim intCountShapesNOTTextBoxes As Integer
intCountShapesNOTTextBoxes = 0
intCountToUpdate = 0
intCountWillNotUpdate = 0
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Or oShp.Type = msoAutoShape Then
StatusBar = "Looping through text boxes to count. This one named: - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' looks like I only update if the first character is a quote character
' MessageBoxAK ("left most string is ASC '" + CStr(Asc(Left(strBoxText, 1))) + "'. Full text is " + strBoxText)
' asc 145-148 are all quotes ' or " or the accented/italic looking ones.
' 147 is double quote "
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, update it()
intCountToUpdate = intCountToUpdate + 1
Else
intCountWillNotUpdate = intCountWillNotUpdate + 1
End If ' left is ", ie is for quotes
Else
StatusBar = "Will not update this text:" + oShp.TextFrame.TextRange.Text
intCountWillNotUpdate = intCountWillNotUpdate + 1
End If ' length is 10, ie PROJECTS
Else
StatusBar = "This shape is not a text box"
intCountShapesNOTTextBoxes = intCountShapesNOTTextBoxes + 1
End If ' is msgbox type
Next ' for each shape
Dim yesNoResponse
yesNoResponse = YesNoBoxAK("AKUpdateQuoteTextBoxes: This macro will update all " & _
" text boxes on this document that don't have PROJECT in the text and that start " & _
" with a "" (double quote character). Will update " & CStr(intCountToUpdate) & _
" and ignore " & CStr(intCountWillNotUpdate) & "textboxes and " & CStr(intCountShapesNOTTextBoxes) & _
"that are shapes but NOT textboxes. Do you want to continue?")
If (yesNoResponse = vbNo) Then
Exit Sub ' bad coding to exit here, but hey.
End If
For Each oShp In ActiveDocument.Shapes
If oShp.Type = msoTextBox Or oShp.Type = msoAutoShape Then
StatusBar = "Looping through text boxes - " + oShp.Name
' StatusBar = oShp.TextFrame.TextRange.Text
' ignore text with just PROJECTS in it. Chec k length. should be about 8 chars
strBoxText = oShp.TextFrame.TextRange.Text
intTextLength = Len(strBoxText)
If (intTextLength <> 10) Then ' only continue if we are not lenght 8, ie PROJECTS - apparently it's 10
' MessageBoxAK ("left most string is ASC '" + CStr(Asc(Left(strBoxText, 1))) + "'. Full text is " + strBoxText)
strLeftMostChar = Left(strBoxText, 1)
str2ndLeftMostChar = Right(Left(strBoxText, 2), 1)
intAscLeftMost = Asc(strLeftMostChar)
intAsc2ndLeftMost = Asc(str2ndLeftMostChar)
If strLeftMostChar = """" Or Asc(strLeftMostChar) = 147 Or _
(strLeftMostChar = Chr(13) And (str2ndLeftMostChar = """" Or Asc(strLeftMostChar) = 147)) Then
' should be a quote, update it()
strRandomQuote = GetRandomQuote()
While strRandomQuote = strLastQuote
strRandomQuote = GetRandomQuote()
Wend
strLastQuote = strRandomQuote
If Len(strRandomQuote) < 76 Then
oShp.TextFrame.TextRange.Text = Chr(13) + """" + strRandomQuote + """"
Else
oShp.TextFrame.TextRange.Text = """" + strRandomQuote + """"
End If ' less than 76 add blank line
strAllQuotes = strAllQuotes + AbbreviateStringWithElipses(strRandomQuote, LENGTH_OF_QUOTE_FOR_DIALOG) + Chr(13)
' let's only show the start of the quote as not all quotes can fit on screen if we have say 7x4 quotes, 28.
intUpdatedCount = intUpdatedCount + 1
End If ' left is ", ie is for quotes
End If ' length is 10, ie PROJECTS
End If ' is msg box type
Next ' for each shape
MessageBoxAK ("Updated " + CStr(intUpdatedCount) + " quote box texts. " + strAllQuotes)
End Sub ' SetAllProjectTextBoxes
Function AbbreviateStringWithElipses(strToAbbreviate As String, intMaxLength As Integer)
If Len(strToAbbreviate) > (intMaxLength + 3) Then
strToAbbreviate = Left(strToAbbreviate, intMaxLength) + "..."
' if it is not bigger then intMaxLenght then do not abbreviate at all, and do not add add ...
End If ' Len
AbbreviateStringWithElipses = strToAbbreviate
End Function
Sub MessageBoxAK(strMessage As String)
' display a message in a box
Dim intYesNo As Integer
intYesNo = MsgBox(strMessage, vbInformation + vbOK + vbDefaultButton2, "MessageBoxAK")
End Sub
Function PromptGetString(strQuestion As String, strDefault As String)
Dim Title
Title = "Input" ' Set title.
' Display message, title, and default value.
PromptGetString = InputBox(strQuestion, Title, strDefault)
End Function
Function YesNoBoxAK(strMessage As String)
Dim Style, Title, Help, Ctxt, Response, MyString
Style = vbYesNo Or vbCritical Or vbDefaultButton2 ' Define buttons.
Title = "Message" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(strMessage, Style, Title, Help, Ctxt)
YesNoBoxAK = Response
' to check return
' if if yesNoReturn = vbNo
Rem vbOK 1 OK
'vbCancel 2 Cancel
'vbAbort 3 Abort
'vbRetry 4 Retry
'vbIgnore 5 Ignore
'vbYes 6 Yes
'vbNo
End Function ' PromptBoxAK
Sub SetCurrentTable100PerCent()
'
' SetCurrentTable100PerCent Macro
'
'
Selection.Tables(1).Select
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
'Selection.Tables(1).Rows.HeightRule = wdRowHeightExactly
'Selection.Tables(1).Rows.Height = CentimetersToPoints(0.5)
' Selection.Tables(1).Columns(1).PreferredWidthType = _
' wdPreferredWidthPercent
'Selection.Tables(1).Columns(1).PreferredWidth = 2
' Selection.Tables(1).Columns(2).PreferredWidth = 2
End Sub
Sub SetCurrentTableRowHeight7PerCent()
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Selection.Tables(1).PreferredWidthType = wdPreferredWidthPercent
Selection.Tables(1).PreferredWidth = 100
'Selection.Tables(1).Rows.HeightRule = wdRowHeightExactly
'Selection.Tables(1).Rows.Height = CentimetersToPoints(0.5)
End Sub
Sub CalendarMaker()
Dim ActiveSheet
Dim Range
Dim MyInput
' Unprotect sheet if had previous calendar to prevent error.
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
Scenarios:=False
' Prevent screen flashing while drawing calendar.
Application.ScreenUpdating = False
' Set up error trapping.
On Error GoTo MyErrorTrap
' Clear area a1:g14 including any previous calendar.
Range("a1:g14").Clear
' Use InputBox to get desired month and year and set variable
' MyInput.
MyInput = InputBox("Type in Month and year for Calendar ")
' Allow user to end macro with Cancel in InputBox.
If MyInput = "" Then Exit Sub
' Get the date value of the beginning of inputted month.
StartDay = DateValue(MyInput)
' Check if valid date but not the first of the month
' -- if so, reset StartDay to first day of month.
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & _
Year(StartDay))
End If
' Prepare cell for Month and Year as fully spelled out.
Range("a1").NumberFormat = "mmmm yyyy"
' Center the Month and Year label across a1:g1 with appropriate
' size, height and bolding.
With Range("a1:g1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.Font.Size = 18
.Font.Bold = True
.RowHeight = 35
End With
' Prepare a2:g2 for day of week labels with centering, size,
' height and bolding.
With Range("a2:g2")
.ColumnWidth = 11
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.Font.Size = 12
.Font.Bold = True
.RowHeight = 20
End With
' Put days of week in a2:g2.
Range("a2") = "Sunday"
Range("b2") = "Monday"
Range("c2") = "Tuesday"
Range("d2") = "Wednesday"
Range("e2") = "Thursday"
Range("f2") = "Friday"
Range("g2") = "Saturday"
' Prepare a3:g7 for dates with left/top alignment, size, height
' and bolding.
With Range("a3:g8")
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.Font.Size = 18
.Font.Bold = True
.RowHeight = 21
End With
' Put inputted month and year fully spelling out into "a1".
Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
' Set variable and get which day of the week the month starts.
Dim DayofWeek
DayofWeek = Weekday(StartDay)
' Set variables to identify the year and month as separate
' variables.
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
' Set variable and calculate the first day of the next month.
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
' Place a "1" in cell position of the first day of the chosen
' month based on DayofWeek.
Select Case DayofWeek
Case 1
Range("a3").Value = 1
Case 2
Range("b3").Value = 1
Case 3
Range("c3").Value = 1
Case 4
Range("d3").Value = 1
Case 5
Range("e3").Value = 1
Case 6
Range("f3").Value = 1
Case 7
Range("g3").Value = 1
End Select
' Loop through range a3:g8 incrementing each cell after the "1"
' cell.
For Each Cell In Range("a3:g8")
RowCell = Cell.Row
ColCell = Cell.Column
' Do if "1" is in first column.
If Cell.Column = 1 And Cell.Row = 3 Then
' Do if current cell is not in 1st column.
ElseIf Cell.Column <> 1 Then
If Cell.Offset(0, -1).Value >= 1 Then
Cell.Value = Cell.Offset(0, -1).Value + 1
' Stop when the last day of the month has been
' entered.
If Cell.Value > (FinalDay - StartDay) Then
Cell.Value = ""
' Exit loop when calendar has correct number of
' days shown.
Exit For
End If
End If
' Do only if current cell is not in Row 3 and is in Column 1.
ElseIf Cell.Row > 3 And Cell.Column = 1 Then
Cell.Value = Cell.Offset(-1, 6).Value + 1
' Stop when the last day of the month has been entered.
If Cell.Value > (FinalDay - StartDay) Then
Cell.Value = ""
' Exit loop when calendar has correct number of days
' shown.
Exit For
End If
End If
Next
' Create Entry cells, format them centered, wrap text, and border
' around days.
For x = 0 To 5
Range("A4").Offset(x * 2, 0).EntireRow.Insert
With Range("A4:G4").Offset(x * 2, 0)
.RowHeight = 65
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Font.Size = 10
.Font.Bold = False
' Unlock these cells to be able to enter text later after
' sheet is protected.
.Locked = False
End With
' Put border around the block of dates.
With Range("A3").Offset(x * 2, 0).Resize(2, _
7).Borders(xlLeft)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Range("A3").Offset(x * 2, 0).Resize(2, _
7).Borders(xlRight)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _
Weight:=xlThick, ColorIndex:=xlAutomatic
Next
If Range("A13").Value = "" Then Range("A13").Offset(0, 0) _
.Resize(2, 8).EntireRow.Delete
' Turn off gridlines.
ActiveWindow.DisplayGridLines = False
' Protect sheet to prevent overwriting the dates.
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True
' Resize window to show all of calendar (may have to be adjusted
' for video configuration).
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1
' Allow screen to redraw with calendar showing.
Application.ScreenUpdating = True
' Prevent going to error trap unless error found by exiting Sub
' here.
Exit Sub
' Error causes msgbox to indicate the problem, provides new input box,
' and resumes at the line that caused the error.
MyErrorTrap:
MsgBox "You may not have entered your Month and Year correctly." _
& Chr(13) & "Spell the Month correctly" _
& " (or use 3 letter abbreviation)" _
& Chr(13) & "and 4 digits for the Year"
MyInput = InputBox("Type in Month and year for Calendar")
If MyInput = "" Then Exit Sub
Resume
End Sub
Sub AKReplaceCarriageReturnOnlyNearEndOfLine()
'
' AKReplaceCarriageReturnOnlyNearEndOfLine Macro
'
Call FindCharacterPosition
End Sub
'
Sub FindCharacterPosition()
Dim MyRange As Range
Set MyRange = ActiveDocument.Range
MyRange.Find.Execute FindText:=Chr(13)
MsgBox "Position = " & MyRange.Information(wdHorizontalPositionRelativeToPage)
MyRange.Find.Execute FindText:=Chr(13)
MsgBox "Position = " & MyRange.Information(wdHorizontalPositionRelativeToPage)
MyRange.Find.Execute FindText:=Chr(13)
MsgBox "Position = " & MyRange.Information(wdHorizontalPositionRelativeToPage)
End Sub
No comments:
Post a Comment