Friday, 30 January 2026

Google Docs Appscript GeneralFunctions 2026

 /**

 * Runs automatically when the document is opened.
 */
function onOpen() {
  DocumentApp.getUi()
    .createMenu('TOC Tools')
    .addItem('Update Table of Contents Now', 'updateTOC')
    .addToUi();

  updateTOC();  // Auto-update on open
}


/**
/ ======================================================================================
/ ======================================================================================
/ AK TABLE OF CONTENTS TOOLS!!!!!! CAN RUN ON OPN
/ AK TABLE OF CONTENTS TOOLS!!!!!! CAN RUN ON OPN



function onOpen() {
  DocumentApp.getUi()
    .createMenu('TOC Tools')
    .addItem('Update Table of Contents Now', 'updateTOC')
    .addToUi();

  updateTOC();  // Auto-update on open
}







*/

/**
 * Builds or updates the Table of Contents at the top.
 */
function updateTOC() {
  const doc = DocumentApp.getActiveDocument();
  const body = doc.getBody();

  removeExistingTOC(body);

  const headings = collectHeadings(body);

  // Feedback (assuming you have a showToast function defined)
  if (headings.length === 0) {
    showToast("No headings (Heading 1–3) found. Check paragraph styles.", "TOC Update", 10);
  } else {
    showToast(`Found ${headings.length} headings. TOC updated.`, "TOC Update", 5);
  }

  if (headings.length === 0) return;

  // Insert title (already black and centered)
  // Insert title
    const tocTitle = body.insertParagraph(0, 'Table of Contents');
    tocTitle.setHeading(DocumentApp.ParagraphHeading.HEADING1)
            .setAlignment(DocumentApp.HorizontalAlignment.CENTER)
            .setAttributes({
              BOLD: true,
              FONT_SIZE: 18,
              FOREGROUND_COLOR: '#000000'
            });

    // Set Calibri for the title too
    const titleText = tocTitle.editAsText();
    titleText.setFontFamily(0, titleText.getText().length - 1, 'Calibri');
     
  body.insertParagraph(1, ''); // blank line

  let insertPos = 2;

  headings.forEach(heading => {
    const p = body.insertParagraph(insertPos++, heading.text.trim());
   
    const indent = (heading.level - 1) * 36;
    p.setIndentStart(indent)
    .setIndentEnd(0)
    .setIndentFirstLine(0);

    // Get the text object for fine-grained control
    const textObj = p.editAsText();  // This gives access to the full text range
    const fullLength = textObj.getText().length;

    // Set font family to Calibri for the entire entry
    textObj.setFontFamily(0, fullLength - 1, 'Calibri');

    // Apply black color and NO underline to the entire text
    textObj.setForegroundColor(0, textObj.getText().length - 1, '#000000');
    textObj.setUnderline(0, textObj.getText().length - 1, false);

    // NOW set the link — Docs will try to force blue/underline, but we override after
    textObj.setLinkUrl(0, textObj.getText().length - 1, '#bookmark=' + heading.bookmarkId);

    // Critical override: re-apply styles AFTER setting the link
    textObj.setForegroundColor(0, textObj.getText().length - 1, '#000000');
    textObj.setUnderline(0, textObj.getText().length - 1, false);
  });

  body.insertHorizontalRule(insertPos);
}

function showToast(message, title = "Info", timeoutSeconds = 4) {
  const html = HtmlService.createHtmlOutput(
    `<div style="padding: 12px; font-family: Arial; font-size: 14px;">
       <strong>${title}</strong><br>
       ${message}
     </div>`
  )
  .setWidth(280)
  .setHeight(80);

  const ui = DocumentApp.getUi();
  ui.showModelessDialog(html, " ");  // empty title bar looks cleaner

  // Auto-close after timeout (client-side JS)
  if (timeoutSeconds > 0) {
    html.append(`<script>
      setTimeout(() => google.script.host.close(), ${timeoutSeconds * 1000});
    </script>`);
  }
}




