VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "ZTreeWin Script Host ZAAP"
   ClientHeight    =   7095
   ClientLeft      =   2445
   ClientTop       =   2160
   ClientWidth     =   10860
   BeginProperty Font 
      Name            =   "Microsoft Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "Main.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   7095
   ScaleWidth      =   10860
   Begin VB.Timer tmrReadZBar 
      Interval        =   125
      Left            =   240
      Top             =   240
   End
   Begin MSComctlLib.TabStrip tsScript 
      Height          =   375
      Left            =   2760
      TabIndex        =   2
      Top             =   120
      Width           =   7935
      _ExtentX        =   13996
      _ExtentY        =   661
      _Version        =   393216
      BeginProperty Tabs {1EFB6598-857C-11D1-B16A-00C0F0283628} 
         NumTabs         =   2
         BeginProperty Tab1 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "Console"
            Key             =   "Console"
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab2 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "Code"
            Key             =   "Code"
            ImageVarType    =   2
         EndProperty
      EndProperty
   End
   Begin VB.ListBox lstScripts 
      Height          =   2985
      Left            =   120
      TabIndex        =   1
      Top             =   720
      Width           =   2535
   End
   Begin VB.TextBox txtConsole 
      BeginProperty Font 
         Name            =   "Courier New"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3255
      Left            =   2760
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   3
      Top             =   480
      Width           =   7935
   End
   Begin VB.CommandButton cmdPause 
      Caption         =   "&Pause"
      Height          =   495
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   2535
   End
   Begin VB.Frame fraStatus 
      Caption         =   "Status"
      Height          =   3135
      Left            =   120
      TabIndex        =   4
      Top             =   3840
      Width           =   10575
      Begin VB.ListBox lstLog 
         Height          =   2595
         Left            =   5520
         OLEDragMode     =   1  'Automatic
         TabIndex        =   6
         Top             =   240
         Width           =   4935
      End
      Begin MSComctlLib.ListView lvwCurrent 
         Height          =   2775
         Left            =   120
         TabIndex        =   5
         Top             =   240
         Width           =   5295
         _ExtentX        =   9340
         _ExtentY        =   4895
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   -1  'True
         HideSelection   =   -1  'True
         OLEDragMode     =   1
         FullRowSelect   =   -1  'True
         GridLines       =   -1  'True
         _Version        =   393217
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
         Appearance      =   1
         OLEDragMode     =   1
         NumItems        =   2
         BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            Key             =   "Key"
            Text            =   "Field"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            SubItemIndex    =   1
            Key             =   "Value"
            Text            =   "Value"
            Object.Width           =   2540
         EndProperty
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private iobjZbar As ZBARCOMLib.Zaap
Private istrScriptPath As String
Private iobjScript() As clsScript
Private iintPrevZbarRes As Long
Private iintPrevZtwHandle As Long
Private iintPrevSeq As Long

Private WithEvents iclsRunningScript As clsScript
Attribute iclsRunningScript.VB_VarHelpID = -1

Private Sub Form_Load()
    If App.PrevInstance Then
        On Error Resume Next
        AppActivate Me.Caption
        Unload Me
    End If
    
    WriteToLog "Initializing ZBarCOM..."
    Set iobjZbar = New ZBARCOMLib.Zaap
    
    iintPrevZbarRes = 16777216
    TryOpeningZBar
    
    iobjZbar.ReadZbar
    iintPrevSeq = iobjZbar.SequenceNumber
    iintPrevZtwHandle = iobjZbar.ZTreeHWND
    
    istrScriptPath = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\") & "Scripts\"
    RefreshCurrent
    
    LoadScripts
    
    FormTopMost(Me.hWnd) = True
End Sub

Private Sub Form_Unload(ByRef Cancel As Integer)
    iobjZbar.CloseZbar
End Sub

Friend Property Get ZBar() As ZBARCOMLib.Zaap
    Set ZBar = iobjZbar
End Property


Private Sub cmdPause_Click()
    If tmrReadZBar.Enabled Then
        tmrReadZBar.Enabled = False
        cmdPause.Caption = "&Resume"
    Else
        cmdPause.Caption = "&Pause"
        tmrReadZBar.Enabled = True
    End If
End Sub

Private Sub iclsRunningScript_Error(Sender As clsScript, Error As ErrObject)
    Me.WindowState = vbNormal
    Me.Show
    AppActivate Me.Caption
    MessageBeep apiBeepCritical
    With Error
        WriteToLog "Error " & .Number & " from " & .Source & ": " & .Description
    End With
