VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "FileProvider"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'------------------------------------------------------------------------------------------
'   FileProvider ver. 1.00
'------------------------------------------------------------------------------------------
Option Explicit
Option Compare Text

'---------------------------------------------------------
'*** Declare Function ***
'---------------------------------------------------------
'*** Private Function ***
Private Declare Function NegByteToSingle Lib "DataConv.dll" (B As Byte, s As Single) As Integer
Private Declare Function SingleToNegByte Lib "DataConv.dll" (s As Single, B As Byte) As Integer

Private Declare Function NegByteToDouble Lib "DataConv.dll" (B As Byte, s As Double) As Integer
Private Declare Function DoubleToNegByte Lib "DataConv.dll" (s As Double, B As Byte) As Integer

Private Declare Function NegByteToShort Lib "DataConv.dll" (B As Byte, l As Integer) As Integer
Private Declare Function ShortToNegByte Lib "DataConv.dll" (l As Integer, B As Byte) As Integer

Private Declare Function NegByteToLong Lib "DataConv.dll" (B As Byte, l As Long) As Integer
Private Declare Function LongToNegByte Lib "DataConv.dll" (l As Long, B As Byte) As Integer

'---------------------------------------------------------
'*** Define Structure ***
'---------------------------------------------------------

'---------------------------------------------------------
'*** Const ***
'---------------------------------------------------------

'---------------------------------------------------------
'*** ｲﾝｽﾀﾝｽ ***
'---------------------------------------------------------
'ﾍｯﾀﾞｰｲﾝｽﾀﾝｽ
Public uType As Byte
Public uMajorVer As Byte
Public uMinorVer As Byte
Public uRevision As Byte
Public uSerialID As Long
Public uRobotType As Long
Public uBlockSize As Long
Public uBlockCount As Long

'ﾌﾟﾗｲﾍﾞｰﾄ変数
Private prvOpen As Integer  'ｵｰﾌﾟﾝﾌﾗｸﾞ
Private prvFileName As String   'ﾌｧｲﾙ名（ﾊﾟｽ付）
Private prvFileID As Integer  'ﾌｧｲﾙ#番号

Private prvBuffer() As Byte     'ﾒﾓﾘﾊﾞｯﾌｧ
Private prvBufPnt As Long     'ﾊﾞｯﾌｧｱｸｾｽﾎﾟｲﾝﾀ
Private prvBufSiz As Long     'ﾊﾞｯﾌｧｻｲｽﾞ
'---------------------------------------------------------
'*** ｺｰﾄﾞ ***
'---------------------------------------------------------
'-----------------------------------------------------------------------------
' @(f)
'
' 関数名    : DoOpen
'
' 機能      : ﾌｧｲﾙｵｰﾌﾟﾝ
'
' 返り値    :　-1：ｴﾗｰ
'
' 引き数    : ARG1 -　ﾌｧｲﾙﾊﾟｽ
'             ARG2 - ｵﾌﾟｼｮﾝ =  0:ｵｰﾌﾟﾝ 1:新規作成
'
' 機能説明  :
'
' 備考      :
'-----------------------------------------------------------------------------
Public Function DoOpen(sFileName$, Optional vOption As Variant = False) As Integer
    Dim iFID    As Integer
    
    On Error GoTo ErrJob
    
    If prvFileID > 0 Then
        DoOpen = -1 'エラー
        Exit Function
    End If

    If vOption = False Then 'ｵｰﾌﾟﾝ
        iFID = FreeFile
        'ﾌｧｲﾙｵｰﾌﾟﾝ
        Open sFileName For Binary Access Read Write As #iFID
    
        prvFileID = iFID
        prvFileName = sFileName
        prvOpen = 1 'ｵｰﾌﾟﾝ
        
        
        '------------------------------
        'ﾊﾞｯﾌｧ確保
        '-----------
        prvBufPnt = 0
        prvBufSiz = FileLen(prvFileName)
        ReDim prvBuffer(prvBufSiz - 1)
        
        'ﾌｧｲﾙﾎﾟｲﾝﾀｰを先頭にｾｯﾄ
        Seek #prvFileID, 1
        '読み出し
        Get #prvFileID, , prvBuffer()
        '------------------------------
        
        'ﾃﾞｰﾀ読み出し
        Call DoRead

    Else '新規
        'すでに存在していたら削除する
        If Len(Dir(sFileName)) > 0 Then Kill sFileName
        
        iFID = FreeFile
        'ﾌｧｲﾙ新規作成
        Open sFileName For Binary Access Write As #iFID
    
        prvFileID = iFID
        prvFileName = sFileName
        prvOpen = -1 'ｸﾘｴｲﾄ
        
        '------------------------------
        'ﾊﾞｯﾌｧ確保
        '-----------
        prvBufPnt = 0
        prvBufSiz = 255 + uBlockSize * uBlockCount '(256+uBlockSize * uBlockCount)-1
        ReDim prvBuffer(prvBufSiz)
        '------------------------------
            
        'ﾃﾞｰﾀ書き出し
        Call DoWrite
        
    End If
    
    Exit Function

