Praatという音声分析ソフトのレポート出力をExcelにまとめたいという要望があり、VBAで作成したので、 ファイル操作やダイアログで複数選ぶ時や文字列を抽出する方法を参考までに。Pulses/Voice Reportの出力は以下の様になっており、 複数のファイルのそれぞれの項目を表にする。ReadFiles()を実行。
-- Voice report for 1. Sound a_1 --
Date: Wed Feb 28 14:37:38 2018
WARNING: some of the following measurements may be imprecise.
For more precision, go to "Pitch settings" and choose "Optimize for voice analysis".
Time range of SELECTION
From 0.040134 to 0.176291 seconds (duration: 0.136157 seconds)
Pitch:
Median pitch: 117.024 Hz
Mean pitch: 118.316 Hz
Standard deviation: 3.136 Hz
Minimum pitch: 114.442 Hz
Maximum pitch: 126.613 Hz
Pulses:
Number of pulses: 16
Number of periods: 15
Mean period: 8.485830E-3 seconds
Standard deviation of period: 0.200097E-3 seconds
Voicing:
Fraction of locally unvoiced frames: 7.143% (1 / 14)
Number of voice breaks: 0
Degree of voice breaks: 0 (0 seconds / 0 seconds)
Jitter:
Jitter (local): 1.051%
Jitter (local, absolute): 89.155E-6 seconds
Jitter (rap): 0.545%
Jitter (ppq5): 0.650%
Jitter (ddp): 1.636%
Shimmer:
Shimmer (local): 7.663%
Shimmer (local, dB): 0.669 dB
Shimmer (apq3): 3.656%
Shimmer (apq5): 5.658%
Shimmer (apq11): 7.601%
Shimmer (dda): 10.969%
Harmonicity of the voiced parts only:
Mean autocorrelation: 0.897243
Mean noise-to-harmonics ratio: 0.174640
Mean harmonics-to-noise ratio: 12.821 dB
Sub ReadFiles()
Dim myFile As Variant
Dim f As Variant
ChDir "C:\"
myFile = Application.GetOpenFilename( _
FileFilter:="テキストファイル (*.txt; *.*),*.txt; *.*", _
MultiSelect:=True)
If IsArray(myFile) Then
For Each f In myFile
Process_File (f)
Next
Else
If myFile <> False Then
Process_File (myFile)
End If
End If
End Sub
Function Process_File(fileName As String)
' MsgBox "以下のファイルを追加：" + fileName
Dim intFF As Integer ' FreeFile値
Dim strREC As String ' 読み込んだレコード内容
Dim GYO As Long ' 収容するセルの行
' １行目生成
Cells(1, 1) = "ファイル名"
Cells(1, 2) = "Jitter (ppq5) (%)"
Cells(1, 3) = "Shimmer (apq5) (%)"
Cells(1, 4) = "Mean harmonics-to-noise ratio (dB)"
' 空行検索
Dim Count As Long
Count = 2
Do Until Cells(Count, 1) = ""
Count = Count + 1
Loop
Cells(Count, 1) = Dir(fileName)
intFF = FreeFile
Open fileName For Input As #intFF
GYO = 1
Do Until EOF(intFF)
Line Input #intFF, strREC
If InStr(strREC, "Jitter (ppq5)") > 0 Then
Cells(Count, 2) = extractStr(strREC, "Jitter (ppq5): ", "%")
End If
If InStr(strREC, "Shimmer (apq5)") > 0 Then
Cells(Count, 3) = extractStr(strREC, "Shimmer (apq5): ", "%")
End If
If InStr(strREC, "Mean harmonics-to-noise ratio") > 0 Then
Cells(Count, 4) = extractStr(strREC, "Mean harmonics-to-noise ratio: ", " dB")
End If
GYO = GYO + 1
Loop
Close #intFF
ProcessFile = Temp
End Function
Function extractStr(rngValue As String, strDel1 As String, strDel2 As String)
Dim startNum As Integer, endNum As Integer
startNum = InStr(rngValue, strDel1) + Len(strDel1) - 1
endNum = InStr(startNum + 1, rngValue, strDel2)
If startNum <> 0 And endNum <> 0 Then
startNum = startNum + 1
extractStr = Mid(rngValue, startNum, endNum - startNum)
Else
extractStr = ""
End If
End Function
以下のように収集される。
| ファイル名 | Jitter (ppq5) (%) | Shimmer (apq5) (%) | Mean harmonics-to-noise ratio (dB) |
| info.txt | 0.65 | 5.658 | 12.821 |
| ... |
項目が多い場合は配列を使うと良い。
Sub ReadFiles()
Dim myFile As Variant
Dim f As Variant
ChDir "C:\"
myFile = Application.GetOpenFilename( _
FileFilter:="テキストファイル (*.txt; *.*),*.txt; *.*", _
MultiSelect:=True)
If IsArray(myFile) Then
For Each f In myFile
Process_File (f)
Next
Else
If myFile <> False Then
Process_File (myFile)
End If
End If
End Sub
Function Process_File(fileName As String)
' MsgBox "以下のファイルを追加：" + fileName
Dim intFF As Integer ' FreeFile値
Dim strREC As String ' 読み込んだレコード内容
Dim GYO As Long ' 収容するセルの行
Dim headList As Variant
headList = Array( _
"Median pitch: ", " Hz", _
"Mean pitch: ", " Hz", _
"Standard deviation: ", " Hz", _
"Minimum pitch: ", " Hz", _
"Maximum pitch: ", " Hz", _
"Jitter (local): ", "%", _
"Jitter (local, absolute): ", " seconds", _
"Jitter (rap): ", "%", _
"Jitter (ppq5): ", "%", _
"Jitter (ddp): ", "%", _
"Shimmer (local): ", "%", _
"Shimmer (local, dB): ", " dB", _
"Shimmer (apq3): ", "%", _
"Shimmer (apq5): ", "%", _
"Shimmer (apq11): ", "%", _
"Shimmer (dda): ", "%", _
"Mean autocorrelation: ", "", _
"Mean noise-to-harmonics ratio: ", "", _
"Mean harmonics-to-noise ratio: ", " dB" _
)
' １行目生成
Cells(1, 1) = "ファイル名"
Length = UBound(headList) - LBound(headList) + 1
For I = 0 To (Length / 2) - 1
Cells(1, I + 2) = headList(I * 2) + headList(I * 2 + 1)
Next I
' 空行検索
Dim Count As Long
Count = 2
Do Until Cells(Count, 1) = ""
Count = Count + 1
Loop
Cells(Count, 1) = Dir(fileName)
intFF = FreeFile
Open fileName For Input As #intFF
GYO = 1
Do Until EOF(intFF)
Line Input #intFF, strREC
For I = 0 To (Length / 2) - 1
If InStr(strREC, headList(I * 2)) > 0 Then
Dim str1 As String
str1 = headList(I * 2)
Dim str2 As String
str2 = headList(I * 2 + 1)
Cells(Count, I + 2) = extractStr(strREC, str1, str2)
End If
Next I
GYO = GYO + 1
Loop
Close #intFF
ProcessFile = Temp
End Function
Function extractStr(rngValue As String, strDel1 As String, strDel2 As String)
Dim startNum As Integer, endNum As Integer
startNum = InStr(rngValue, strDel1) + Len(strDel1) - 1
endNum = InStr(startNum + 1, rngValue, strDel2)
If startNum <> 0 And endNum <> 0 Then
startNum = startNum + 1
extractStr = Mid(rngValue, startNum, endNum - startNum)
If strDel2 = "" And startNum <> 0 Then
extractStr = Mid(rngValue, startNum, Len(rngValue))
End If
Else
extractStr = ""
End If
End Function