VERSION 5.00
Begin VB.Form frmTrans 
   BorderStyle     =   1  '固定(実線)
   Caption         =   "Trans"
   ClientHeight    =   3900
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7290
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3900
   ScaleWidth      =   7290
   StartUpPosition =   3  'Windows の既定値
   Begin VB.Frame Frame2 
      Caption         =   "Trans Operation"
      Height          =   2745
      Left            =   120
      TabIndex        =   5
      Top             =   1050
      Width           =   7065
      Begin VB.ListBox lstTrans 
         Height          =   2160
         ItemData        =   "Trans.frx":0000
         Left            =   180
         List            =   "Trans.frx":0002
         Style           =   1  'ﾁｪｯｸﾎﾞｯｸｽ
         TabIndex        =   9
         Top             =   330
         Width           =   5025
      End
      Begin VB.CommandButton cmdSelectAll 
         Caption         =   "&Select All"
         Height          =   375
         Left            =   5310
         TabIndex        =   8
         Top             =   1290
         Width           =   1635
      End
      Begin VB.CommandButton cmdGet 
         Caption         =   "&Get"
         Height          =   375
         Left            =   5310
         TabIndex        =   7
         Top             =   330
         Width           =   1635
      End
      Begin VB.CommandButton cmdPut 
         Caption         =   "&Put"
         Height          =   375
         Left            =   5310
         TabIndex        =   6
         Top             =   810
         Width           =   1635
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "Connection"
      Height          =   855
      Left            =   90
      TabIndex        =   0
      Top             =   90
      Width           =   7095
      Begin VB.ComboBox cmbParameter 
         Height          =   300
         Left            =   1320
         TabIndex        =   3
         Top             =   360
         Width           =   3015
      End
      Begin VB.CommandButton cmdDisconnect 
         Caption         =   "&Disconnect"
         Height          =   375
         Left            =   5760
         TabIndex        =   2
         Top             =   300
         Width           =   1215
      End
      Begin VB.CommandButton cmdConnect 
         Caption         =   "&Connect"
         Height          =   375
         Left            =   4440
         TabIndex        =   1
         Top             =   300
         Width           =   1215
      End
      Begin VB.Label Label2 
         Alignment       =   1  '右揃え
         Caption         =   "Parameter : "
         Height          =   255
         Left            =   240
         TabIndex        =   4
         Top             =   360
         Width           =   975
      End
   End
End
Attribute VB_Name = "frmTrans"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Compare Text

Public Enum TRANSTYPE
    ePACCNF = 0
    ePACFILE = 1
    eVariable = 2
    eDIO = 3
    eARM = 4
End Enum

Public caoEng As New CaoEngine
Public caoCtrl As CaoController
Public caoCtrls As CaoControllers

Private sPath$
Private sConn$

Private Sub Form_Load()
    
    With cmbParameter
        .Clear
        .AddItem "eth:192.168.0.1" ' <- Change this for your controller IP setting. "eth:<controller IP>:4112
        .AddItem "com:1:38400:N:8:1" ' <- Change this for your controller RS-232C setting. "com:<COM port no.>:<speed>:N:8:1"
        .ListIndex = 0
    
        sPath$ = App.path + "\Data"
        sConn = .List(.ListIndex)
    End With
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    cmdDisconnect_Click

End Sub


' ----------------------------------------------------
Private Sub cmdConnect_Click()

    Dim sConn As String
        
    sConn = "Conn=" & cmbParameter.Text & ",timeout=3000"
    
    If (ConnectController(sConn)) Then
        With lstTrans
            .Clear
            .AddItem "PAC-CNF": .ItemData(.NewIndex) = ePACCNF: .Selected(.NewIndex) = True
            .AddItem "PAC-Files": .ItemData(.NewIndex) = ePACFILE: .Selected(.NewIndex) = True
            .AddItem "Variable": .ItemData(.NewIndex) = eVariable: .Selected(.NewIndex) = True
            .AddItem "DIO": .ItemData(.NewIndex) = eDIO: .Selected(.NewIndex) = True
            .AddItem "Arm": .ItemData(.NewIndex) = eARM: .Selected(.NewIndex) = True
        End With
    Else
        cmdDisconnect_Click
    End If