ErrJob:
    DoOpen = -1 'エラー
    
End Function

Public Function DoClose() As Integer

    'ﾌｧｲﾙｸﾛｰｽﾞ
    If prvFileID > 0 Then
        '------------------------------
        If prvOpen = -1 Then 'ｸﾘｴｲﾄ（書き込み）
            'ﾒﾓﾘｰ->ﾌｧｲﾙへ
            'ﾌｧｲﾙﾎﾟｲﾝﾀｰを先頭にｾｯﾄ
            Seek #prvFileID, 1
            'ﾃﾞｰﾀ書き出し
            Put #prvFileID, , prvBuffer()
        End If
        '------------------------------
        Close #prvFileID
    End If
    
    '------------------------------
    'ﾊﾞｯﾌｧ解放
    '-----------
    prvBufPnt = 0
    prvBufSiz = 0
    ReDim prvBuffer(0)
    '------------------------------

    prvFileID = 0
    prvOpen = 0 'ｸﾛｰｽﾞ
    uBlockCount = 0
    
End Function

Public Property Get filename() As String

    'ｱｸｾｽ中のﾌｧｲﾙ名を返す(Read Only)
    filename = prvFileName
    
End Property

Public Property Get Blocks() As Long

    Blocks = uBlockCount
    
End Property

Public Property Let Blocks(myBlocks As Long)
    
    If myBlocks >= 0 Then uBlockCount = myBlocks

End Property

Public Property Get FileType() As Integer

    FileType = uType
    
End Property

Public Property Let FileType(myType As Integer)

    uType = CByte(myType)
    Select Case uType
        Case 1 'U_VAR_INT
            uBlockSize = 4
        Case 2 'U_VAR_SNG
            uBlockSize = 4
        Case 3 'U_VAR_DBL
            uBlockSize = 8
        Case 4 'U_VAR_VEC
            uBlockSize = 12
        Case 5 'U_VAR_POS
            uBlockSize = 28
        Case 6 'U_VAR_JNT
            uBlockSize = 32
        Case 7 'U_VAR_TRN
            uBlockSize = 40
        Case 8 'U_VAR_STR
            uBlockSize = 248
        Case 9 'U_VAR_TOOL
            uBlockSize = 28
        Case &HA  'U_VAR_WORK
            uBlockSize = 28
        Case &HB  'U_VAR_AREA
            uBlockSize = 52
        Case &H11 'F_LOG_ERROR
            uBlockSize = 216
        Case &H12 'F_LOG_OPERATION
            uBlockSize = 212
        Case &H13 'F_LOG_CONTROL
            uBlockSize = 140
        Case &H14 'F_LOG_IO
            uBlockSize = 14
        Case Else 'CNF
            uBlockSize = 4
    End Select
            
    
End Property