function removeExistingTOC(body) {
  const toRemove = [];
  let foundTitle = false;

  showToast("Starting TOC cleanup scan...", "Debug", 3);

  for (let i = 0; i < body.getNumChildren(); i++) {
    const child = body.getChild(i);

    if (child.getType() !== DocumentApp.ElementType.PARAGRAPH) {
      // Remove HR or other non-paragraph if after title
      if (foundTitle) {
        toRemove.push(i);
      }
      continue;
    }

    const p = child.asParagraph();
    const textTrim = p.getText().trim();
    const textLower = textTrim.toLowerCase();
    const isHeading = p.getHeading() !== DocumentApp.ParagraphHeading.NORMAL_TEXT;

    // Detect title (very forgiving)
    if (!foundTitle && textLower.includes('table') && textLower.includes('contents')) {
      foundTitle = true;
      toRemove.push(i);
      showToast("TOC title found at position " + i, "Debug", 4);
      continue;
    }

    if (foundTitle) {
      // Keep removing while:
      // - blank
      // - OR has link (bookmark link)
      // - OR indented
      // - OR NOT a heading
      const textObj = p.editAsText();
      const hasLink = textObj.getText().length > 0 && textObj.getLinkUrl() !== null;
      const isIndented = p.getIndentStart() > 0;
      const isBlank = textTrim === '';

      if (isBlank || hasLink || isIndented || !isHeading) {
        toRemove.push(i);
        showToast("Removing TOC-like item at " + i + " (link=" + hasLink + ", indent=" + isIndented + ")", "Debug", 2);
      } else {
        // This looks like your first real section heading → STOP and DO NOT remove it
        showToast("Stop at position " + i + " — real heading detected", "Debug", 5);
        break;
      }

      if (toRemove.length > 60) break; // safety
    }
  }

  if (toRemove.length > 0) {
    showToast("Preparing to remove " + toRemove.length + " items", "Info", 4);
    toRemove.sort((a, b) => b - a);
    toRemove.forEach(idx => {
      try {
        body.removeChild(body.getChild(idx));
      } catch (e) {
        showToast("Remove failed at " + idx + ": " + e.message, "Error", 6);
      }
    });
    showToast("Cleanup finished — removed " + toRemove.length + " items", "Success", 5);
  } else {
    showToast("No TOC detected at top — nothing removed", "Warning", 6);
  }
}


/**
 * Collect headings with reliable bookmark handling
 */
/**
 * Collect headings with reliable bookmark handling (no findElement on Body)
 */
function collectHeadings(body) {
  const doc = DocumentApp.getActiveDocument();
  const headings = [];

  for (let i = 0; i < body.getNumChildren(); i++) {
    const child = body.getChild(i);
    if (child.getType() !== DocumentApp.ElementType.PARAGRAPH) continue;

    const p = child.asParagraph();
    const headingType = p.getHeading();

    if (![DocumentApp.ParagraphHeading.HEADING1,
          DocumentApp.ParagraphHeading.HEADING2,
          DocumentApp.ParagraphHeading.HEADING3].includes(headingType)) continue;

    const text = p.getText().trim();
    if (text === '') continue;

    // Get the Text element reliably (most paragraphs have exactly one Text child)
    let textElement = null;
    if (p.getNumChildren() > 0) {
      const potentialText = p.getChild(0);
      if (potentialText.getType() === DocumentApp.ElementType.TEXT) {
        textElement = potentialText.asText();
      }
    }

    // Fallback: If no Text child (very rare for headings), use editAsText() which gives a Text element
    if (!textElement) {
      textElement = p.editAsText();
    }

    // Now create position at offset 0 (start of the text)
    const position = doc.newPosition(textElement, 0);

    const bookmark = doc.addBookmark(position);
    headings.push({
      level: getHeadingLevel(headingType),
      text: text,
      bookmarkId: bookmark.getId()
    });
  }

  return headings;
}
function getHeadingLevel(heading) {
  switch (heading) {
    case DocumentApp.ParagraphHeading.HEADING1: return 1;
    case DocumentApp.ParagraphHeading.HEADING2: return 2;
    case DocumentApp.ParagraphHeading.HEADING3: return 3;
    default: return 0;
  }
}

