'*********************************************************************************
Sub FETI_ODV_3()
'*********************************************************************************

'Coded  & Verified  030731 by M.Kashiwai(kashiwai@mua.biglobe.ne.jp)
'           Microsoft Visual Basic 6.0にて作成・動作確認。
'機能；
'   FETI/MIRC フォーマットのA-lineデータ・ファイルを
'   Generic ODV スプレッドシート・フォーマットに変換。
'準備；
    'このコードを拡張子[.bas]のファイルとしてコピーあるいは作成。
    'FETI データ・ファイルをソース・ディレクトリ[E:\FETI\data]に準備。
    'デスティネーション・ディレクトリ[E:\ODV\data\yyyy]を作成。
    '   !!ディレクトリ名が異なる場合はコードの修正が必要!!
    '管理用エクセル・ブックを作成し、マクロを移植；
    '   [ツールバー]→[ツール]→[マクロ]→[Visual Basic Editor]
    '   →[プロジェクト・ウィンドウ]→[(新規管理用ブック)]選択
    '   →[右クリック]→[プルダウン・メニュー]→[ファイルのインポート]
    '   →[FETI_ODV_3.bas]
    '   →[プルダウン・メニュー]（あるいは[ツールバー]→[表示]）
    '   →[コードの表示]
    '   →コード・ウィンドウにVBAコードが表示される。
    '   →確認→[名前を付けて保存]
'実行；
    '   [管理用ブック]→[マクロを有効にして開く]
    '   →[ツールバー]→[ツール]→[マクロ]
    '   →ダイアログボックス[マクロ]→[FETI_ODV_3.bas]選択→[実行]
    'あるいは
    '   [FETI_ODV_3.bas]のコードが表示されている[Visual Basic Editor]
    '   →[実行]→[Sub/ユーザーフォームの実行]
 '動作；プログラムを実行すると;
    '   ダイアログボックス[ファイルを開く]出現；
    '   →[変換するFETIデータ・ファイル]<選択>→<開く>；
    '   ダイアログボックス[このファイルを変換か/ファイルを再選択か]
    '   →<選択>。
    '   新規ブックのシート１にFETIデータを読み込む；
    '   FETIフォーマット・データをODVデータに変換してシート２に書き込む；
    '  シート２をGeneric ODV データ・ファイルとして保存する；
    '   デスティネーション・ディレクトリにファイル名[yymmA##]で保存；
    '                   ここで yymmは観測年月, A##は測点番号。
    '   作成したブックは保存せずに閉じる；
    '   ダイアログボックス[継続か/中止か]→<選択>。
    
On Error GoTo Err_Handler

START:
    Dim H As Integer
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer
    Dim L As Integer: L = 1
    Dim M As Integer: M = 0
    Dim N As Integer: N = 2
        
    OBV_TYPE$ = "C"
    DEPTH_QF = 1
    
