VBA Software


'
' CSV形式テキストファイル(不定カラム)読み込み
'   http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_030.html
'   http://www.asahi-net.or.jp/~ef2o-inue/top01.html#
'           作成 井上治殿
'   Modified by Kenji Arai /JH1PJL  Jan. 31st, 2010
'                                   Jan. 31st, 2010
'
Sub READ_TextFile()
    Const cnsTITLE = "テキストファイル読み込み処理"
    Const cnsFILTER = "全てのファイル (*.*),*.*"
    Dim xlAPP As Application        ' Applicationオブジェクト
    Dim intFF As Integer            ' FreeFile値
    Dim strFILENAME As String       ' OPENするファイル名(フルパス)
    Dim x() As Variant              ' 読み込んだレコード内容
    Dim IX1 As Long                 ' CSV項目カラムINDEX
    Dim GYO As Long                 ' 収容するセルの行
    Dim lngREC As Long              ' レコード件数カウンタ
    Dim strREC As String            ' レコード領域
    Dim POS1 As Long                ' レコード文字位置INDEX
    Dim POS2 As Long                ' レコード文字位置INDEX
    Dim CNT1 As Integer             ' 文字列内カウンタ
    Dim strTMP As String            ' 文字の一時格納

    ' Applicationオブジェクト取得
    Set xlAPP = Application
    ' 「ファイルを開く」のフォームでファイル名の指定を受ける
    xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
    strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
        Title:=cnsTITLE)
    ' キャンセルされた場合は以降の処理は行なわない
    If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

    ' FreeFile値の取得(以降この値で入出力する)
    intFF = FreeFile
    ' 指定ファイルをOPEN(入力モード)
    Open strFILENAME For Input As #intFF
    GYO = 1
    ' ファイルのEOF(End of File)まで繰り返す
    Do Until EOF(intFF)
        ' レコード件数カウンタの加算
        lngREC = lngREC + 1
        xlAPP.StatusBar = "読み込み中です．．．．(" & lngREC & "レコード目)"
        ' 行単位にレコードを読み込む
        Line Input #intFF, strREC
        
        ' LineInputより自分で半角カンマを探しCSV→項目分割させる
        POS1 = 1
        IX1 = 0
        ReDim x(IX1)                ' 配列を初期化
        Do While POS1 <= Len(strREC)
            POS2 = InStr(POS1, strREC, ",", vbTextCompare)
            If POS2 < POS1 Then
                POS2 = Len(strREC) + 1
            End If
            ReDim Preserve x(IX1)   ' 配列要素数を再設定
            x(IX1) = Trim$(Mid$(strREC, POS1, POS2 - POS1))
            ' *があるか否かをチェックし、あれば2つに分割する
            CNT1 = 0
            strTMP = x(IX1)
            CNT1 = InStr(1, strTMP, "*", vbTextCompare)
            If (CNT1 <> 0) Then  ' データを分割
                x(IX1) = Left$(strTMP, CNT1 - 1)
                IX1 = IX1 + 1
                ReDim Preserve x(IX1)
                x(IX1) = Right$(strTMP, Len(strTMP) - CNT1 + 1)
            End If
            POS1 = POS2 + 1
            IX1 = IX1 + 1
        Loop
        ' 行を加算しレコード内容を表示(先頭は2行目)
        GYO = GYO + 1
        If IX1 >= 1 Then
            Range(Cells(GYO, 1), Cells(GYO, IX1)).Value = x   ' 配列渡し
        End If
    Loop
    ' 指定ファイルをCLOSE
    Close #intFF
    xlAPP.StatusBar = False
    ' 終了の表示
    MsgBox "ファイル読み込みが完了しました。" & vbCr & _
        "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
End Sub


'
'　メインルーチン
'   By Kenji Arai / JH1PJL  Feb. 14th, 2010
'                           Feb. 14th, 2010
'
Sub data_convert()
    Call Create_ADC_data
    Call Create_GPS_data
    Call convert_to_physical_data
End Sub