/**
/ ======================================================================================
/ ======================================================================================
/ END AK TABLE OF CONTENTS TOOLS!!!!!! CAN RUN ON OPN
/ END AK TABLE OF CONTENTS TOOLS!!!!!! CAN RUN ON OPN */


Monday, 3 November 2025

Word VBA Macro create calendars for boox pdf

 Sub CreateMonthlyCalendar_Landscape()

  Dim yearInput As Integer

    Dim monthIndex As Integer

    Dim mName As String

    Dim firstDate As Date

    Dim lastDate As Date

    Dim tableRows As Integer, tableCols As Integer

    Dim doc As Document

    Dim calTable As Table

    Dim r As Integer, c As Integer

    Dim currentDate As Date

    Dim weekendsColor As Long

    Dim firstWeekday As Integer

    Dim totalDays As Integer

    Dim totalSlots As Integer

    Dim numWeeks As Integer

    

    ' === SETTINGS ===

    weekendsColor = RGB(220, 230, 241)  ' Light blue weekend shading

    tableCols = 7

    

    ' === ASK FOR YEAR ===

    yearInput = InputBox("Enter the calendar year (e.g., 2025):", "Calendar Year", year(Date))

    If Not IsNumeric(yearInput) Then Exit Sub

    If yearInput < 1900 Or yearInput > 2100 Then

        MsgBox "Please enter a valid year between 1900 and 2100."

        Exit Sub

    End If

    

    Set doc = Documents.Add

    With doc.PageSetup

        .Orientation = wdOrientLandscape

        .TopMargin = CentimetersToPoints(0.8)

        .BottomMargin = CentimetersToPoints(0.8)

        .LeftMargin = CentimetersToPoints(0.8)

        .RightMargin = CentimetersToPoints(0.8)

    End With

    

    ' === LOOP THROUGH EACH MONTH ===

    For monthIndex = 1 To 12

        mName = monthName(monthIndex)

        firstDate = DateSerial(yearInput, monthIndex, 1)

        lastDate = DateSerial(yearInput, monthIndex + 1, 0)

        

        ' Page break between months

        If monthIndex > 1 Then doc.Range(doc.Content.End - 1).InsertBreak Type:=wdPageBreak

        

        ' Month heading

        doc.Range.InsertAfter vbCr

        With doc.Paragraphs.Last.Range

            .Text = mName & " " & yearInput

            .Style = "Heading 1"

            .ParagraphFormat.Alignment = wdAlignParagraphCenter

            .InsertParagraphAfter

        End With

        

        ' Determine number of rows needed

        firstWeekday = Weekday(firstDate, vbMonday)

        totalDays = Day(lastDate)

        totalSlots = (firstWeekday - 1) + totalDays

        numWeeks = (totalSlots + 6) \ 7

        tableRows = numWeeks + 1  ' +1 for header row

        

        ' Insert table

        Set calTable = doc.Tables.Add(Range:=doc.Paragraphs.Last.Range, NumRows:=tableRows, NumColumns:=tableCols)

        calTable.Borders.Enable = True

        calTable.PreferredWidthType = wdPreferredWidthPercent

        calTable.PreferredWidth = 100

        

        ' Header row (Mon–Sun)

        Dim daysOfWeek As Variant

        daysOfWeek = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")

        For c = 1 To tableCols

            With calTable.Cell(1, c).Range

                .Text = daysOfWeek(c - 1)

                .ParagraphFormat.Alignment = wdAlignParagraphCenter

                .Bold = True

            End With

        Next c

        

        ' Fill in dates

        currentDate = firstDate

        r = 2

        c = firstWeekday

        

        Do While currentDate <= lastDate

            With calTable.Cell(r, c).Range

                .Text = Day(currentDate)

                .ParagraphFormat.Alignment = wdAlignParagraphRight

            End With

            

            ' Shade weekends

            If Weekday(currentDate, vbMonday) > 5 Then

                calTable.Cell(r, c).Shading.BackgroundPatternColor = weekendsColor

            End If

            

            currentDate = currentDate + 1

            c = c + 1

            If c > 7 Then

                c = 1

                r = r + 1

            End If

        Loop

        

        ' === Adjust table appearance ===

        On Error Resume Next

        calTable.Rows.HeightRule = wdRowHeightExactly

        

        ' Smaller header row

        calTable.Rows(1).Height = CentimetersToPoints(0.9)

        

        ' Slightly smaller date rows

        For r = 2 To calTable.Rows.Count

            calTable.Rows(r).Height = CentimetersToPoints(2.4)

        Next r

        

        ' Column width for landscape fit

        calTable.Columns.PreferredWidth = CentimetersToPoints(3.7)

        On Error GoTo 0

        

        ' Reduce spacing around the table

        calTable.Rows.SpaceBetweenColumns = 0

        calTable.Range.ParagraphFormat.SpaceBefore = 0

        calTable.Range.ParagraphFormat.SpaceAfter = 3

    Next monthIndex

    

    MsgBox "Compact landscape calendar created for " & yearInput & "!", vbInformation