SlctFl: 'Selecting working file
    'Application.ScreenUpdating = False
    SRCFL$ = Application.GetOpenFilename(fileFilter:="TextFile (*.*), *.*")
    
    Dim RETMsg As Integer
    RETMsg = MsgBox("?? FETI フォーマット・ファイル: " _
    & Chr(13) & SRCFL$ & Chr(13) & " を ODV データ・ファイルに変換しますか ??", _
    vbYesNo + vbQuestion, "FETI File を ODV File に変換")
        If RETMsg = vbNo Then
            RETMsg = MsgBox("?? ファイルを再選択しますか ?? or ?? 変換をキャンセルしますか ??" & Chr(13) & Chr(13) & _
            "ファイルを再選択: <R>" & Chr(13) & _
            "キャンセル               :<C>", vbRetryCancel + vbQuestion, _
            "FETI File を ODV File に変換")
            If RETMsg = vbRetry Then GoTo SlctFl Else GoTo Finish
        End If
 
    Workbooks.OpenText Filename:=SRCFL$, DataType:=xlDelimited, Tab:=True
    SRCBK$ = ActiveWorkbook.Name
    
    Worksheets.Add After:=Worksheets(1)
    Worksheets(2).Name = "ODV"
    Worksheets(2).Cells(1, 1).Value = "Cruise"
    Worksheets(2).Cells(1, 2).Value = "Station"
    Worksheets(2).Cells(1, 3).Value = "Type"
    Worksheets(2).Cells(1, 4).Value = "mon/day/yr"
    Worksheets(2).Cells(1, 5).Value = "Lon (degE)"
    Worksheets(2).Cells(1, 6).Value = "Lat (degN)"
    Worksheets(2).Cells(1, 7).Value = "Bot. Depth (m)"
    Worksheets(2).Cells(1, 8).Value = "Depth [dBar]"
    Worksheets(2).Cells(1, 9).Value = "QF"
    Worksheets(2).Cells(1, 10).Value = "Temperature [degC]"
    Worksheets(2).Cells(1, 11).Value = "QF"
    Worksheets(2).Cells(1, 12).Value = "Salinity [psu]"
    Worksheets(2).Cells(1, 13).Value = "QF"
    Worksheets(2).Cells(1, 14).Value = "Sigma-t [kg/m^3]"
    Worksheets(2).Cells(1, 15).Value = "QF"
    Worksheets(2).Cells(1, 16).Value = "Potential Temperature [degC]"
    Worksheets(2).Cells(1, 17).Value = "QF"
    Worksheets(2).Cells(1, 18).Value = "Sigma-theta [kg/m^3]"
    Worksheets(2).Cells(1, 19).Value = "QF"