End Sub

' ----------------------------------------------------
' sConnParam$ : Connection string (ORIN2 Conn=<sConnParam>)
'
Public Function ConnectController(sConnParam$) As Boolean

    On Error GoTo DoErr

    ConnectController = False

    Set caoCtrls = caoEng.Workspaces(0).Controllers
    Set caoCtrl = caoCtrls.Add("", "CaoProv.DENSO.NetwoRC", "", sConnParam)

    ConnectController = True

    Exit Function
DoExit:
    If Not caoCtrl Is Nothing Then
        caoCtrls.Remove caoCtrl.Index
        Set caoCtrl = Nothing
    End If
    Set caoCtrls = Nothing
    Exit Function
    
DoErr:
    MsgBox Err.Description, vbCritical
    GoTo DoExit
    
End Function


' ----------------------------------------------------
Private Sub cmdDisconnect_Click()
    
    If Not caoCtrl Is Nothing Then
        caoCtrls.Remove caoCtrl.Index
        Set caoCtrl = Nothing
    End If

    Set caoCtrls = Nothing
    Set caoEng = Nothing

    lstTrans.Clear

End Sub


' ----------------------------------------------------
Private Sub cmdSelectAll_Click()
    
    Dim i As Integer
    
    If (lstTrans.ListCount < 1) Then Exit Sub
    
    With lstTrans
        For i = 0 To .ListCount - 1
            .Selected(i) = True
        Next i
    End With

End Sub



' =========================
' ======== Receive ========
' =========================

' ----------------------------------------------------
Private Sub cmdGet_Click()
    
    On Error GoTo ErrGet

    Dim i As Integer
    Dim lMousePt As Long
    
    If (lstTrans.ListCount < 1) Then Exit Sub
    
    lMousePt = Me.MousePointer
    Me.MousePointer = vbHourglass
    
    ' 一旦保存用フォルダの削除
    KillFolder sPath
    MakePathAux sPath

    With lstTrans
        For i = 0 To .ListCount - 1
            If (.Selected(i)) Then
                If Not (Receive(.ItemData(i), sPath$)) Then     ' Receive
                    GoTo ErrGet
                End If
            End If
        Next i
    End With
    
PostProc:
    Me.MousePointer = lMousePt
    Exit Sub
    
ErrGet:
    MsgBox "Get Failure", vbExclamation
    GoTo PostProc
    
End Sub


' ----------------------------------------------------
Public Function Receive(iType As TRANSTYPE, sPath$) As Boolean

    Receive = False

    Select Case iType
    Case ePACCNF
    
        '--------------------
        'PAC-CNF
        '--------------------
        '1. PACCnf
        Receive = GetFile(sPath, "@CNF_PAC")
        If Not (Receive) Then Exit Function
        
        '2. ITPCnf
        Receive = GetFile(sPath, "@CNF_ITP")
        If Not (Receive) Then Exit Function
        
    Case ePACFILE
    
        '--------------------
        'PAC-Files
        '--------------------
        '1. PAC files
        Dim sPrevPath$
        sPrevPath = sPath
        sPath = sPrevPath & "\PAC"
        Receive = ReceivePac(sPath)
        sPath = sPrevPath

    Case eVariable

        '--------------------
        'VAR
        '--------------------
        'All variables
        Receive = GetFile(sPath, "@VAR_INT")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_SNG")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_DBL")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_VEC")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_POS")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_JNT")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_TRN")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_STR")
        'TOOL,WORK,AREA
        Receive = GetFile(sPath, "@VAR_TOOL")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_WORK")
        If Not (Receive) Then Exit Function
        Receive = GetFile(sPath, "@VAR_AREA")

    Case eDIO

        '--------------------
        'DIO
        '--------------------
        '1. DIOCnf
        Receive = GetFile(sPath, "@CNF_DIO")
    
    Case eARM
    
        '--------------------
        'ARM
        '--------------------
        '1. SRVCnf
        Receive = GetFile(sPath, "@CNF_SRV")
        If Not (Receive) Then Exit Function
        '2. ARMCnf
        Receive = GetFile(sPath, "@CNF_ARM")
        If Not (Receive) Then Exit Function
        '3. SPDCnf
        Receive = GetFile(sPath, "@CNF_SPD")
    
    End Select