End Sub



Sub AKCreateMonthlyCalendar()


 

    Dim yearInput As Integer

    Dim monthIndex As Integer

    Dim mName As String

    Dim firstDate As Date

    Dim lastDate As Date

    Dim dayNum As Integer

    Dim weekdayNum As Integer

    Dim tableRows As Integer

    Dim tableCols As Integer

    Dim doc As Document

    Dim calTable As Table

    Dim r As Integer, c As Integer

    Dim currentDate As Date

    Dim cellText As String

    Dim weekendsColor As Long

    Dim firstWeekday As Integer

    Dim totalDays As Integer

    Dim totalSlots As Integer

    Dim numWeeks As Integer

    

    ' === SETTINGS ===

    weekendsColor = RGB(220, 230, 241)  ' Light blue highlight for weekends

    tableCols = 7

    

    ' === ASK FOR YEAR ===

    yearInput = InputBox("Enter the calendar year (e.g., 2025):", "Calendar Year", year(Date))

    If Not IsNumeric(yearInput) Then

        MsgBox "Please enter a valid year."

        Exit Sub

    End If

    If yearInput < 1900 Or yearInput > 2100 Then

        MsgBox "Please enter a valid year between 1900 and 2100."

        Exit Sub

    End If

    

    Set doc = Documents.Add

    doc.PageSetup.Orientation = wdOrientPortrait

    

    ' === LOOP THROUGH EACH MONTH ===

    For monthIndex = 1 To 12

        mName = monthName(monthIndex)           ' use a different variable name so MonthName() isn't shadowed

        firstDate = DateSerial(yearInput, monthIndex, 1)

        lastDate = DateSerial(yearInput, monthIndex + 1, 0)

        

        ' Add a page break between months (except first)

        If monthIndex > 1 Then

            doc.Range(doc.Content.End - 1).InsertBreak Type:=wdPageBreak

        End If

        

        ' Insert month heading

        doc.Range.InsertAfter vbCr

        With doc.Paragraphs.Last.Range

            .Text = mName & " " & yearInput

            .Style = "Heading 1"

            .ParagraphFormat.Alignment = wdAlignParagraphCenter

            .InsertParagraphAfter

        End With

        

        ' Calculate number of rows needed for date grid

        firstWeekday = Weekday(firstDate, vbMonday)   ' 1 = Monday ... 7 = Sunday

        totalDays = Day(lastDate)

        totalSlots = (firstWeekday - 1) + totalDays

        numWeeks = (totalSlots + 6) \ 7               ' integer division rounding up

        tableRows = numWeeks + 1                      ' +1 for header row

        

        ' Insert table (header row + weeks rows)

        Set calTable = doc.Tables.Add(Range:=doc.Paragraphs.Last.Range, NumRows:=tableRows, NumColumns:=tableCols)

        calTable.Borders.Enable = True

        calTable.PreferredWidthType = wdPreferredWidthPercent

        calTable.PreferredWidth = 100

        

        ' Header row (Mon–Sun)

        Dim daysOfWeek As Variant

        daysOfWeek = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")

        For c = 1 To tableCols

            With calTable.Cell(1, c).Range

                .Text = daysOfWeek(c - 1)

                .ParagraphFormat.Alignment = wdAlignParagraphCenter

                .Bold = True

            End With

        Next c

        

        ' Fill in dates

        currentDate = firstDate

        r = 2

        c = firstWeekday

        

        Do While currentDate <= lastDate

            cellText = CStr(Day(currentDate))

            With calTable.Cell(r, c).Range

                .Text = cellText

                .ParagraphFormat.Alignment = wdAlignParagraphRight

                .ParagraphFormat.SpaceAfter = 6

            End With

            

            ' Highlight weekends (Saturday=6, Sunday=7 when Weekday(..., vbMonday))

            If Weekday(currentDate, vbMonday) > 5 Then

                calTable.Cell(r, c).Shading.BackgroundPatternColor = weekendsColor

            End If

            

            ' Advance to next day

            currentDate = currentDate + 1

            c = c + 1

            If c > 7 Then

                c = 1

                r = r + 1

            End If

        Loop

        

        ' Optional: make cells a reasonable size for notes

        On Error Resume Next

        calTable.Rows.HeightRule = wdRowHeightExactly

        calTable.Rows.Height = CentimetersToPoints(2.6)  ' adjust as desired

        calTable.Columns.PreferredWidth = CentimetersToPoints(2.5)

        On Error GoTo 0

        

        calTable.Range.ParagraphFormat.SpaceBefore = 3

        calTable.Range.ParagraphFormat.SpaceAfter = 3

    Next monthIndex

    

    MsgBox "Calendar created for " & yearInput & "!", vbInformation