Public Function DoRead() As Integer

    If prvOpen = 0 Then
        DoRead = -1 'エラー
        Exit Function
    End If

    'ﾌｧｲﾙﾎﾟｲﾝﾀｰを先頭にｾｯﾄ
    'Seek #prvFileID, 1
    'ﾍｯﾀﾞｰ部読み出し
    'Get #prvFileID, , uType
    uType = prvBuffer(0)
    'Get #prvFileID, , uMajorVer
    uMajorVer = prvBuffer(1)
    'Get #prvFileID, , uMinorVer
    uMinorVer = prvBuffer(2)
    'Get #prvFileID, , uRevision
    uRevision = prvBuffer(3)
    
    'Get #prvFileID, , uSerialID
    NegByteToLong prvBuffer(4), uSerialID
    'Get #prvFileID, , uRobotType
    NegByteToLong prvBuffer(8), uRobotType
    'Get #prvFileID, , uBlockSize
    NegByteToLong prvBuffer(12), uBlockSize
    'Get #prvFileID, , uBlockCount
    NegByteToLong prvBuffer(16), uBlockCount
        
End Function

Public Function DoWrite() As Integer

    If prvOpen = 0 Then
        DoWrite = -1 'エラー
        Exit Function
    End If

    Dim i       As Integer
    Dim lVal    As Long
    
    'ﾌｧｲﾙﾎﾟｲﾝﾀｰを先頭にｾｯﾄ
    'Seek #prvFileID, 1
    'ﾍｯﾀﾞｰ部書き出し
    'Put #prvFileID, , uType
    prvBuffer(0) = uType
    'Put #prvFileID, , uMajorVer
    prvBuffer(1) = uMajorVer
    'Put #prvFileID, , uMinorVer
    prvBuffer(2) = uMinorVer
    'Put #prvFileID, , uRevision
    prvBuffer(3) = uRevision
    'Put #prvFileID, , uSerialID
    LongToNegByte uSerialID, prvBuffer(4)
    'Put #prvFileID, , uRobotType
    LongToNegByte uRobotType, prvBuffer(8)
    'Put #prvFileID, , uBlockSize
    LongToNegByte uBlockSize, prvBuffer(12)
    'Put #prvFileID, , uBlockCount
    LongToNegByte uBlockCount, prvBuffer(16)
    lVal = 0
    For i = 0 To 58
        'Put #prvFileID, , lVal
        LongToNegByte lVal, prvBuffer(20 + i * 4)
    Next i
        
End Function