End Function

' ----------------------------------------------------
Private Function ReceivePac(sPath$) As Boolean
    
    On Error GoTo ErrSkip
    
    Dim l As Long
    Dim names As Variant

    ReceivePac = False

    KillFolder sPath
    MakePathAux sPath

    '1. map,nic,pac,h
    names = caoCtrl.FileNames
    For l = LBound(names) To UBound(names)
        If (names(l) Like "*.pac") Or (names(l) Like "*.h") Or _
            (names(l) Like "*.nic") Or (names(l) Like "*.map") Or _
            (names(l) Like "*.pnl") Or (names(l) Like "*.exe") Then
            ReceivePac = GetFile(sPath, names(l))
            If Not (ReceivePac) Then
                Exit For
            End If
        End If
    Next l

ErrSkip:

End Function

' ----------------------------------------------------
Public Function GetFile(path$, ByVal filename$) As Boolean

    GetFile = False
    Dim lErrRaised As Long
    lErrRaised = 0
    
    Dim bAdded As Boolean
    bAdded = False
    
    On Error GoTo ErrSkip

    Dim caoFl  As CaoFile
    Set caoFl = caoCtrl.AddFile(filename)
    bAdded = True
    
    Dim vntData As Variant
    Dim bytData() As Byte
    Dim strData As String

    If Not caoFl Is Nothing Then
        vntData = caoFl.Value
        
        Select Case VarType(vntData)
        Case vbString
            strData = vntData
            SaveToTextFile path + "\" + filename, strData
        Case vbArray + vbByte
            bytData = vntData
            SaveToBinFile path + "\" + filename, bytData
        End Select
    End If

    GetFile = True
    
DoExit:
    If bAdded = True Then
        caoCtrl.Files.Remove caoFl.Index
        bAdded = False
    End If
    
    Set caoFl = Nothing
    
    If lErrRaised <> 0 Then
        Err.Raise lErrRaised
    End If

    Exit Function
ErrSkip:
    lErrRaised = Err.Number
    MsgBox filename & " : " & Err.Description
    Err.Clear
    GoTo DoExit

End Function



' =========================
' ======== Send ===========
' =========================

' ----------------------------------------------------
Private Sub cmdPut_Click()
    
    On Error GoTo ErrPut
    
    Dim i As Integer
    Dim lMousePt As Long
                
    If (lstTrans.ListCount < 1) Then Exit Sub
    
    lMousePt = Me.MousePointer
    Me.MousePointer = vbHourglass
    
    With lstTrans
        For i = 0 To .ListCount - 1
            If (.Selected(i)) Then
                If Not (Send(.ItemData(i), sPath$)) Then   ' Send
                    GoTo ErrPut
                End If
            End If
        Next i
    
        ' Save all
        Call caoCtrl.Execute("saveFile")
    
    End With

PostProc:
    Me.MousePointer = lMousePt
    Exit Sub
    
ErrPut:
    MsgBox "Put Failure", vbExclamation
    GoTo PostProc

End Sub