End Sub

Sub AKCreateGoalStatement word vba

 Sub AKCreateGoalStatement()

    Dim goal As String

    Dim month As String

    Dim year As String

    Dim emotion As String

    

        monthAndYear = InputBox("Enter the goal month and year(e.g., November 2025):")

    goal = InputBox("Enter the goal (how to know it's achieved):")

    emotion = InputBox("Enter the emotion you'll feel when achieved:")

    


    

    Dim statement As String

    statement = "It is now " & monthAndYear & " and " & goal & " and " & emotion & "."

    

    Selection.TypeText Text:=statement & vbCrLf

End Sub


Friday, 12 September 2025

Microsoft word VBA functions 2025

 




Sub AKDeleteEmptyRows_AllTables()


 


Dim oTable As Table


Dim oRow As Row


Dim intRowCount As Integer


 


For Each oTable In ActiveDocument.Tables


  


    'Check whether row is empty - delete if it is


    'ATK 1/6/2024  what does * 2 + 2 mean??????


   


       'first fo any nested tables


    For Each nestedTable In oTable.Tables


       intRowCount = nestedTable.Rows.Count


        For Each nestedRow In nestedTable.Rows


            If Len(nestedRow.Range.Text) = nestedRow.Cells.Count * 2 + 2 Then


                nestedRow.Delete


            End If


        Next nestedRow


    Next nestedTable


        For Each oRow In oTable.Rows


            oRow.Select


         intRowCount = oTable.Rows.Count


         oRow.Select


        If Len(oRow.Range.Text) = oRow.Cells.Count * 2 + 2 Then


           oRow.Delete


        End If


   


    Next oRow


Next oTable


 


 


 


 


Exit Sub


 


End Sub 'AKDeleteEmptyRows_AllTables()


Sub AKRemoveSpacesAndLines()

'

' AKRemoveSpacesAndLines Macro