'
'　ADCデータを分離
'       by Kenji Arai / JH1PJL  Jan. 31st, 2010
'                               Feb. 14th, 2010
'
Sub Create_ADC_data()
    Const cnsTITLE = "ADCデータ変換出力処理"
    Const cnsSH1 = "Sheet1"
    Const cnsSH2 = "Sheet2"
    Dim xlAPP As Application        ' Applicationオブジェクト
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
    Dim GYO_1 As Long
    Dim GYO_2 As Long
    Dim GYOMAX As Long
    Dim Data_time As Long
    Dim Time_ms As Long
    Dim Get_Date As Boolean
    
    Set xlAPP = Application
    Set Ws1 = Worksheets(cnsSH1)
    Set Ws2 = Worksheets(cnsSH2)
    GYOMAX = Ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
    Do While Ws1.Cells(GYOMAX, 1).Value = ""
        GYOMAX = GYOMAX - 1
    Loop
    GYO_1 = 2
    GYO_2 = 2
    Data_time = 0
    Time_ms = 0
    Get_Date = False
    Do Until GYO_1 > GYOMAX
        If (Ws1.Cells(GYO_1, 1).Value = "$ADC") Then
            Ws2.Cells(GYO_2, 2) = Ws1.Cells(GYO_1, 2)
            Ws2.Cells(GYO_2, 3) = Ws1.Cells(GYO_1, 3)
            Ws2.Cells(GYO_2, 4) = Ws1.Cells(GYO_1, 4)
            Ws2.Cells(GYO_2, 5) = Ws1.Cells(GYO_1, 5)
            Ws2.Cells(GYO_2, 6) = Ws1.Cells(GYO_1, 6)
            Ws2.Cells(GYO_2, 7) = Ws1.Cells(GYO_1, 7)
            'Ws2.Range(Ws2.Cells(GYO_2, 2), Ws2.Cells(GYO_2, 7)).Value = _
            '    Ws1.Range(Ws1.Cells(GYO_1, 2), Ws1.Cells(GYO_1, 7)).Value
            Ws2.Cells(GYO_2, 1).Value = Data_time + Time_ms / 10
            Time_ms = Time_ms + 1
            GYO_2 = GYO_2 + 1
        ElseIf (Ws1.Cells(GYO_1, 1).Value = "$GPGGA") Then
            Data_time = Ws1.Cells(GYO_1, 2).Value
            Time_ms = 0
        ElseIf Get_Date = False Then
            If (Ws1.Cells(GYO_1, 1).Value = "$GPRMC") Then
                Ws2.Cells(2, 8).Value = Ws1.Cells(GYO_1, 10).Value
                Get_Date = True
            End If
        End If
        GYO_1 = GYO_1 + 1
        xlAPP.StatusBar = "出力中です．．．．(" & GYO_1 & "レコード目)"
    Loop
    xlAPP.StatusBar = False
    MsgBox "Sheet2へ出力完了" & vbCr & _
    "レコード件数=" & GYO_2 & "件", vbInformation, cnsTITLE
End Sub
'
'　ADCデータを物理量変換
'       by Kenji Arai / JH1PJL  Jan. 31st, 2010
'                               Feb. 14th, 2010
'
Sub convert_to_physical_data()
    Const cnsTITLE = "ADCデータ物理量変換処理"
    Const cnsSH2 = "Sheet2"
    Dim xlAPP As Application        ' Applicationオブジェクト
    Dim Ws2 As Worksheet
    Dim GYO As Long
    Dim GYOMAX As Long

    Set xlAPP = Application
    Set Ws2 = Worksheets(cnsSH2)
    GYOMAX = Ws2.Cells.SpecialCells(xlCellTypeLastCell).Row
    Do While Ws2.Cells(GYOMAX, 1).Value = ""
        GYOMAX = GYOMAX - 1
    Loop
    GYO = 2
    Do Until GYO > GYOMAX
        Ws2.Cells(GYO, 9).Value = Ws2.Cells(GYO, 1).Value
        Ws2.Cells(GYO, 10).Value = _
            ADC_Battery_Volt(Ws2.Cells(GYO, 6).Value, Ws2.Cells(GYO, 7).Value)
        Ws2.Cells(GYO, 11).Value = _
            ADC_Temperature(Ws2.Cells(GYO, 5).Value, Ws2.Cells(GYO, 7).Value)
        Ws2.Cells(GYO, 12).Value = _
            GSEN_total_g(Ws2.Cells(GYO, 2).Value, _
            Ws2.Cells(GYO, 3).Value, Ws2.Cells(GYO, 4).Value)
        GYO = GYO + 1
        xlAPP.StatusBar = "出力中です．．．．(" & GYO & "レコード目)"
    Loop
    xlAPP.StatusBar = False
    MsgBox "Sheet2内、変換完了" & vbCr & _
    "レコード件数=" & GYO & "件", vbInformation, cnsTITLE