End Sub

Private Sub iclsRunningScript_ScriptError(Sender As clsScript, Error As MSScriptControl.Error)
    ReportScriptError Sender, Error
End Sub

Private Sub lstLog_OLECompleteDrag(Effect As Long)
    Effect = vbDropEffectCopy
End Sub

Private Sub lstLog_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
    Dim lstrLines() As String
    Dim lintLine As Long
    
    ReDim lstrLines(0 To lstLog.ListCount - 1)
    For lintLine = 0 To lstLog.ListCount - 1
        lstrLines(lintLine) = lstLog.List(lintLine)
    Next
    Data.SetData Join$(lstrLines, vbCrLf), vbCFText
    AllowedEffects = vbDropEffectCopy
End Sub

Private Sub lstScripts_Click()
    Dim lintIndex As Long

    If lstScripts.ListIndex > -1 Then
        lintIndex = lstScripts.ItemData(lstScripts.ListIndex)
        Select Case tsScript.SelectedItem.Key
        Case "Console"
            txtConsole.Text = iobjScript(lintIndex).Output
        Case "Code"
            txtConsole.Text = iobjScript(lintIndex).Code
        End Select
        
        txtConsole.Enabled = True
        txtConsole.BackColor = vbWindowBackground
    Else
        txtConsole.Enabled = False
        txtConsole.BackColor = vbButtonFace
    End If
End Sub

Private Sub lstScripts_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyF5 Then
        LoadScripts
    End If
End Sub

Private Sub lvwCurrent_OLECompleteDrag(Effect As Long)
    Effect = vbDropEffectCopy
End Sub

Private Sub lvwCurrent_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
    Dim lstrLines() As String
    Dim lintLine As Long
    
    ReDim lstrLines(1 To lvwCurrent.ListItems.Count)
    
    For lintLine = 1 To lvwCurrent.ListItems.Count
        With lvwCurrent.ListItems(lintLine)
            lstrLines(lintLine) = .Text & vbTab & .SubItems(1)
        End With
    Next
    Data.SetData Join$(lstrLines, vbCrLf), vbCFText
    AllowedEffects = vbDropEffectCopy
End Sub

Private Sub tmrReadZBar_Timer()
    Dim i As Integer
    Dim lclsScript As clsScript
    Dim lscHost As MSScriptControl.ScriptControl