'

'

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = "2024-??-*:??:??"

        .Replacement.Text = " "

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = "2024-??-*:??:??"

        .Replacement.Text = " "

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchAllWordForms = False

        .MatchSoundsLike = False

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Copy

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = "________________________________________"

        .Replacement.Text = " "

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchAllWordForms = False

        .MatchSoundsLike = False

        .MatchWildcards = True

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = "^p^p"

        .Replacement.Text = "~!@#"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Find.Execute Replace:=wdReplaceAll

    ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View. _

        ShowAll

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = "^p ^p"

        .Replacement.Text = "~!@#"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Find.Execute Replace:=wdReplaceAll

    With Selection.Find

        .Text = "^p"

        .Replacement.Text = " "

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    With Selection.Find

        .Text = "~!@#"

        .Replacement.Text = "^p^p"

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Sub AKMakeTrueTitleCaseHeading1s()

' AKMakeTrueTitleCaseHeading1- Ones -

    ' was called Sub Heading1MakeTitle()

' Calls TitleCase procedure

' Paul Edstein

' http://www.msofficeforums.com/word/24807-how-do-i-convert-line-text-title.html#post78192

' Makes all Heading 1 text title case ' I think I have to select all text....

'

    Application.ScreenUpdating = False

    Dim StrTmp As String

    With ActiveDocument.Range

      With .Find

        Let .MatchWildcards = True

        .ClearFormatting

        .Replacement.ClearFormatting

        Let .Format = True

        Let .Wrap = wdFindStop

        .Execute Replace:=wdReplaceAll

        Let .Style = "Heading 1"

        Let .Text = "[!^13]{1,}"

        Let .Replacement.Text = ""

        .Execute

      End With

      Do While .Find.Found

        StrTmp = Trim(.Text)

        While Right(StrTmp, 1) = "."

          Let StrTmp = Left(StrTmp, Len(StrTmp) - 1)

        Wend

        While InStr(StrTmp, "  ") > 0

          Let StrTmp = Replace(StrTmp, "  ", " ")

        Wend

        StrTmp = TitleCase(StrTmp, bCaps:=False, blExcludeCertainWords:=True)

        Let .Text = StrTmp

        .Collapse wdCollapseEnd

        .Find.Execute

      Loop

    End With

    Application.ScreenUpdating = True


'

'


End Sub ' AK make all headings 1s true title case


Sub MakeTitle()

' Calls TitleCase procedure

' Paul Edstein

' http://www.msofficeforums.com/word/24807-how-do-i-convert-line-text-title.html#post78192

' Converts selected text to true Title Case

'

    Application.ScreenUpdating = False

    Dim StrTmp As String

    With Selection.Range

      Let StrTmp = Trim(.Text)

      While Right(StrTmp, 1) = "."

        Let StrTmp = Left(StrTmp, Len(StrTmp) - 1)

      Wend

      While InStr(StrTmp, "  ") > 0

        Let StrTmp = Replace(StrTmp, "  ", " ")

      Wend

      Let StrTmp = TitleCase(StrTmp, bCaps:=False, blExcludeCertainWords:=True)

      .Text = StrTmp

    End With

    Let Application.ScreenUpdating = True

End Sub




Private Function TitleCase(StrTxt As String, Optional bCaps As Boolean, Optional bClos As Boolean, Optional blExcludeCertainWords As Boolean) As String

' Paul Edstein

' http://www.msofficeforums.com/word/24807-how-do-i-convert-line-text-title.html#post78192

' December 2016

' Goes with MakeTitle and HeadingMakeTitle macros

' Added Let to beginning of variable definitions CKK 2018-10-07

'

'Convert an input string to proper-case.

'Surnames like O', Mc & Mac and hyphenated names are converted to title case also.

'If bCaps = True, then upper-case strings like ABC are preserved; otherwise they're converted.

'If bClos = False, words in the exclusion list after closing characters are retained as lower-case; otherwise they're converted.

