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
If you can read this, you're too close.
I have much more books than I can put on my night-stand. Books that are on my
night-stand are quickly accessible (when I'm in bed, that is), and books on
the shelf are not (I hate getting up from the cozy, warm, bed). So, when I
suddenly feel like reading a book that is not on the night- stand, I have no
choice but to go to sleep. In the morning, I wake up and always find the book
I wanted next to the bed! As it turns out, when I was asleep, another process,
known as "sleepwalkd" got me the book I wanted. Also, when my nightstand
already has too many books on it, The sleepwalk process moves one of the books
- the one I'm least likely to want to read next - back to the shelf.
Last month, four Europeans with weird names decided to mess around with my
book-reading system. One called Alan decided that in some cases I should move
*all* my books to the shelf, go to bed without any books the same night, and
instead fill the nightstand with crap. And if somehow all my shelves are full
I should just burn one at random (if it burns the whole shelf, or the wrong
shelf, who cares).
Another one, called Andrea, decided that I should redesign my whole
sleepwalking routine according to his master-plan. However, this made my
sleepwalking become so strange, that people were hesitant to call me "stable"
any more. Alan thought my new sleepwalking was a sure sign of be not being
stable.
But then a third European, Linus, finally made a judgment-call, and decided
that I was stable, even with Andrea's new sleepwalking routine. He then told
yet another European, Marcello, that from now he's resposible for keeping me
stable. I thought it was my shrink's resposibility, but Marcello said no, that
now that he finally has some responsibility he's not going to just give it up.
-- Nadav Har'El
-- Hackers-IL Message No. 1,408 ( http://tech.groups.yahoo.com/group/hackers-il/message/1408 )