'    Dim lscModule As MSScriptControl.Module
    Dim lvarResult As Variant
    Dim lblnSkip As Boolean

    With iobjZbar
        If (.ZBarOpen() = False) Or (iintPrevZbarRes <> 0) Then
            TryOpeningZBar
        End If
        If .ZBarOpen Then
            .ReadZbar
            If (.SequenceNumber <> iintPrevSeq) Or (.ZTreeHWND <> iintPrevZtwHandle) Then
                RefreshCurrent
                
                If .ZtreeCommand = Asc("y") Or .ZtreeCommand = Asc("Y") Then
                    tmrReadZBar.Interval = 50
                ElseIf tmrReadZBar.Interval = 50 Then
                    If .ZtreeCommand <> Asc("Y") Then
                        tmrReadZBar.Interval = 125
                    End If
                End If
                
                If .ZtreeCommand = Asc("Y") And .AssistCommand Like "eval [A-Za-z]* *" Then
                    Set lscHost = New MSScriptControl.ScriptControl
                    i = InStr(6, .AssistCommand, " ")
                    lscHost.Language = Mid$(.AssistCommand, 6, i - 6)
                    lscHost.AddObject "zbar", iobjZbar
                    lscHost.AddObject App.EXEName, New clsScriptGlobals, True
                    On Error Resume Next
                    lvarResult = lscHost.Eval(Mid$(.AssistCommand, i + 1))
                    If Err.Number Then
                        If lscHost.Error.Number Then
                            If lscHost.Error.Column > 0 Then
                                .WriteZbarError Asc("s"), lscHost.Error.Description & " (at position " & lscHost.Error.Column + i & ")"
                            Else
                                .WriteZbarError Asc("s"), lscHost.Error.Description
                            End If
                            ReportScriptError Nothing, lscHost.Error
                        Else
                            .WriteZbarError Asc("s"), Err.Description
                            MessageBeep apiBeepExclamation
                            WriteToLog iobjZbar.AssistCommand & "(" & iobjZbar.NewFilename & ") >> Error: " & Err.Description
                        End If
                        On Error GoTo HandleError
                    Else
                        On Error GoTo HandleError
                        If IsEmpty(lvarResult) Or IsNull(lvarResult) Then
                            '.WriteZbar Asc("k")
                        ElseIf lvarResult <> Empty Then
                            .WriteZbar Asc("T")
                            lblnSkip = True
                        Else
                            .WriteZbar Asc("U")
                            lblnSkip = True
                        End If
                        WriteToLog iobjZbar.AssistCommand & " (" & iobjZbar.NewFilename & ") >> [" & TypeName(lvarResult) & "] " & lvarResult
                    End If
                    Set lscHost = Nothing
                End If
                
                If Not lblnSkip Then
                    For i = LBound(iobjScript) To UBound(iobjScript)
                        Set lclsScript = iobjScript(i)
                        Set iclsRunningScript = lclsScript
                        If tsScript.SelectedItem.Key = "Console" Then
                            txtConsole.Text = lclsScript.Output
                        End If
                        If (.ZtreeCommand = Asc("Y")) And lclsScript.CanAssist Then
                            lvarResult = Empty
                            lvarResult = lclsScript.DoAssist
                            If IsEmpty(lvarResult) Or IsNull(lvarResult) Then
                                '.WriteZbar Asc("k")
                            ElseIf CBool(lvarResult) Then
                                .WriteZbar Asc("T")
                                lblnSkip = True
                            Else
                                .WriteZbar Asc("U")
                                lblnSkip = True
                            End If
                            WriteToLog lclsScript.Name & ": " & iobjZbar.AssistCommand & "(" & iobjZbar.NewFilename & ") >> [" & TypeName(lvarResult) & "] " & lvarResult
                        ElseIf lclsScript.CanUpdate Then
                            lvarResult = lclsScript.DoUpdate
                        End If
                        Set iclsRunningScript = Nothing
                        If lblnSkip Then Exit For
                    Next
                End If
                
                iintPrevSeq = .SequenceNumber
                iintPrevZtwHandle = .ZTreeHWND
            End If
        End If
    End With
    
HandleExit:
    Exit Sub
    
HandleError:
    MessageBeep apiBeepCritical
    With Err
        WriteToLog "Error " & .Number & ": " & .Description & " (" & .Source & ")"
    End With
    Resume Next 'HandleExit
End Sub

Private Function TryOpeningZBar() As Boolean
    Dim lintResult As Long
    Dim lstrMessage As String
    
    lintResult = iobjZbar.LogZbar
    Select Case lintResult
        Case 0
            lstrMessage = "OK"
        Case -1 ' ZBAR_NOTFOUND
            lstrMessage = "No zbar.dat found!"
        Case -2 ' ZTREE_NOTFOUND
            lstrMessage = "ZTreeWin not found!"
        Case -3 ' ZTREE_NOTRUNNING
            lstrMessage = "ZTreeWin not running!"
        Case -8 ' PSAPI_ERROR
            lstrMessage = "Unable to load PSAPI libraries..."
    End Select
    
    If lintResult <> iintPrevZbarRes Then
        WriteToLog "Reading zbar.dat..."
        WriteToLog lstrMessage, 1
        iintPrevZbarRes = lintResult
    End If
    
    TryOpeningZBar = (lintResult = 0)
    cmdPause.Enabled = TryOpeningZBar
End Function