'If blExcludeCertainWords = True, words in the exclusion list are retained as lower-case, unless after specified punctuation marks.

    Dim i As Long, j As Long, k As Long, l As Long, bFnd As Boolean

    Dim StrChr As String, StrExcl As String, StrMac As String, StrPunct As String, StrTmpA As String, StrTmpB As String

    'General exclusion list.

    Let StrExcl = "(a),a,am,an,and,are,as,at,(b),be,but,by,(c),can,cm,(d),did,do,does,(e),eg,en,eq,etc,(f),for," & _

              "(g),get,go,got,(h),has,have,he,her,him,how,(i),ie,if,in,into,is,it,its,(j),(k),(l),(m),me,mi," & _

              "mm,my,(n),na,nb,no,not,(o),of,off,ok,on,one,or,our,out,(p),(q),(r),re,(s),she,so,(t),the," & _

              "their,them,they,this,to,(u),(v),via,vs,(w),was,we,were,who,will,with,would,(x),(y),yd,you,your,(z)"

    'Mac name lower-case list.

    Let StrMac = "Macad,Macau,Macaq,Macaro,Macass,Macaw,Maccabee,Macedon,Macerate,Mach,Mack,Macle,Macrame,Macro,Macul,Macumb"

    Let StrPunct = "!,;,:,.,?,/,(,{,[,<,“,"""

    If bClos = True Then StrPunct = StrPunct & ",),},],>,”"

    If blExcludeCertainWords = False Then

      Let StrExcl = ""

      Let StrPunct = ""

    Else

      Let StrExcl = " " & Replace(Trim(StrExcl), ",", " , ") & " "

    End If

    If Len(Trim(StrTxt)) = 0 Then

      Let TitleCase = StrTxt

      Exit Function

    End If

    If bCaps = False Then StrTxt = LCase(StrTxt)

    StrTxt = " " & StrTxt & " "

    For i = 1 To UBound(Split(StrTxt, " ")) - 1

      Let StrTmpA = Split(StrTxt, " ")(i)

      'Check for a double-quote before the word

      If Left(StrTmpA, 1) Like "[""“”]" Then

        Let StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)

      Else

        Let StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)

      End If

      Let StrTmpB = " " & StrTmpB & " "

      Let StrTmpA = " " & StrTmpA & " "

      Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

    Next

    'Code for handling hyphenated words

    For i = 1 To UBound(Split(StrTxt, "-"))

      Let StrTmpA = Split(StrTxt, "-")(i)

      Let StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)

      Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

    Next

    'Code for handling family names starting with O'

    For i = 1 To UBound(Split(StrTxt, "'"))

      If InStr(Right(Split(StrTxt, "'")(i - 1), 2), " ") = 1 Or _

        Right(Split(StrTxt, "'")(i - 1), 2) = Right(Split(StrTxt, "'")(i - 1), 1) Then

        Let StrTmpA = Split(StrTxt, "'")(i)

        Let StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)

        Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

      End If

    Next

    'Code for handling family names starting with Mc

    If Left(StrTxt, 2) = "Mc" Then

      Let Mid(StrTxt, 3, 1) = UCase(Mid(StrTxt, 3, 1))

    End If

    Let i = InStr(StrTxt, " Mc") + InStr(StrTxt, """Mc")

    If i > 0 Then

      Let Mid(StrTxt, i + 3, 1) = UCase(Mid(StrTxt, i + 3, 1))

    End If

    'Code for handling family names starting with Mac

    If InStr(1, StrTxt, "Mac", vbBinaryCompare) > 0 Then

      For i = 1 To UBound(Split(StrTxt, " "))

        Let StrTmpA = Split(StrTxt, " ")(i)

        If InStr(1, StrTmpA, "Mac", vbBinaryCompare) > 0 Then

          Let StrTmpA = Left(StrTmpA, Len(StrTmpA) - InStr(1, StrTmpA, "Mac", vbBinaryCompare) + 1)

          Let bFnd = False

          For j = 0 To UBound(Split(StrMac, ","))

            Let StrTmpB = Split(StrMac, ",")(j)

            If Left(StrTmpA, Len(StrTmpB)) = StrTmpB Then

              Let bFnd = True

              Exit For

            End If

          Next

          If bFnd = False Then

            If Len(Split(Trim(StrTmpA), " ")(0)) > 4 Then

              Let StrTmpB = StrTmpA

              Let Mid(StrTmpB, 4, 1) = UCase(Mid(StrTmpB, 4, 1))

              Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

            End If

          End If

        End If

      Next

    End If

    'Code to restore excluded words to lower case

    If StrExcl <> "" Then

      For i = 0 To UBound(Split(StrExcl, ","))

        Let StrTmpA = Split(StrExcl, ",")(i)

        Let StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)

        If InStr(StrTxt, StrTmpB) > 0 Then

          Let StrTxt = Replace(StrTxt, StrTmpB, StrTmpA)

          'Make sure an excluded words following punctution marks are given proper case anyway

          For j = 0 To UBound(Split(StrPunct, ","))

            Let StrChr = Split(StrPunct, ",")(j)

            Let StrTxt = Replace(StrTxt, StrChr & StrTmpA, StrChr & StrTmpB)

          Next

        End If

      Next

    End If

    Let TitleCase = Trim(StrTxt)

End Function ' TitleCase




'

Sub ConvertURLsToHyperlinks()

    Dim rng As Range

    Dim i As Long

    Dim urlPattern As String

    Dim urlMatch As Object

    Dim url As String

    Dim para As Paragraph

    

 

    ' Regular expression pattern to match URLs

    urlPattern = "(http|https)://[a-zA-Z0-9./?=_-]+"

 

    ' Loop through each paragraph in the document

    For Each para In ActiveDocument.Paragraphs

        Set rng = para.Range

        Set urlMatch = Nothing

         

        ' Use Regular Expressions to find URLs

        With CreateObject("VBScript.RegExp")

            .Pattern = urlPattern

            .Global = True

            If .Test(rng.Text) Then

                Set urlMatch = .Execute(rng.Text)

                ' Loop through all matches

                For i = 0 To urlMatch.Count - 1

                    url = urlMatch(i).Value

                    rng.Hyperlinks.Add Anchor:=rng, Address:=url, TextToDisplay:=url

                Next i

            End If

        End With

    Next para

End Sub ' createallhyperlinks


Thursday, 10 July 2025

Publish or perish - research software literature software

 For those in academia or research - Publish or Perish software is excellent if you really want to find popular research papers on a subject. Highly recommended. https://harzing.com/resources/publish-or-perish




Wednesday, 26 March 2025

Google Docs and Sheets AppScript to add menu and replace new lines

 


function onOpen() {
  const ui = DocumentApp.getUi();
  const menu = ui.createMenu('AK Menu'); // Replace 'My Menu' with your desired menu name
  menu.addItem('AKReplace', 'replaceAKNewlinesAndCaptureExpressions'); // Replace 'Show Spreadsheet Name' and 'showName' with your desired item name and function name
  menu.addToUi();
}


function replaceAKNewlinesAndCaptureExpressions() {
  // allows google docs to use matching capture in replace expression
  // eg (\d\d )\n - find things like 10 \n - newline
  // replace with $1  - removes the new line character and keeps the digits eg 11
  var body = DocumentApp.getActiveDocument().getBody();
  var paragraphs = body.getParagraphs();
   const ui = DocumentApp.getUi();
    const response = ui.prompt(
    'Search Text? (currently HARDCODED)',
    ui.ButtonSet.YES_NO,);

  for (var i=0; i<paragraphs.length; i++) {
    var text = paragraphs[i].getText();

    // need to create an input form here or two or three popups for search text
    // replace text
    paragraphs[i].replaceText("(\d\d) \n", "$1") ;
  }
}

Wednesday, 6 December 2023

Some Word VB macros eg GetRandomQuotes

 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