Attribute VB_Name = "Module1"
' =====================================================================
' File: MSWordChordChartTransposer.bas
'
' Designer: Barry K
' AI Code Generator: ChatGPT based on GPT-5.1
' Human QA & Debugging: Barry K
' Version: 1.0 - 10 December 2025
'
' Usage: Open Visual Basic Editor in MS Word.
'             In the Project panel, right-click Project and select Insert->Module.
'             On the inserted Module, right-click and select Import File...
'             Import this file.
'             Run this macro on a chord chart that is formatted with a Custom Style called "4) Chords".
'                    NOTE: This code checks for styles with the name "4) Chords" to know what to transpose.
' =====================================================================

Option Explicit

Sub TransposeChords()
    Dim interval As Integer
    Dim sharpsOrFlats As String
    
    interval = Val(InputBox("Transpose by how many semitones?" & vbCrLf & _
                            "(Example: 2 = up whole step, -2 = down whole step)", _
                            "Transpose Interval", "2"))
    If interval = 0 Then Exit Sub

    sharpsOrFlats = UCase(InputBox("Output using:" & vbCrLf & _
                                   "S = Sharps (C#, F#)" & vbCrLf & _
                                   "F = Flats (Db, Gb)", _
                                   "Sharp or Flat Output?", "S"))
    If sharpsOrFlats <> "S" And sharpsOrFlats <> "F" Then sharpsOrFlats = "S"

    Call TransposeChords_Internal(interval, sharpsOrFlats)
End Sub


Sub TransposeChords_Internal(interval As Integer, useSharpsFlats As String)

    Dim styleName As String: styleName = "4) Chords"  ' <<< CHANGE THIS TO MATCH YOUR STYLE NAME
    Dim pList() As Paragraph
    Dim count As Long
    Dim para As Paragraph
    Dim i As Long

    ' -------- 1. Collect chord paragraphs into array --------
    count = 0
    For Each para In ActiveDocument.Paragraphs
        If para.Range.Style = styleName Then
            count = count + 1
            ReDim Preserve pList(1 To count)
            Set pList(count) = para
        End If
    Next para

    ' -------- 2. Process chord paragraphs safely --------
    Dim txt As String, newTxt As String

    For i = 1 To count
        txt = pList(i).Range.Text

        ' Remove ending CR
        If Right(txt, 1) = vbCr Or Right(txt, 1) = Chr(13) Then
            txt = Left(txt, Len(txt) - 1)
        End If

        newTxt = ProcessChordRun(txt, interval, useSharpsFlats)

        If newTxt <> txt Then
            pList(i).Range.Text = newTxt & vbCr
        End If
    Next i

End Sub


' =====================================================================
' PROCESS ONE LINE OF CHORDS
' =====================================================================
Function ProcessChordRun(chordText As String, interval As Integer, outSf As String) As String
    Dim parts() As String
    Dim i As Integer

    parts = Split(chordText, " ")
    For i = 0 To UBound(parts)
        parts(i) = TransposeOneChord(parts(i), interval, outSf)
    Next i

    ProcessChordRun = Join(parts, " ")
End Function


' =====================================================================
' PROCESS ONE CHORD TOKEN
' =====================================================================
Function TransposeOneChord(ch As String, interval As Integer, outSf As String) As String
    Dim slashPos As Integer
    Dim root As String, suffix As String

    ch = Trim(ch)
    If ch = "" Then
        TransposeOneChord = ""
        Exit Function
    End If

    slashPos = InStr(ch, "/")
    If slashPos > 0 Then
        TransposeOneChord = _
            TransposeOneChord(Left(ch, slashPos - 1), interval, outSf) & "/" & _
            TransposeRoot(Mid(ch, slashPos + 1), interval, outSf)
        Exit Function
    End If

    root = ExtractRoot(ch)
    suffix = Mid(ch, Len(root) + 1)

    TransposeOneChord = TransposeRoot(root, interval, outSf) & suffix
End Function


' =====================================================================
' SUPPORT FUNCTIONS
' =====================================================================
Function ExtractRoot(ch As String) As String
    If Len(ch) >= 2 Then
        If Mid(ch, 2, 1) = "#" Or Mid(ch, 2, 1) = "b" Then
            ExtractRoot = Left(ch, 2)
            Exit Function
        End If
    End If
    ExtractRoot = Left(ch, 1)
End Function

Function NormalizeAccidentals(root As String) As String
    root = Replace(root, "Db", "C#")
    root = Replace(root, "Eb", "D#")
    root = Replace(root, "Gb", "F#")
    root = Replace(root, "Ab", "G#")
    root = Replace(root, "Bb", "A#")
    NormalizeAccidentals = root
End Function

Function TransposeRoot(root As String, interval As Integer, outSf As String) As String
    Dim sharpScale, flatScale
    Dim idx As Integer

    sharpScale = Array("C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B")
    flatScale = Array("C", "Db", "D", "Eb", "E", "F", "Gb", "G", "Ab", "A", "Bb", "B")

    root = NormalizeAccidentals(root)
    idx = NoteIndex(root)

    If idx < 0 Then
        TransposeRoot = root
        Exit Function
    End If

    idx = (idx + interval) Mod 12
    If idx < 0 Then idx = idx + 12

    If outSf = "F" Then
        TransposeRoot = flatScale(idx)
    Else
        TransposeRoot = sharpScale(idx)
    End If
End Function

Function NoteIndex(root As String) As Integer
    Select Case root
        Case "C": NoteIndex = 0
        Case "C#", "Db": NoteIndex = 1
        Case "D": NoteIndex = 2
        Case "D#", "Eb": NoteIndex = 3
        Case "E": NoteIndex = 4
        Case "F": NoteIndex = 5
        Case "F#", "Gb": NoteIndex = 6
        Case "G": NoteIndex = 7
        Case "G#", "Ab": NoteIndex = 8
        Case "A": NoteIndex = 9
        Case "A#", "Bb": NoteIndex = 10
        Case "B": NoteIndex = 11
        Case Else: NoteIndex = -1
    End Select
End Function