'-----------------------------------------------------------------------------
' @(f)
'
' 関数名    : DoGetValue
'
' 機能      :
'
' 返り値    :
'
' 引き数    : ARG1 - ﾃﾞｰﾀｲﾝﾃﾞｯｸｽ
'             ARG2 - 取得ﾃﾞｰﾀ
'             ARG3 - (ｵﾌｾｯﾄ)
'             ARG4 - (文字列ｻｲｽﾞ)　String型の場合でﾌｧｲﾙから取得するﾊﾞｲﾄ数
'
' 機能説明  :
'               ARG3は特殊型のﾃﾞｰﾀにｱｸｾｽする場合に使用する
'
'               例えばT型のT10(x,y,z,ox,oy,oz,ax,ay,az,fig)のT10zを取得する場合
'               Dim sngData as single
'               Call DoGetValue(10,sngData,3)
'
'               例えばI型のI10を取得する場合
'               Dim lData as lnteger
'               Call DoGetValue(10,lData)
'
' 備考      :
'-----------------------------------------------------------------------------
Public Function DoGetValue(ByVal Index As Long, vVal As Variant, Optional ByVal vOfs As Variant = 0, Optional ByVal vSiz As Variant = 1) As Integer
    
    On Error GoTo ErrJob
    
    If prvOpen = 0 Then
        DoGetValue = -1 'エラー
        Exit Function
    End If

    If Index >= uBlockCount Then
        DoGetValue = -2 'エラー
        Exit Function
    End If
    
    Dim i   As Integer
    Dim l   As Long

    Dim iVarType As Integer
    iVarType = VarType(vVal)
    DoGetValue = 0
    Select Case iVarType
        Case vbInteger
            Dim iVal    As Integer
            'Get #prvFileID, 257 + uBlockSize * Index + vOfs, iVal
            NegByteToShort prvBuffer(256 + uBlockSize * Index + vOfs), iVal
            vVal = iVal
        Case vbLong
            Dim lVal    As Long
            'Get #prvFileID, 257 + uBlockSize * Index + vOfs, lVal
            NegByteToLong prvBuffer(256 + uBlockSize * Index + vOfs), lVal
            vVal = lVal
        Case vbSingle
            Dim sngVal    As Single
            'Get #prvFileID, 257 + uBlockSize * Index + vOfs, sngVal
            NegByteToSingle prvBuffer(256 + uBlockSize * Index + vOfs), sngVal
            vVal = sngVal
        Case vbDouble
            Dim dVal    As Double
            'Get #prvFileID, 257 + uBlockSize * Index + vOfs, dVal
            NegByteToDouble prvBuffer(256 + uBlockSize * Index + vOfs), dVal
            vVal = dVal
        Case vbString
            Dim bVal()      As Byte
            Dim stmp        As String
            ReDim bVal(vSiz - 1)
            'Get #prvFileID, 257 + uBlockSize * Index + vOfs, bVal()
            l = 256 + uBlockSize * Index + vOfs
            For i = 0 To vSiz - 1
                bVal(i) = prvBuffer(l)
                l = l + 1
            Next i
            
            ByteToUnicode bVal(), 0, stmp
            vVal = stmp
            
        Case Else
            If vbArray <= iVarType Then '配列
                Select Case (iVarType - vbArray)
                    Case vbInteger
                        Dim iaVal()  As Integer
                        ReDim iaVal(vSiz - 1)
                        'Get #prvFileID, 257 + uBlockSize * Index + vOfs, iaVal()
                        l = 256 + uBlockSize * Index + vOfs
                        For i = 0 To vSiz - 1
                            NegByteToShort prvBuffer(l), iaVal(i)
                            vVal(i) = iaVal(i)
                            l = l + 2
                        Next i
                        
                    Case vbLong
                        Dim laVal()  As Long
                        ReDim laVal(vSiz - 1)
                        'Get #prvFileID, 257 + uBlockSize * Index + vOfs, laVal()
                        l = 256 + uBlockSize * Index + vOfs
                        For i = 0 To vSiz - 1
                            NegByteToLong prvBuffer(l), laVal(i)
                            vVal(i) = laVal(i)
                            l = l + 4
                        Next i
                        
                    Case vbSingle
                        Dim sngaVal()  As Single
                        ReDim sngaVal(vSiz - 1)
                        'Get #prvFileID, 257 + uBlockSize * Index + vOfs, sngaVal()
                        l = 256 + uBlockSize * Index + vOfs
                        For i = 0 To vSiz - 1
                            NegByteToSingle prvBuffer(l), sngaVal(i)
                            vVal(i) = sngaVal(i)
                            l = l + 4
                        Next i
                        
                    Case vbDouble
                        Dim daVal()  As Double
                        ReDim daVal(vSiz - 1)
                        'Get #prvFileID, 257 + uBlockSize * Index + vOfs, daVal()
                        l = 256 + uBlockSize * Index + vOfs
                        For i = 0 To vSiz - 1
                            NegByteToDouble prvBuffer(l), daVal(i)
                            vVal(i) = daVal(i)
                            l = l + 8
                        Next i
                        
                    Case Else
                        DoGetValue = -1 'ｴﾗｰ
                End Select
            Else
                DoGetValue = -1 'ｴﾗｰ
            End If
    End Select
    
    Exit Function
ErrJob:
    DoGetValue = -1 'エラー

End Function