' ----------------------------------------------------
Public Function Send(iType As TRANSTYPE, sPath$) As Boolean

    Send = False

    Select Case iType
    Case ePACCNF

        '--------------------
        'PAC-CNF
        '--------------------
        '1. PACCnf
        Send = PutFile(sPath, "@CNF_PAC", True)
        If Not (Send) Then Exit Function

        '2. ITPCnf
        Send = PutFile(sPath, "@CNF_ITP", True)
        If Not (Send) Then Exit Function
    
    Case ePACFILE

        '--------------------
        'PAC-Files
        '--------------------
        '1. PAC files
        Dim sPrevPath$
        sPrevPath = sPath
        sPath = CheckPath(sPrevPath) & "PAC"
        Send = SendPac(caoCtrl, sPath)
        sPath = sPrevPath

    Case eVariable

        '--------------------
        'VAR
        '--------------------
        Send = PutFile(sPath, "@VAR_INT", True)
        If Not (Send) Then Exit Function

        Send = PutFile(sPath, "@VAR_SNG", True)
        If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_DBL", True)
        If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_VEC", True)
        If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_POS", True)
        If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_JNT", True)
        If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_TRN", True)
         If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_STR", True)
        If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_TOOL", True)
        If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_WORK", True)
         If Not (Send) Then Exit Function
        
        Send = PutFile(sPath, "@VAR_AREA", True)

    Case eDIO

        '--------------------
        'DIO
        '--------------------
        '1. DIOCnf
        Send = PutFile(sPath, "@CNF_DIO", True)
    
    Case eARM
    
        '--------------------
        'ARM
        '--------------------
        '1. SRVCnf
        Send = PutFile(sPath, "@CNF_SRV", True)
        If Not (Send) Then Exit Function

        '2. ARMCnf
        Send = PutFile(sPath, "@CNF_ARM", True)
        If Not (Send) Then Exit Function
        
        '=====================================================
        ' TODO: ロボット固有のデータは現在扱っていいない！！
        '・J1の各パラメータを送信
        'CALSET値
        '[E73]
        'エンコーダ基準位置
        'エンコーダ基準パルス
        '基準位置許容偏差
        '・J2 〜 J8 も同様
        '=====================================================
        
        '3. SPDCnf
        Send = PutFile(sPath, "@CNF_SPD", True)

    End Select

End Function

' ----------------------------------------------------
Private Function SendPac(caoCtrl As CaoController, sPath$) As Boolean
    
    On Error GoTo ErrSkip
    
    Dim sname As String
    Dim bBin As Boolean

    '1. map,nic,pac,h
    
    Call caoCtrl.Execute("StartFileUpload")
            
    sname = Dir(sPath + "\*.*", vbNormal)
    Do While sname <> ""
        If sname <> "." And sname <> ".." Then
            If (sname Like "*.nic") Or (sname Like "*.exe") Then
                bBin = True
            Else
                bBin = False
            End If
            SendPac = PutFile(sPath, sname, bBin)
            If Not (SendPac) Then Exit Function
        End If
        sname = Dir
    Loop
    
    Call caoCtrl.Execute("StopFileUpload")
    
    '2. Notification of parameter was modified . = 4 - 1 - 1
    Call caoCtrl.Execute("letStatus", Array(4, 1, 1))

    '3. Load NIC exec. program (NIC)
    Call caoCtrl.Execute("loadNIC", LVar(1))

    Exit Function
ErrSkip:
    SendPac = False

End Function

' ----------------------------------------------------
Public Function PutFile(path$, ByVal filename$, bBin As Boolean) As Boolean

    PutFile = False
    Dim lErrRaised As Long
    lErrRaised = 0

    Dim bAdded As Boolean
    bAdded = False
    
    On Error GoTo ErrSkip

    Dim caoFl  As CaoFile
    Set caoFl = caoCtrl.AddFile(filename, "@Create=1") '1:Create new file
    bAdded = True

    Dim strData As String
    Dim bytData() As Byte

    If Not caoFl Is Nothing Then
        If bBin Then ' Binary file
            LoadFromBinFile CheckPath(path) + filename, bytData
            caoFl.Value = bytData
        Else
            LoadFromTextFile CheckPath(path) + filename, strData
            caoFl.Value = strData
        End If
    End If

    PutFile = True

DoExit:
    If bAdded = True Then
        caoCtrl.Files.Remove caoFl.Index
        bAdded = False
    End If
    
    Set caoFl = Nothing

    If lErrRaised <> 0 Then
        Err.Raise lErrRaised
    End If

    Exit Function
ErrSkip:
    lErrRaised = Err.Number
    MsgBox filename & " : " & Err.Description
    Err.Clear
    GoTo DoExit

End Function