End Sub

Private Function ADC_Battery_Volt(adc_VB As Integer, adc_Vref As Integer) As Single
    Dim ad_factor As Single
    
    ad_factor = 774.206 / adc_Vref
    ADC_Battery_Volt = ad_factor * adc_VB * 0.003222656 * 2
End Function

Private Function ADC_Temperature(adc_Temp As Integer, adc_Vref As Integer) As Single
    Dim ad_factor As Single
    
    ad_factor = 774.206 / adc_Vref
    ADC_Temperature = (ad_factor * adc_Temp * 3.222656 - 424) / 6.25
End Function

Private Function GSEN_total_g(gx As Long, gy As Long, gz As Long) As Double
    GSEN_total_g = Sqr(gx * gx + gy * gy + gz * gz) / 100
End Function

'
' GPSデータの分離
'   by Kenji Arai /JH1PJL  Feb. 14th, 2010
'                          Feb. 14th, 2010
'
Sub Create_GPS_data()
    Const cnsTITLE = "GPSデータ出力処理"
    Const cnsSH1 = "Sheet1"
    Const cnsSH3 = "Sheet3"
    Dim xlAPP As Application        ' Applicationオブジェクト
    Dim Ws1 As Worksheet
    Dim Ws3 As Worksheet
    Dim GYO_1 As Long
    Dim GYO_2 As Long
    Dim GYOMAX As Long
    Dim i As Integer
    
    Set xlAPP = Application
    Set Ws1 = Worksheets(cnsSH1)
    Set Ws3 = Worksheets(cnsSH3)
    GYOMAX = Ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
    Do While Ws1.Cells(GYOMAX, 1).Value = ""
        GYOMAX = GYOMAX - 1
    Loop
    GYO_1 = 2
    GYO_2 = 2
    Do Until GYO_1 > GYOMAX
        If (Ws1.Cells(GYO_1, 1).Value <> "$ADC") Then
            For i = 1 To 22
                Ws3.Cells(GYO_2, i) = Ws1.Cells(GYO_1, i)
            Next
            GYO_2 = GYO_2 + 1
        End If
        GYO_1 = GYO_1 + 1
        xlAPP.StatusBar = "出力中です．．．．(" & GYO_1 & "レコード目)"
    Loop
    xlAPP.StatusBar = False
    MsgBox "Sheet3へ出力完了" & vbCr & _
    "レコード件数=" & GYO_2 & "件", vbInformation, cnsTITLE
End Sub

c) GPSデータの抽出（File to File）


