Sub Transpose()

'Auteur : JM CLIPET 29/09/2001 modifiée 29/10/2001

' Cette macro transpose les accords d'une grille (tableau) ou d'un morceau (texte)

' du nombre de demi-tons demandé. On doit choisir si on préfère obtenir

' des # ou des b

' Tout ce qui est en italique (Titres ou paroles...) n'est pas considéré comme accords

' et n'est donc pas transposé.

' De même tout ce qui est en exposant est considéré comme enrichissement et n'est donc pas transposé

' Par Ex Bb7 sera transposé mais pas B(exp b5)

Dim Note1$(12)

Note1$(1) = "C"

Note1$(2) = "Db"

Note1$(3) = "D"

Note1$(4) = "Eb"

Note1$(5) = "E"

Note1$(6) = "F"

Note1$(7) = "Gb"

Note1$(8) = "G"

Note1$(9) = "Ab"

Note1$(10) = "A"

Note1$(11) = "Bb"

Note1$(12) = "B"

Dim Note2$(12)

Note2$(1) = "C"

Note2$(2) = "C#"

Note2$(3) = "D"

Note2$(4) = "D#"

Note2$(5) = "E"

Note2$(6) = "F"

Note2$(7) = "F#"

Note2$(8) = "G"

Note2$(9) = "G#"

Note2$(10) = "A"

Note2$(11) = "A#"

Note2$(12) = "B"

Dim Note3$(24)

Note3$(1) = "T"

Note3$(2) = "T#"

Note3$(3) = "U"

Note3$(4) = "U#"

Note3$(5) = "V"

Note3$(6) = "W"

Note3$(7) = "W#"

Note3$(8) = "X"

Note3$(9) = "X#"

Note3$(10) = "Y"

Note3$(11) = "Y#"

Note3$(12) = "Z"

Note3$(13) = "T"

Note3$(14) = "Ub"

Note3$(15) = "U"

Note3$(16) = "Vb"

Note3$(17) = "V"

Note3$(18) = "W"

Note3$(19) = "Xb"

Note3$(20) = "X"

Note3$(21) = "Yb"

Note3$(22) = "Y"

Note3$(23) = "Zb"

Note3$(24) = "Z"

Dim ordre(12)

ordre(1) = 2

ordre(2) = 4

ordre(3) = 7

ordre(4) = 9

ordre(5) = 11

ordre(6) = 1

ordre(7) = 3

ordre(8) = 5

ordre(9) = 6

ordre(10) = 8

ordre(11) = 10

ordre(12) = 12

If Selection.Type = wdSelectionIP Then

MsgBox ("Veuillez sélectionner les accords à transposer")

End

End If

t = Val(InputBox$("Tapez le nombre de demi-tons à transposer (positif ou négatif) : "))

'replace t entre 1 et 12

While (t <= 0)

t = t + 12

Wend

While (t >= 12)

t = t - 12

Wend

Reponse = MsgBox("Appréciez vous les bémols ?", vbYesNo, "Choix bémols ou dièses")

If Reponse = vbYes Then bemol = 1 Else bemol = 0

'supprime l'affichage en mode page pour ne pas perdre de temps avec la pagination

temp = ActiveWindow.View.Type

ActiveWindow.View.Type = wdNormalView

Selection.Find.ClearFormatting

Selection.Find.Font.Italic = False 'Ne modifie pas le texte en italique

Selection.Find.Font.Superscript = False 'Ni les altérations en exposant

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Forward = True

.Wrap = wdFindStop

.Format = True

.MatchCase = True

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Rem Remplace A - G par T - Z transposés

For i = 1 To 12

Result = ordre(i) + t

If Result > 12 Then Result = Result - 12

With Selection.Find

.Text = Note1$(ordre(i))

.Replacement.Text = Note3$(Result + bemol * 12)

End With

Selection.Find.Execute Replace:=wdReplaceAll

If (i <= 5) Then

Rem EditionRemplacer .Rechercher = Note2$(ordre(i)), .Remplacer = Note3$(Result + bemol * 12), .Sens = 0, .RespecterLaCasse = 1, .MotEntier = 0, .CritèresSpéciaux = 1, .Réservé23 = 0, .RemplacerTout, .Format = 1, .RenvoiLigneAuto = 0

With Selection.Find

.Text = Note2$(ordre(i))

.Replacement.Text = Note3$(Result + bemol * 12)

End With

Selection.Find.Execute Replace:=wdReplaceAll

End If

Next i

Rem Remplace tous les T - Z par des A - G

For i = 6 To 12

With Selection.Find

.Text = Note3$(ordre(i))

.Replacement.Text = Note1$(ordre(i))

End With

Selection.Find.Execute Replace:=wdReplaceAll

Next i

ActiveWindow.View.Type = temp

MsgBox ("Fini !")

End Sub