Option Explicit
Sub import_text()
Dim fso As Object, f As Object
Dim i As Integer, s As String
Dim pos_accordo As Integer
Dim scala() As Variant, tmp As String
Dim j As Integer, n As Integer, k As Integer
Dim char As String, nuovo_accordo As String, m As String
Dim SEMITONO As Integer
scala = Array("C", "D", "E", "F", "G", "A", "B")
Range("A:K").Clear
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(ThisWorkbook.Path & "prova.txt", 1) ' 1 == FORREADING
Cells(1, "A") = "Testo originale"
Cells(1, "H") = "Posizione dell'accordo"
Cells(1, "K") = "Nuovo accordo"
While SEMITONO = 0
SEMITONO = InputBox("Indica la quantità di semitono da trasporre (da -6 a +6; zero per uscire):", "SEMITONO", 0)
If SEMITONO = 0 Then Exit Sub
If SEMITONO < -6 Or SEMITONO > 6 Then SEMITONO = 0
Wend
i = 2
Do While f.AtEndOfStream <> True
i = i + 1
s = f.ReadLine
Cells(i, "A") = s
If i Mod 2 = 1 Then 'esamina ogni linea dispari degli accordi
Cells(i, "A").Font.Color = vbRed
pos_accordo = InStr(s, Trim(s)) 'a quale carattere comincia l'accordo?
Cells(i, "H") = pos_accordo
m = ""
For j = 1 To Len(s)
char = Mid(s, j, 1)
k = InStr(Join(scala, vbNullString), char)
If k Then
n = k + SEMITONO
If k + SEMITONO > 7 Then n = (k + SEMITONO Mod 7) Mod 7
If k + SEMITONO < 1 Then n = Abs(k + SEMITONO Mod 7)
nuovo_accordo = scala(n - 1)
m = m & nuovo_accordo
Else
m = m & char
End If
Cells(i, "K") = m
Cells(i, "K").Font.Color = vbBlue
Next
End If
Loop
Set fso = Nothing
End Sub
'contenuto del file prova.txt
Am G Dm Em
Perché, perché
Am G
Perché questa canzone
F Em
Dice sempre io
Am G
Perché e mi spinge a precipizio
F Em Am
Ti perdoniamo, ti perdono, perché |