'
' データロガーデータのファイル読込と同時にGPSデータのみ書き出し
'   by Kenji Arai /JH1PJL  Feb. 14th, 2010
'                          Feb. 14th, 2010
'
Sub WRITE_TXTFile()
    Const cnsTITLE1 = "テキストファイル読み込み処理"
    Const cnsTITLE2 = "テキストファイル出力処理"
    Const cnsTITLE3 = "テキストファイルフィルタ処理"
    Const cnsFILTER = "TXTファイル (*.txt),*.txt"
    Dim xlAPP As Application
    Dim intFF1 As Integer
    Dim intFF2 As Integer
    Dim strFILENAME1 As String
    Dim strFILENAME2 As String
    Dim lngREC As Long
    Dim strREC As String

    Set xlAPP = Application
    xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
    strFILENAME1 = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
        Title:=cnsTITLE1)
    If StrConv(strFILENAME1, vbUpperCase) = "FALSE" Then Exit Sub
    
    xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
    strFILENAME2 = xlAPP.GetSaveAsFilename(InitialFileName:="SAMPLE.txt", _
        FileFilter:=cnsFILTER, Title:=cnsTITLE2)
    If StrConv(strFILENAME2, vbUpperCase) = "FALSE" Then Exit Sub
    
    intFF1 = FreeFile
    Open strFILENAME1 For Input As #intFF1
    intFF2 = FreeFile
    Open strFILENAME2 For Output As #intFF2
    
    Do Until EOF(intFF1)
        lngREC = lngREC + 1
        xlAPP.StatusBar = "読込み＆書込み中です．．．．(" & lngREC & "レコード目)"
        Line Input #intFF1, strREC
        If Left(strREC, 2) <> "$A" Then
            Print #intFF2, strREC
        End If
    Loop
    Close #intFF1
    Close #intFF2
    xlAPP.StatusBar = False
    MsgBox "ファイル処理完了しました。" & vbCr & _
        "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE3
End Sub

d) ADCデータのグラフ化