' =========================
' ====== File operation ===
' =========================

' ----------------------------------------------------
Public Sub LoadFromTextFile(fn As String, buf As String)

    Dim fd As Integer

    fd = FreeFile
    Open fn For Input As fd
        buf = StrConv(InputB(LOF(fd), #fd), vbUnicode)
    Close fd

End Sub

' ----------------------------------------------------
Public Sub SaveToTextFile(fn As String, buf As String)

    Dim fd As Integer

    fd = FreeFile
    Open fn For Output As fd
        Print #fd, buf;
    Close fd

End Sub

' ----------------------------------------------------
Public Sub LoadFromBinFile(fn As String, bytData() As Byte)

    Dim fd As Integer
    Dim fl As Long

    fd = FreeFile
    fl = FileLen(fn)
    ReDim bytData(0 To fl - 1)
    Open fn For Binary Access Read As fd
        Get #fd, , bytData
    Close fd

End Sub

' ----------------------------------------------------
Public Sub SaveToBinFile(fn As String, bytData() As Byte)

    Dim fd As Integer

    fd = FreeFile
    Open fn For Binary Access Write As fd
        Put #fd, , bytData
    Close fd

End Sub

' ----------------------------------------------------
Public Function MakePathAux(strDirName As String) As Boolean

    On Error Resume Next
    
    Dim strPath         As String
    Dim intOffset       As Integer
    Dim intAnchor       As Integer
    Dim strOldPath      As String

    strDirName = CheckPath(strDirName)

    strOldPath = CurDir$
    MakePathAux = False
    intAnchor = 0

    intOffset = InStr(intAnchor + 1, strDirName, "\")
    intAnchor = intOffset
    Do
        intOffset = InStr(intAnchor + 1, strDirName, "\")
        intAnchor = intOffset

        If intAnchor > 0 Then
            strPath = Left$(strDirName, intOffset - 1)
            Err = 0
            ChDir strPath
            If Err Then
                Err = 0
                MkDir strPath
                If Err Then GoTo Done
            End If
        End If
    Loop Until intAnchor = 0

    MakePathAux = True
Done:
    ChDir strOldPath
    Err = 0

End Function

' ----------------------------------------------------
Public Sub KillFolder(MyFolder$)

    On Error Resume Next

    Dim MyName As String
    MyName = Dir(MyFolder$, vbDirectory)
    Do While MyName <> vbNullString
         If MyName <> "." And MyName <> ".." Then
            SetAttr MyFolder$ & MyName, vbNormal
        End If
        MyName = Dir
    Loop

    Kill MyFolder$ & "\*.*"
    RmDir MyFolder$

End Sub

' ----------------------------------------------------
Private Function CheckPath(sPath$) As String

    If (Right$(sPath, 1) <> "\") Then
        CheckPath = sPath & "\"
    Else
        CheckPath = sPath
    End If

End Function

'-----------------------------------------------------------
Public Function LLng(ByRef expression) As Long
    
    LLng = CLng(Val(expression))

End Function

'-----------------------------------------------------------------------------
Public Function LInt(ByRef expression) As Integer
    
    LInt = CInt(Val(expression))

End Function

'-----------------------------------------------------------------------------
Public Function LByte(ByRef expression) As Byte
    
    LByte = CByte(Val(expression))

End Function

'-----------------------------------------------------------------------------
Public Function LDbl(ByRef expression) As Double
    
    LDbl = CDbl(Val(expression))

End Function

'-----------------------------------------------------------------------------
Public Function LSng(ByRef expression) As Single
    
    LSng = CSng(Val(expression))

End Function

'-----------------------------------------------------------------------------
Public Function LBool(ByRef expression) As Boolean
    
    LBool = CBool(Val(expression))

End Function

'-----------------------------------------------------------------------------
Public Function LVar(ByRef expression) As Variant
    
    LVar = CVar(Val(expression))

End Function

'-----------------------------------------------------------
Public Function LStr(ByRef expression) As String
    
    On Error Resume Next
    
    LStr = expression
    LStr = LTrim$(Str(expression))

End Function