Word VBA - Convert ChatGPT file into Word document

Run subroutines one by one in order:

Sub ChatGptDocumentMaker()
    ClearBgColorGrotic1One
    BoldTextBetweenUserAndChatGPT2Two
    ReplaceUser3Three
    ReplaceGPTbyAnswer4Four
    DoubleParaToSingle5Five
    BoldTextBeforeLastDoubleStars6Six
    BoldAndColorLinesStartingWithTripleHash7Seven
    AdjustTableWidths8Eight
    AdjustImageSizes9Nine
    FormatTripleBacktickSections10Ten
    DeleteLineContainingTripleBackticks11Eleven
End Sub

Run the following code to select document and remove special formatting

Sub ClearBgColorGrotic1One()
    Selection.WholeStory
    Selection.Font.Name = "a_Grotic"
    Selection.Shading.Texture = wdTextureNone
    Selection.Shading.ForegroundPatternColor = wdColorAutomatic
    Selection.Shading.BackgroundPatternColor = wdColorAutomatic
End Sub

Run the following code to Bold Text between user and ChatGPT

Sub BoldTextBetweenUserAndChatGPT2Two()
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True

    With Selection.Find
        .Text = "user^13(*)ChatGPT^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = True
        .Color = wdColorBlue
        .Name = "Georgia"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code

Sub ReplaceUser3Three()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "user^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub ReplaceGPTbyAnswer4Four()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = False
        .Italic = False
        .Color = wdColorBlack
        .Name = "Courier New"
    End With
    With Selection.Find
        .Text = "ChatGPT^p"
        .Replacement.Text = "Answer: "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub DoubleParaToSingle5Five()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub BoldTextBeforeLastDoubleStars6Six()
    Dim doc As Document
    Dim para As Paragraph
    Dim pos As Integer
    Dim lineText As String
    Dim rng As Range
    Dim lastPos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        lastPos = InStrRev(lineText, "**")
        
        ' If '**' is found, bold the preceding text
        If lastPos > 1 Then
            Set rng = para.Range.Duplicate
            rng.End = rng.Start + lastPos - 1
            rng.Font.Bold = True
        End If
    Next para
End Sub

Run the following code:

Sub BoldAndColorLinesStartingWithTripleHash7Seven()
    Dim doc As Document
    Dim para As Paragraph
    Dim lineText As String
    Dim rng As Range
    Dim pos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        pos = InStr(lineText, "###")
        
        ' If the paragraph starts with '###', format the entire paragraph
        If pos = 1 Then
            Set rng = para.Range
            rng.Font.Bold = True
            rng.Font.Color = wdColorBrown
            rng.Font.Size = 10
        End If
    Next para
End Sub

Run the following code:

Sub AdjustTableWidths8Eight()
    Dim doc As Document
    Dim tbl As Table
    Dim tblWidth As Single
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    For Each tbl In doc.Tables
        tblWidth = tbl.PreferredWidth

        If tblWidth > docWidth Then
            tbl.PreferredWidth = docWidth
            tbl.AllowAutoFit = False ' Prevent autofit to ensure width stays as set
            ' Optionally, you can adjust column widths proportionally
            Dim col As Column
            Dim totalColWidth As Single
            totalColWidth = 0

            ' Calculate total width of columns
            For Each col In tbl.Columns
                totalColWidth = totalColWidth + col.Width
            Next col

            ' Adjust each column proportionally
            For Each col In tbl.Columns
                col.Width = col.Width * docWidth / totalColWidth
            Next col
        End If
    Next tbl
End Sub

Run the following code

Sub AdjustImageSizes9Nine()
    Dim doc As Document
    Dim img As InlineShape
    Dim shape As shape
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    ' Loop through all inline shapes (embedded images)
    For Each img In doc.InlineShapes
        If img.Width > docWidth Then
            img.LockAspectRatio = msoTrue
            img.Width = docWidth
        End If
    Next img

    ' Loop through all floating shapes (floating images)
    For Each shape In doc.Shapes
        If shape.Type = msoPicture Or shape.Type = msoLinkedPicture Then
            If shape.Width > docWidth Then
                shape.LockAspectRatio = msoTrue
                shape.Width = docWidth
            End If
        End If
    Next shape
End Sub

Run the following code:

Sub FormatTripleBacktickSections10Ten()
    Dim doc As Document
    Dim rng As Range
    Dim startRng As Range
    Dim endRng As Range
    Dim textRng As Range
    Dim found As Boolean
    Dim languages As Variant
    Dim i As Integer

    Set doc = ActiveDocument
    Set rng = doc.Content

    ' Array of languages to check
    languages = Array("```csharp", "```css", "```html", "```javascript", "```sql")

    For i = LBound(languages) To UBound(languages)
        With rng.Find
            .ClearFormatting
            .Text = languages(i) & "^13"

            Do While .Execute(Forward:=True) = True
                ' Set the start range at the end of the found triple backticks line
                Set startRng = rng.Duplicate
                startRng.Collapse Direction:=wdCollapseEnd

                ' Find the closing triple backticks
                With startRng.Find
                    .Text = "```^13"
                    If .Execute(Forward:=True) = True Then
                        ' Set the end range at the start of the found triple backticks line
                        Set endRng = startRng.Duplicate
                        endRng.Collapse Direction:=wdCollapseStart

                        ' Set the text range between the end of the starting triple backticks and the start of the ending triple backticks
                        Set textRng = doc.Range(rng.End, startRng.Start - 1)

                        ' Apply single line spacing, before spacing 5pt, and after spacing 5pt
                        With textRng.ParagraphFormat
                            .SpaceBefore = 5
                            .SpaceAfter = 5
                            .LineSpacingRule = wdLineSpaceSingle
                        End With

                        ' Apply font style and color
                        With textRng.Font
                            .Name = "Calibri" ' or "Arial Narrow"
                            .Size = 9 ' Adjust the font size as needed
                        End With

                        ' Fill the background color with a very light cyan
                        textRng.Shading.BackgroundPatternColor = RGB(204, 255, 255) ' Light cyan

                    End If
                End With

                ' Move the main search range past the found end triple backticks
                rng.Start = startRng.End
            Loop
        End With

        ' Reset the range for the next language search
        Set rng = doc.Content
    Next i
End Sub

Run the following code

Sub DeleteLineContainingTripleBackticks11Eleven()
    Dim doc As Document
    Dim rng As Range
    Dim findText As String
    
    ' The text to search for: any word starting with ```
    findText = "```"
    
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    With rng.Find
        .ClearFormatting
        .Text = findText
        .Forward = True
        .Wrap = wdFindStop
        
        Do While .Execute
            ' Move range to the start of the line containing the found text
            rng.Start = rng.Paragraphs(1).Range.Start
            ' Extend range to the end of the line
            rng.End = rng.Paragraphs(1).Range.End
            ' Delete the line
            rng.Delete
            
            ' Move to the next instance
            rng.Collapse Direction:=wdCollapseEnd
        Loop
    End With
End Sub

Run the following code

Sub ExtractQuestionsAndMoveToTopPerfectUsingDictionary()
    Dim doc As Document
    Dim para As Paragraph
    Dim questionsDict As Object
    Dim questionRangesDict As Object
    Dim k As Integer
    Dim questionText As String
    Dim rngQStart As Range
    Dim topRng As Range
    Dim key As Variant

    ' Initialize the document and dictionaries
    Set doc = ActiveDocument
    Set questionsDict = CreateObject("Scripting.Dictionary")
    Set questionRangesDict = CreateObject("Scripting.Dictionary")
    k = 1
    questionText = ""

    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        ' Check if the paragraph has the required format
        With para.Range.Font
            If .Name = "Georgia" And .Size = 10 And .Bold = True And .Color = RGB(0, 0, 255) Then
                ' Store the starting range of the question
                If questionText = "" Then
                    Set rngQStart = para.Range.Duplicate
                End If
                ' Append the plain text of the paragraph to the question text
                questionText = questionText & para.Range.Text
            ElseIf Len(questionText) > 0 Then
                ' Store the collected question text in the dictionary
                questionsDict.Add k, questionText
                questionRangesDict.Add k, rngQStart
                k = k + 1
                questionText = ""
            End If
        End With
    Next para

    ' If there's any remaining question text, add it to the dictionaries
    If Len(questionText) > 0 Then
        questionsDict.Add k, questionText
        questionRangesDict.Add k, rngQStart
    End If

    ' Set the range to the start of the document to insert questions
    Set topRng = doc.Range(0, 0)

    ' Insert questions and hyperlinks at the top of the document in reverse order
    For i = questionsDict.Count To 1 Step -1
        ' Insert question with key
        topRng.InsertAfter questionsDict(i) & vbCrLf
        
        ' Move the range to the end of the newly added text
        Set topRng = doc.Range(0, 0)
        topRng.Collapse wdCollapseEnd
        
        ' Add a bookmark and hyperlink
        AddHyperlink topRng, "Q" & i, questionRangesDict(i)
    Next i
End Sub

Run the following code

Sub AddHyperlink(rng As Range, displayText As String, targetRange As Range)
    ' Add a bookmark at the target range so that the hyperlink can reference it
    On Error Resume Next
    ActiveDocument.Bookmarks.Add Name:=displayText, Range:=targetRange
    On Error GoTo 0

    ' Add a hyperlink to the specified range
    ActiveDocument.Hyperlinks.Add _
        Anchor:=rng, _
        Address:="", _
        SubAddress:=displayText, _
        TextToDisplay:=displayText
End Sub