'
' ADCデータの描画
'   Reference
'   ---Overall
'   http://d.hatena.ne.jp/language_and_engineering/20090516/p1
'   language_and_engineering-san
'   ---Draw the graph
'   http://brain.cc.kogakuin.ac.jp/~kanamaru/lecture/vba2003/13-applications02.html
'   http://www.officepro.jp/excelvba/chart_edit/index2.html
'
'   by Kenji Arai /JH1PJL  Feb. 7th, 2010
'                          Feb. 16th, 2010
'
Sub Graph_everywhere_ADC()
    Const cnsTITLE = "グラフ描画処理"
    Const cnsSH2 = "Sheet2"
    Const cnsSH4 = "Sheet4"
    Const cnsSH10 = "データロガー分析"
    Dim xlAPP As Application        ' Application Object
    Dim Ws2 As Worksheet
    Dim Ws4 As Worksheet
    Dim Ws10 As Worksheet
    Dim chartObj As ChartObject
    Dim y_offset As Long, x_offset As Long, y_temp As Long
    Dim x_end As Long, y_end As Long
    Dim y_skip As Long, show_length As Long
    Dim item_no As Integer
    Dim GYO_1 As Long
    Dim GYO_2 As Long
    Dim GYOMAX As Long
    Dim series_num As Integer
    Dim series_names As Variant, chart_title As Variant
    Dim x_title As String, y_title As String
    Dim gpos_x As Integer, gpos_y As Integer
    Dim g_width As Integer, g_height As Integer, graph_name As String
    Dim i As Long
    Dim continue_flag As Boolean
    
    ' ---------- Set Condition ----------
    ' Data start position
    y_offset = 2
    x_offset = 12
    ' Number of Y data
    series_num = 1
    ' Name of Graph
    graph_name = "PJL"
    
    ' ---------- Create sheet4 to prepare the data ----------
    ' Active sheet
    Set xlAPP = Application
    Set Ws2 = Worksheets(cnsSH2)
    Set Ws4 = Worksheets(cnsSH4)
    Set Ws10 = Worksheets(cnsSH10)
    
    ' ---------- Delete previous data -----------
    xlAPP.StatusBar = "sheet4へ出力準備中"
    GYOMAX = Ws4.Cells.SpecialCells(xlCellTypeLastCell).Row
    GYO_1 = 2
    Do Until GYO_1 > GYOMAX
        Ws4.Cells(GYO_1, 1).Clear
        Ws4.Cells(GYO_1, 2).Clear
        GYO_1 = GYO_1 + 1
    Loop
    ' If graphs are in the sheet then delete all
    If Ws4.ChartObjects.Count > 0 Then
        For i = 1 To Ws4.ChartObjects.Count
            Ws4.ChartObjects(i).Delete
        Next i
    End If
    ' Name of data / Title of Graph /Name of X-axis and Y
    item_no = Ws10.Cells(18, 12).Value
    If item_no = 1 Then
        series_names = "Vbatt"
        chart_title = "Battery Voltage"
        x_title = "Time"
        y_title = "[V]"
    ElseIf item_no = 2 Then
        series_names = "Temp"
        chart_title = "Temperature"
        x_title = "Time"
        y_title = "[℃]"
    ElseIf item_no = 3 Then
        series_names = "Acc"
        chart_title = "Acceleration"
        x_title = "Time"
        y_title = "[G]"
    End If
    ' data period
    i = Ws10.Cells(19, 12).Value
    If i = 1 Then       ' all data
        y_skip = 1
    ElseIf i = 2 Then   ' every 1sec
        y_skip = 10
    ElseIf i = 3 Then   ' every 10 sec
        y_skip = 100
    ElseIf i = 4 Then   ' every 30sec
        y_skip = 300
    ElseIf i = 5 Then   ' every 1 min
        y_skip = 600
    ElseIf i = 6 Then   ' every 10 min
        y_skip = 6000
    End If
    ' data length
    i = Ws10.Cells(20, 12).Value
    If i = 1 Then       ' 100points
        show_length = 100
    ElseIf i = 2 Then
        show_length = 500
    ElseIf i = 3 Then
        show_length = 1000
    ElseIf i = 4 Then
        show_length = 5000
    ElseIf i = 5 Then
        show_length = 10000
    ElseIf i = 6 Then
        show_length = 30000
    End If
    GYOMAX = Ws2.Cells.SpecialCells(xlCellTypeLastCell).Row
    Do While Ws2.Cells(GYOMAX, 1).Value = ""
        GYOMAX = GYOMAX - 1
    Loop
    If show_length = 30000 Then
        i = GYOMAX / y_skip
        If i > show_length Then
            i = i / show_length + 1
        End If
    End If
    ' Copy sheet2 to sheet4
    GYO_1 = 2
    GYO_2 = 2
    Do Until GYO_1 > GYOMAX
        Ws4.Cells(GYO_2, 1) = Ws2.Cells(GYO_1, 9)   ' time
        Ws4.Cells(GYO_2, 2) = Ws2.Cells(GYO_1, 9 + item_no) 'data
        GYO_1 = GYO_1 + y_skip
        GYO_2 = GYO_2 + 1
        xlAPP.StatusBar = "sheet4へ出力中です．．．．(" & GYO_1 & "レコード目)"
    Loop
    Application.Goto Sheets("Sheet4").Range("A1")
    
    ' ---------- Create Graphs ----------
    ' data offset
    x_offset = 2
    y_offset = 2
    ' Position
    gpos_x = 120
    gpos_y = 20
    ' Size
    g_width = 1000
    g_height = 500
    ' Get data size
    y_temp = y_offset
    continue_flag = True
    i = 0
    Do While continue_flag = True
        ' if data is there then next
        If Len(Ws4.Cells(y_temp, x_offset).Value) > 0 Then
            y_temp = y_temp + 1
            i = i + 1
            If i > show_length Then
                continue_flag = False
            End If
        Else
            continue_flag = False
        End If
    Loop
    y_end = y_temp
    x_end = x_offset + series_num - 1

    Set chartObj = Ws4.ChartObjects.Add(gpos_x, gpos_y, g_width, g_height)
    chartObj.Name = graph_name
    With chartObj.Chart
        ' Set data range
        .SetSourceData Ws4.Range(Ws4.Cells(y_offset, x_offset), _
          Ws4.Cells(y_end, x_end)), xlColumns
        ' Set X-axis range
        .SeriesCollection(1).XValues = Ws4.Range(Ws4.Cells(y_offset, _
          x_offset - 1), Ws4.Cells(y_end, x_offset - 1))
        ' Set options
        .ChartType = xlLine
        .HasTitle = True
        .ChartTitle.Characters.Text = chart_title
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = x_title
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title
        .HasLegend = False
        .SeriesCollection(1).Name = series_names
    End With
    xlAPP.StatusBar = False
    MsgBox "Sheet4へグラフ描画完了" & vbCr & _
    "レコード件数=" & GYO_2 & "件", vbInformation, cnsTITLE
End Sub