READ_RECORD:
    Do
    M = M + 1
    
    Worksheets(1).Activate
    Worksheets(1).Cells(M, 1).Select
    D$ = ActiveCell.Value
    P$ = Mid$(D$, 1, 2)
    Select Case P$
        Case "HC", "HD": 'HEADER
            'LATITUDE
                If Mid$(D$, 3, 2) <> "" Then
                    DD$ = Mid$(D$, 3, 2)
                    LAT = Val(DD$)
                    If Mid$(D$, 5, 2) <> "" Then
                        MM$ = Mid$(D$, 5, 2)
                        LAT = LAT + Val(MM$) / 60#
                        If Mid$(D$, 7, 2) <> "" Then
                           SS$ = Mid$(D$, 7, 2)
                           LAT = LAT + Val(SS$) / 3600#
                        End If
                    End If
                Else
                    DD$ = "--": MM$ = "--": SS$ = "--"
                End If
                If Mid$(D$, 9, 1) <> "" Then
                    NS$ = Mid$(D$, 9, 1)
                    If NS$ = "S" Then
                    LAT = LAT * (-1#)
                    End If
                Else
                    NS$ = "-"
                End If
                LATITUDE$ = DD$ + "ﾟ " + MM$ + "’" + SS$ + "" + NS$
            'LONGITUDE
                If Mid$(D$, 10, 3) <> "" Then
                    DDD$ = Mid$(D$, 10, 3)
                    Lon = Val(DDD$)
                    If Mid$(D$, 13, 2) <> "" Then
                        MM$ = Mid$(D$, 13, 2)
                        Lon = Lon + Val(MM$) / 60#
                        If Mid$(D$, 15, 2) <> "" Then
                           SS$ = Mid$(D$, 15, 2)
                           Lon = Lon + Val(SS$) / 3600#
                        End If
                    End If
                Else
                    DD$ = "---": MM$ = "--": SS$ = "--"
                End If
                If Mid$(D$, 17, 1) <> "" Then
                    EW$ = Mid$(D$, 17, 1)
                    If EW$ = "W" Then
                    Lon = 360# - Lon
                    End If
                Else
                    EW$ = "-"
                End If
                LONGITUDE$ = DDD$ + "ﾟ " + MM$ + "’" + SS$ + "" + EW$
            'DATE
                If Mid$(D$, 18, 4) <> "" Then YYYY$ = Mid$(D$, 18, 4) Else YYYY$ = "----"
                If Mid$(D$, 22, 2) <> "" Then MM$ = Mid$(D$, 22, 2) Else MM$ = "--"
                If Mid$(D$, 24, 2) <> "" Then DD$ = Mid$(D$, 24, 2) Else DD$ = "--"
                MMDDYYYY$ = MM$ + "/" + DD$ + "/" + YYYY$
                YY$ = Mid$(YYYY$, 3, 2)
            'TIME
'                If Mid$(D$, 26, 2) <> "" Then HH$ = Mid$(D$, 26, 2) Else HH$ = "--"
'                If Mid$(D$, 28, 2) <> "" Then MM$ = Mid$(D$, 28, 2) Else MM$ = "--"
'                If Mid$(D$, 30, 2) <> "" Then SS$ = Mid$(D$, 30, 2) Else SS$ = "--"
'                HHMMSS$ = HH$ + ":" + MM$ + ":" + SS$
            'CALL_SIGN:  'Tankai-maru="7LAY"    :'Hokko-maru="8LRY
                 If Mid$(D$, 39, 7) <> "" Then
                    CALL_SIGN$ = Mid$(D$, 39, 7)
                Else
                    CALL_SIGN$ = "-------"
                End If
                Select Case CALL_SIGN$
                    Case "   7LAY"
                        SHIP$ = "TK"
                    Case "   8LRY"
                        SHIP$ = "HK"
                End Select
            'PROJECT_CODE
                If Mid$(D$, 49, 4) <> "" Then
                    PROJECT_CODE$ = Mid$(D$, 49, 4)
                Else
                    PROJECT_CODE$ = "----"
                End If
                STATION$ = Mid$(PROJECT_CODE$, 3, 2)
                
            CRUISE$ = SHIP$ + YY$ + MM$
                
        Case "CC", "CD": 'COMMENT
        
        Case "DC", "DD", "DE": 'DATA
        Q$ = Mid$(D$, 3, 2)
            Select Case Q$
            Case "01": 'TEMPERATURE
            H = 0
            I = Val(Mid$(D$, 20, 1))
            J = Val(Mid$(D$, 21, 1))
            K = 22
            Do
                Depth$ = Mid$(D$, K, 6)
                Pressure = Val(Depth$) / 10
                K = K + 6
                DT$ = Mid$(D$, K, I)
                    If P$ = "DD" And DT$ = "" Then Exit Do
                K = K + I
                QC_FLAG$ = Mid$(D$, K, 1)
                K = K + 1
                MN_FLAG$ = Mid$(D$, K, 1)
                TEMP = Val(DT$) / 10 ^ J
                    QF = QC(QC_FLAG$, MN_FLAG$)
                Select Case STATION$
                    Case "01": BOT_DEPTH = 95
                    Case "02": BOT_DEPTH = 540
                    Case "03": BOT_DEPTH = 1780
                    Case "04": BOT_DEPTH = 2980
                    Case "05": BOT_DEPTH = 4000
                    Case "06": BOT_DEPTH = 5280
                    Case "07": BOT_DEPTH = 6960
                    Case "08": BOT_DEPTH = 6320
                    Case "09": BOT_DEPTH = 5580
                    Case "10": BOT_DEPTH = 5280
                    Case "11": BOT_DEPTH = 5160
                    Case "12": BOT_DEPTH = 5150
                    Case "13": BOT_DEPTH = 5160
                    Case "14": BOT_DEPTH = 5170
                    Case "15": BOT_DEPTH = 5180
                    Case "16": BOT_DEPTH = 5220
                    Case "17": BOT_DEPTH = 5210
                End Select
                Worksheets(2).Activate
                Worksheets(2).Cells(N, 1).Value = CRUISE$
                Worksheets(2).Cells(N, 2).Value = STATION$
                Worksheets(2).Cells(N, 3).Value = OBV_TYPE$
                Worksheets(2).Cells(N, 4).Value = MMDDYYYY$
                Worksheets(2).Cells(N, 5).Value = Lon
                Worksheets(2).Cells(N, 6).Value = LAT
                Worksheets(2).Cells(N, 7).Value = BOT_DEPTH
                Worksheets(2).Cells(N, 8).Value = Pressure
                Worksheets(2).Cells(N, 9).Value = DEPTH_QF
                Worksheets(2).Cells(N, 10).Value = TEMP
                Worksheets(2).Cells(N, 11).Value = QF
                N = N + 1
                K = K + 1
                H = H + 1
            Loop Until H = 6
            If P$ = "DD" Then N = 2
            
            Case "06": 'CONDUCTIVITY
            If P$ = "DD" Then N = 2
            
            Case "02": 'SALINITY
            H = 0
            I = Val(Mid$(D$, 20, 1))
            J = Val(Mid$(D$, 21, 1))
            K = 28
            Do
                DT$ = Mid$(D$, K, I)
                     If P$ = "DD" And DT$ = "" Then Exit Do
                K = K + I
                QC_FLAG$ = Mid$(D$, K, 1)
                K = K + 1
                MN_FLAG$ = Mid$(D$, K, 1)
                DT = Val(DT$) / 10 ^ J
                QF = QC(QC_FLAG$, MN_FLAG$)
                Worksheets(2).Cells(N, 12).Value = DT
                Worksheets(2).Cells(N, 13).Value = QF
                N = N + 1
                K = K + 1 + 6
                H = H + 1
            Loop Until H = 6
            If P$ = "DD" Then N = 2
            
            Case "21": 'SIGMA_T
            H = 0
            I = Val(Mid$(D$, 20, 1))
            J = Val(Mid$(D$, 21, 1))
            K = 28
            Do
                DT$ = Mid$(D$, K, I)
                    If P$ = "DD" And DT$ = "" Then Exit Do
                K = K + I
                QC_FLAG$ = Mid$(D$, K, 1)
                K = K + 1
                MN_FLAG$ = Mid$(D$, K, 1)
                DT = Val(DT$) / 10 ^ J
                QF = QC(QC_FLAG$, MN_FLAG$)
                Worksheets(2).Cells(N, 14).Value = DT
                Worksheets(2).Cells(N, 15).Value = QF
                N = N + 1
                K = K + 1 + 6
                H = H + 1
            Loop Until H = 6
            If P$ = "DD" Then N = 2
            
            Case "26": 'POTENTIAL_TEMPERATURE
            H = 0
            I = Val(Mid$(D$, 20, 1))
            J = Val(Mid$(D$, 21, 1))
            K = 28
            Do
                DT$ = Mid$(D$, K, I)
                    If P$ = "DD" And DT$ = "" Then Exit Do
                K = K + I
                 QC_FLAG$ = Mid$(D$, K, 1)
                K = K + 1
                MN_FLAG$ = Mid$(D$, K, 1)
                DT = Val(DT$) / 10 ^ J
                QF = QC(QC_FLAG$, MN_FLAG$)
                Worksheets(2).Cells(N, 16).Value = DT
                Worksheets(2).Cells(N, 17).Value = QF
                N = N + 1
                K = K + 1 + 6
                H = H + 1
            Loop Until H = 6
            If P$ = "DD" Then N = 2
            
            Case "27": 'SIGMA_THETA
            H = 0
            I = Val(Mid$(D$, 20, 1))
            J = Val(Mid$(D$, 21, 1))
            K = 28
            Do
                DT$ = Mid$(D$, K, I)
                    If P$ = "DE" And DT$ = "" Then Exit Do
                K = K + I
                QC_FLAG$ = Mid$(D$, K, 1)
                K = K + 1
                MN_FLAG$ = Mid$(D$, K, 1)
                DT = Val(DT$) / 10 ^ J
                QF = QC(QC_FLAG$, MN_FLAG$)
                Worksheets(2).Cells(N, 18).Value = DT
                Worksheets(2).Cells(N, 19).Value = QF
               N = N + 1
                K = K + 1 + 6
                H = H + 1
            Loop Until H = 6
            
            End Select
        
        End Select
    
    Loop Until P$ = "DE"
        
'Formatting Sheet2
    Sheets(2).Select
    Columns("A:A").ColumnWidth = 6
    Columns("B:B").ColumnWidth = 12
    Selection.NumberFormatLocal = "0.000000_ "
    Columns("C:C").ColumnWidth = 12
    Selection.NumberFormatLocal = "0.0000_ "
    Columns("D:D").ColumnWidth = 12
    Selection.NumberFormatLocal = "0.0000_ "
    Columns("E:E").ColumnWidth = 12
    Selection.NumberFormatLocal = "0.0000_ "
    Columns("F:F").ColumnWidth = 12
    Selection.NumberFormatLocal = "0.0000_ "
    Columns("G:G").ColumnWidth = 12
    Selection.NumberFormatLocal = "0.0000_ "

    'Name & Save File
    DSTBK1$ = Mid$(SRCFL$, 16, 4) + SRCBK$
    DstDir$ = "E:\ODV\data\" + YYYY$ + "\"
    DSTBK$ = DstDir$ + DSTBK1$
    Worksheets(2).SaveAs Filename:=DSTBK$
    ActiveWorkbook.Close SaveChanges:=False
    
    RETMsg = MsgBox("?? ファイル変換を続けますか ??" & Chr(13) & Chr(13) & _
    "変換作業を継続:<はい(Y)>" & Chr(13) & "　　　　　　　      :<いいえ(N)>", _
     vbYesNo + vbQuestion, "FETI File を ODV File に変換")
        If RETMsg = vbYes Then
            GoTo START
        Else: GoTo Finish
        End If

Err_Handler:
    Const Title = "エラー"
    MsgBox "エラーです!" & Chr(13) & Chr(13) & _
        "エラー番号 　　　 = " & Err.Number & Chr(13) & _
        "エラー・メッセージ= " & Err.Description, , Title

Finish:
End Sub
Function QC(A$, B$)
'       ODV Quality Flag
'               0 : good
'               1 : unknown
'               4 : questionalble
'               8 : bad
    Select Case A$: 'FETI Data Quality Control Flag
        Case " ": 'no flag
            QC = 1
        Case "0": 'accepted data
            QC = 1
        Case "1": 'range outlier (outside of range check)
            QC = 8
        Case "2": 'failed inversion check
            QC = 4
        Case "3": 'failed gradient check
            QC = 4
        Case "4": 'zero anomaly
            QC = 4
        Case "5": 'failed combined gradient and inversion checks
             QC = 4
       Case "6": 'failed range and inversion checks
            QC = 8
        Case "7": 'failed range and gradient checks
            QC = 8
        Case "8": 'failed range and zero anomaly checks
             QC = 8
       Case "9": 'failed range and combined gradient and inversion checks
            QC = 8
    End Select
    
    Select Case B$: 'FETI Data Management Flag
        Case " "
            QC = 1
        Case "0": 'accepted value by data originator
            QC = 1
        Case "1": 'accepted depth after modification by MIRC/JODC
            QC = 1
        Case "2": 'acepted value after modification by MIRC/JODC
            QC = 1
        Case "3": 'accepted depth and value after modification by MIRC/JODC
            QC = 1
        Case "4": 'error in recorded depth: same or less than previous depth
            QC = 4
        Case "5": 'failed depth check: exceed 20% of water depth
            QC = 8
        Case "6": 'density inversion (for temperature and salinity)
            QC = 4
        Case "A": 'accepted value by data originator, and error in recorded depth
             QC = 4
       Case "B": 'accepted value by data originator, and failed depth check
             QC = 4
       Case "C": 'accepted value by data originator, density inversion
            QC = 4
    End Select
    If QC = "" Or QC = " " Then QC = 1
End Function
'*********************************************************************************