Private Sub LoadScripts()
Dim lstrFiles() As String
Dim lstrEntry As String
Dim lintIndex As Long
    
    WriteToLog "Loading scripts from """ & istrScriptPath & """..."
    lstScripts.Clear
    txtConsole.Enabled = False
    txtConsole.BackColor = vbButtonFace
    
    ' Load list of scripts
    lstrFiles() = Split("")
    lstrEntry = Dir$(istrScriptPath & "*.*")
    Do Until LenB(lstrEntry) = 0
        ReDim Preserve lstrFiles(LBound(lstrFiles) To UBound(lstrFiles) + 1)
        lstrFiles(UBound(lstrFiles)) = lstrEntry
    
        lstrEntry = Dir$()
    Loop
    
    If UBound(lstrFiles) < LBound(lstrFiles) Then
        WriteToLog "No scripts found.", 1
        lstScripts.AddItem "(no scripts found)"
        lstScripts.ItemData(lstScripts.NewIndex) = -1
        ReDim iobjScript(0 To 0)
    Else
        
        ReDim iobjScript(LBound(lstrFiles) To UBound(lstrFiles))
        For lintIndex = LBound(lstrFiles) To UBound(lstrFiles)
            WriteToLog "Loading " & lstrFiles(lintIndex), 1
            txtConsole.Text = ""
            
            Set iobjScript(lintIndex) = New clsScript
            Set iclsRunningScript = iobjScript(lintIndex)
            With iobjScript(lintIndex)
                .Initialize iobjZbar
                .Load istrScriptPath & lstrFiles(lintIndex)
                
                lstScripts.AddItem .Name
                lstScripts.ItemData(lstScripts.NewIndex) = lintIndex
            End With
            Set iclsRunningScript = Nothing
        Next
    End If
    
HandleExit:
    If FreeFile() > 1 Then Close #1
    Exit Sub

HandleError:
    MessageBeep apiBeepCritical
    With Err
        WriteToLog "Error " & .Number & ": " & .Description & " (" & .Source & ")"
    End With
    Resume Next 'HandleExit
End Sub

Private Sub RefreshCurrent()
    With iobjZbar
        lvwCurrent.ListItems.Clear
        lvwCurrent.ListItems.Add(, "hWnd", "hWnd").ListSubItems.Add , , Hex$(.ZTreeHWND)
        lvwCurrent.ListItems.Add(, "Seq", "Sequence #").ListSubItems.Add , , .SequenceNumber
        lvwCurrent.ListItems.Add(, "Cmd", "Command").ListSubItems.Add , , Chr$(.ZtreeCommand)
        lvwCurrent.ListItems.Add(, "CmdChar", "Char").ListSubItems.Add , , Chr$(.ZtreeCommandChar)
        lvwCurrent.ListItems.Add(, "Screen", "Screen").ListSubItems.Add , , Chr$(.ZtreeScreenStatus)
        lvwCurrent.ListItems.Add(, "Page", "Page").ListSubItems.Add , , Chr$(.ZtreePage)
        lvwCurrent.ListItems.Add(, "Stats", "Stats screen").ListSubItems.Add , , .ZtreeStatsScreen
        lvwCurrent.ListItems.Add(, "File", "Filename").ListSubItems.Add , , .NewFilename, , .NewFilename
        lvwCurrent.ListItems.Add(, "Other", "Other file").ListSubItems.Add , , .OtherFilename, , .OtherFilename
        lvwCurrent.ListItems.Add(, "AssistCmd", "Assist command").ListSubItems.Add , , .AssistCommand, , .AssistCommand
        
        modListView.AutoWidth lvwCurrent
    End With
End Sub


Private Sub ReportScriptError(ByVal aclsScript As clsScript, _
                              ByRef aobjError As MSScriptControl.Error, _
                              Optional ablnSuppressSignal As Boolean = False)
    If Not ablnSuppressSignal Then
        MessageBeep apiBeepExclamation
    End If
    With aobjError
        WriteToLog "Error on line " & .Line & ", column " & .Column & ":" & _
                    .Source & ": " & .Description, 1
        If LenB(.Text) > 0 Then
            WriteToLog "(""" & Left$(.Text, 100) & """)", 2
        End If
    End With
End Sub

Private Sub WriteToLog(astrText As String, _
                       Optional aintIndent As Long = 0)
    Dim lstrLines() As String
    Dim lintLine As Long
    
    lstrLines() = Split(astrText, vbCrLf)
    For lintLine = LBound(lstrLines) To UBound(lstrLines)
        lstLog.AddItem String$(aintIndent, vbTab) & lstrLines(lintLine)
    Next
    AdjustScrollingArea lstLog
    lstLog.ListIndex = lstLog.NewIndex
    Do While lstLog.ListCount > 1024
        lstLog.RemoveItem 0
    Loop
End Sub

Private Sub tsScript_Click()
    Dim lobjScript As clsScript
    
    If lstScripts.ListIndex > -1 Then
        Set lobjScript = iobjScript(lstScripts.ItemData(lstScripts.ListIndex))
        Select Case tsScript.SelectedItem.Key
        Case "Console"
            txtConsole.Text = lobjScript.Output
        Case "Code"
            txtConsole.Text = lobjScript.Code
        End Select
    Else
        txtConsole.Text = vbNullString
        Set lobjScript = Nothing
    End If
    
End Sub