Public Function DoLetValue(ByVal Index As Long, ByVal vVal As Variant, Optional ByVal vOfs As Variant = 0, Optional ByVal vSiz As Variant = 1) As Integer
    
    On Error GoTo ErrJob
    
    If prvOpen = 0 Then
        DoLetValue = -1 'エラー
        Exit Function
    End If

    If Index >= uBlockCount Then
        DoLetValue = -2 'エラー
        Exit Function
    End If

    Dim i   As Integer
    Dim l   As Long

    '256分はﾍｯﾀﾞｰ部,ﾎﾞﾃﾞｨは257から開始する
    Dim iVarType As Integer
    iVarType = VarType(vVal)
    DoLetValue = 0
    Select Case iVarType
        Case vbInteger
            Dim iVal    As Integer
            iVal = vVal
            'Put #prvFileID, 257 + uBlockSize * Index + vOfs, iVal
            ShortToNegByte iVal, prvBuffer(256 + uBlockSize * Index + vOfs)
            
        Case vbLong
            Dim lVal    As Long
            lVal = vVal
            'Put #prvFileID, 257 + uBlockSize * Index + vOfs, lVal
            LongToNegByte lVal, prvBuffer(256 + uBlockSize * Index + vOfs)
        
        Case vbSingle
            Dim sngVal    As Single
            sngVal = vVal
            'Put #prvFileID, 257 + uBlockSize * Index + vOfs, sngVal
            SingleToNegByte sngVal, prvBuffer(256 + uBlockSize * Index + vOfs)

        Case vbDouble
            Dim dVal    As Double
            dVal = vVal
            'Put #prvFileID, 257 + uBlockSize * Index + vOfs, dVal
            DoubleToNegByte dVal, prvBuffer(256 + uBlockSize * Index + vOfs)
        
        Case vbString
            Dim bVal()      As Byte
            Dim stmp        As String
            ReDim bVal(vSiz)
            stmp = vVal
            UnicodeToByte stmp, 0, bVal()
            'Put #prvFileID, 257 + uBlockSize * Index + vOfs, bVal()
            l = 256 + uBlockSize * Index + vOfs
            For i = 0 To vSiz - 1
                prvBuffer(l) = bVal(i)
                l = l + 1
            Next i
            
        Case Else
'            If vbArray <= iVarType Then '配列
'            Else
                DoLetValue = -1 'ｴﾗｰ
    End Select

    Exit Function
ErrJob:
    DoLetValue = -1 'エラー

End Function

Public Function DoDestroy() As Integer
    
    On Error Resume Next
    
    'ﾌｧｲﾙｸﾛｰｽﾞ
    DoClose
    
    'ﾌｧｲﾙ削除
    Kill prvFileName
    
    prvFileName = vbNullString
    
    Err.Clear
    DoDestroy = 0
    Exit Function

ErrJob:
    DoDestroy = -1

End Function

Private Sub Class_Terminate()
    
    'ﾌｧｲﾙｸﾛｰｽﾞ
    If prvFileID > 0 Then Close #prvFileID
    uBlockCount = 0

End Sub

'------------------------------------------------------------------------------------------
' @(f)
'
' 関数名    : ByteToUnicode
'
' 機能      :
'
' 返り値    :
'
' 引き数    : ARG1 -
'             ARG2 -
'             ARG3 -
'
' 機能説明  :
'
' 備考      :
'
Private Function ByteToUnicode(Data() As Byte, ByVal Start%, result$) As Integer

    ReDim bname(256) As Byte
    Dim i                           As Integer
    Dim imax                        As Integer

    imax = UBound(Data)
    For i = 0 To imax
        bname(i) = Data(Start + i)
        If bname(i) = 0 Then Exit For
    Next
    bname(i) = 0
    ByteToUnicode = Start + i       '\0の位置を返す

    result$ = StrConv(bname, vbUnicode)
    i = InStr(result$, Chr$(0))
    If i > 0 Then result$ = Left$(result$, i - 1)

End Function

'------------------------------------------------------------------------------------------
' @(f)
'
' 関数名    : UnicodeToByte
'
' 機能      :
'
' 返り値    :
'
' 引き数    : ARG1 -
'             ARG2 -
'             ARG3 -
'
' 機能説明  :
'
' 備考      :
'
Private Function UnicodeToByte(txt$, ByVal Start%, Data() As Byte) As Integer

    Dim Name    As String   ' ANSI Code
    Dim i       As Integer
    Dim imax    As Integer
    Dim iFin    As Integer

    Name = StrConv(txt$, vbFromUnicode)

    iFin = UBound(Data)
    imax = LenB(Name) - 1
    For i = 0 To iFin
        If i <= imax Then
            Data(Start% + i) = (AscB(MidB$(Name, i + 1, 1))) And &HFF
        Else
            Data(Start% + i) = 0
        End If
    Next
    UnicodeToByte = imax + 1         ' \0の位置を返す

End Function