Programming Tool Box/SIMS_2.iso/bp_3_94/vbwin/makro/command.bas

BASIC Source File | 1994-04-26 | 14KB | 417 lines

DefInt A-Z
Global Const MODE_REALIZE = 1
Global Const MODE_HELP = 2
Global Const MODE_TEST = 3
Global Const MODE_PARAMS = 4
Dim IsOutPutOpen As Integer
Dim Comment As String * 1
Dim ErrorAdd As String
Dim MsgCaption As String
Dim UserVars() As Variant
Type MakroLine
    LineIndex As Integer
    LineCommand As String
End Type
' DLL Deklarationen
Declare Function DiskInfo% Lib "bptools.dll" (ByVal nDrive%, lBytesTotal&, lBytesFree&)
Declare Function VBEdit_GetLineCount% Lib "bptools.dll" (C As Control)
Declare Sub VBEdit_InvertLine Lib "bptools.dll" (C As Control, ByVal i%)
Declare Function VBEdit_GetLine$ Lib "bptools.dll" (C As Control, ByVal i%)
Declare Sub VBCombo_SelectString Lib "bptools.dll" (C As ComboBox, ByVal a$)
Declare Sub VBCombo_ClearString Lib "bptools.dll" (C As ComboBox)


Function Char2Drive (Char$)
    x = Asc(UCase(Left$(Char$, 1)))
    If (x >= 65) And (x <= 90) Then
        x = x - 64
        Char$ = Chr$(x + 64) & ":\"
    Else
        x = 0
        Char$ = Left$(CurDir$, 1) & ":\"
    End If
    Char2Drive = x
End Function

Function cmd_CloseOutput (Modus, OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE, MODE_TEST:
    If IsOutPutOpen Then
        If Modus = MODE_REALIZE Then
            frmOutput.lst_Output.AddItem ""
            frmOutput.lst_Output.AddItem Chr$(9) & "Weiter mit beliebiger Taste oder Mausklick..."
            frmOutput.Show 1
        End If
        IsOutPutOpen = False
        cmd_CloseOutput = 0
    Else cmd_CloseOutput = -6
    End If
Case MODE_HELP
    OutputLine = "'CloseOutput' beendet die Ausgabe in einer Liste"
    cmd_CloseOutput = 1
End Select

End Function

Function cmd_Exit (Modus, OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE: Unload frmMain
Case MODE_HELP: OutputLine = "'Exit' beendet Makroverarbeitung"
End Select
cmd_Exit = 1
End Function

Function cmd_Free (Modus%, In$(), OutputLine As Variant)
    Select Case Modus
    Case MODE_REALIZE
        If UBound(In) = 1 Then
            d$ = CurDir$
        Else d$ = In(2)
        End If
        Drive = Char2Drive(d$)
        If UBound(In) < 3 Then
            showmode = 1
        Else showmode = Val(Left$(In(3), 1))
        End If
        If DriveReady(d$) = 0 Then
            x = DiskInfo(Drive, lBytesTotal&, lBytesFree&)
            If showmode > 0 Then
                lBytesTotal& = lBytesTotal& / 1024
                lBytesFree& = lBytesFree& / 1024
            End If
            OutputLine = "Laufwerk: " & d$ & Chr$(13) & Chr$(10)
            OutputLine = OutputLine & "Gesamter Speicherplatz: " & Chr$(9) & Format$(lBytesTotal&, "###,000,000") & Chr$(13) & Chr$(10)
            OutputLine = OutputLine & "Freier Speicherplatz: " & Chr$(9) & Format$(lBytesFree&, "###,000,000") & Chr$(13) & Chr$(10)
            cmd_Free = 1
        Else cmd_Free = 0
        End If
    Case MODE_HELP
        OutputLine = "'Free' ermittelt freien Speicherplatz auf dem aktuellen Laufwerk"
        cmd_Free = 1
    Case MODE_TEST
        If UBound(In) = 1 Then
            d$ = CurDir$
        Else d$ = In(2)
        End If
        Drive = Char2Drive(d$)
        x = DriveReady(d$)
        If x = 0 Then
            cmd_Free = 1
        Else cmd_Free = x
        End If
    End Select
End Function

Function cmd_Help (Modus, Arr$(), OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE
        Dummy$ = Arr$(0)
        Pos = InStr(1, Dummy$, " ")
        If Pos > 0 Then
            Dummy$ = Mid$(Arr(0), Pos + 1, Len(Trim$(Arr$(0))) - Pos + 1)
            If Left$(Dummy$, 1) = "@" Then
                OutputLine = Right$(Dummy$, Len(Dummy$) - 1)
                cmd_Help = 1
            Else
                cmd_Help = InterpretLine(MODE_HELP, Dummy$, OutputLine)
            End If
        Else cmd_Help = -3
        End If
Case MODE_TEST
        Dummy$ = Arr$(0)
        Pos = InStr(1, Dummy$, " ")
        If Pos > 0 Then
            Dummy$ = Mid$(Arr(0), Pos + 1, Len(Trim$(Arr$(0))) - Pos + 1)
            If Left$(Dummy$, 1) <> "@" Then
                cmd_Help = InterpretLine(MODE_HELP, Dummy$, OutputLine)
            Else cmd_Help = 1
            End If
        Else cmd_Help = -3
        End If
Case MODE_HELP
    OutputLine = "'Help' oder '?' zeigt Hilfe zu einem Befehl an"
    cmd_Help = 1
Case Else
    cmd_Help = -2
End Select
End Function

Function cmd_MsgBox (Modus, Arr$(), OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE, MODE_TEST
    Dummy$ = Arr$(0)
    Pos = InStr(1, Dummy$, " ")
    If Pos > 0 Then
       Dummy$ = Mid$(Arr(0), Pos + 1, Len(Trim$(Arr$(0))) - Pos + 1)
       If Left$(Dummy$, 1) = "@" Then
        OutputLine = Right$(Dummy$, Len(Dummy$) - 1)
        cmd_MsgBox = 2
       Else
        If InterpretLine(Modus, Dummy$, OutputLine) = 1 Then cmd_MsgBox = 2
       End If
    Else cmd_MsgBox = -3
    End If
Case MODE_HELP
    cmd_MsgBox = 1
    OutputLine = "'MsgBox' zeigt eine Meldung an."
End Select
End Function

Function cmd_Now (Modus, OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE, MODE_TEST
    If Modus = MODE_REALIZE Then
        OutputLine = Time$ & " am " & Date$
    End If
    cmd_Now = 1
Case MODE_HELP
    cmd_Now = 1
    OutputLine = "'Now' gibt die aktuelle Uhrzeit und das aktuelle Datum aus."
End Select
End Function

Function cmd_OpenOutput (Modus, OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE, MODE_TEST:
    If Not IsOutPutOpen Then
        If Modus = MODE_REALIZE Then Load frmOutput
        IsOutPutOpen = True
        cmd_OpenOutput = 0
    Else cmd_OpenOutput = -6
    End If
Case MODE_HELP
    OutputLine = "'OpenOutput' gestattet die Ausgabe in einer Liste"
    cmd_OpenOutput = 1
End Select
End Function

Function cmd_Out (Modus, Arr$(), OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE, MODE_TEST
        Dummy$ = Arr$(0)
        Pos = InStr(1, Dummy$, " ")
        If Pos > 0 Then
            If Modus = MODE_REALIZE Then
                Dummy$ = Mid$(Arr(0), Pos + 1, Len(Trim$(Arr$(0))) - Pos + 1)
                If Left(Dummy$, 1) = "@" Then Dummy$ = Right$(Dummy$, Len(Dummy$) - 1)
                OutputLine = Dummy$
            End If
        Else OutputLine = Right$(Dummy$, Len(Dummy$) - 2)
        End If
        cmd_Out = 1
Case MODE_HELP
    OutputLine = "'Out' oder '<<' zeigt eine Zeichenkette an"
    cmd_Out = 1
End Select
End Function

Function cmd_Set (Modus, Arr$(), OutputLine As Variant)
Select Case Modus
Case MODE_REALIZE, MODE_TEST
        If Modus = MODE_REALIZE Then m = False Else m = True
        Select Case UBound(Arr)
        Case Is = 2: cmd_Set = SetOption(Arr$(2), "", m)
        Case Is > 2: cmd_Set = SetOption(Arr$(2), Arr$(3), m)
        Case Is <= 2: cmd_Set = -3
        End Select
Case MODE_HELP
    cmd_Set = 1
    OutputLine = "'Set' oder '!' verΣndert verschiedene Einstellungen des Systems"
End Select
End Function

Function cmd_Wait (Modus, OutputLine)

End Function

Function DriveReady (Drive$)
    On Error Resume Next
    x$ = Dir$(Drive$)
    Select Case Err
    Case 0: DriveReady = 0
    Case 68: DriveReady = -10
    Case 75: DriveReady = -11
    Case 71: DriveReady = -12
    Case Else: DriveReady = -200
    End Select
End Function

Function GetError$ (ErrorIndex%)
    Select Case ErrorIndex
    Case -1: GetError = "Unbekannter Befehl: " & ErrorAdd
    Case -2: GetError = "Verschachtelter Befehl nicht ausfⁿhrbar"
    Case -3: GetError = "Parameter erwartet"
    Case -4: GetError = "Unbekannte Option: " & ErrorAdd
    Case -5: GetError = "Diese Option darf nicht gel÷scht werden"
    Case -6: GetError = "Doppelte Aufruf nicht gestattet!"
    Case -7: GetError = "Die Option kann hier nicht gesetzt werden."
    Case -8: GetError = "Vermisse Anweisung: " & ErrorAdd
    Case -9: GetError = "Unbekannter Wert fⁿr diese Option"
    Case -10: GetError = "Laufwerk auf dem System nicht verfⁿgbar"
    Case -11: GetError = "Fehler beim Zugriff auf Laufwerk"
    Case -12: GetError = "Laufwerk nicht bereit"
    Case Else: GetError = "Unbekannter Fehler"
    End Select
End Function

Function GetOption (OptionString$, ErrorIndex%) As String
    ErrorIndex = 0
    Select Case UCase(OptionString)
    Case "COMMENT": GetOption = Comment
    Case "MSGCAPTION": GetOption = MsgCaption
    Case Else
        ErrorAdd = OptionString
        ErrorIndex = -4
    End Select
End Function

Function InterpretLine (Modus, InputLine$, OutputLine As Variant) As Integer
    Dim Out$(), Arr$()
    doit = LineSplit(InputLine$, Arr$())
    If doit Then
    Select Case UCase(Trim$(Arr$(1)))  'Welcher Befehl?
    Case "EXIT": InterpretLine = cmd_Exit(Modus, OutputLine)
    Case "FREE": InterpretLine = cmd_Free(Modus, Arr$(), OutputLine)
    Case "MSGBOX": InterpretLine = cmd_MsgBox(Modus, Arr$(), OutputLine)
    Case "HELP", "?": InterpretLine = cmd_Help(Modus, Arr$(), OutputLine)
    Case "SET", "!": InterpretLine = cmd_Set(Modus, Arr$(), OutputLine)
    Case "OPENOUTPUT": InterpretLine = cmd_OpenOutput(Modus, OutputLine)
    Case "CLOSEOUTPUT": InterpretLine = cmd_CloseOutput(Modus, OutputLine)
    Case "OUT", "<<": InterpretLine = cmd_Out(Modus, Arr$(), OutputLine)
    Case "NOW": InterpretLine = cmd_Now(Modus, OutputLine)
    Case Else:
        ErrorAdd = Trim$(Arr$(1))
        InterpretLine = -1 'Unbekannter Befehl
    End Select
    End If
End Function

Function InterpretMakro (InitMode%, Makro() As MakroLine, ErrorIndex)
    'Dim F As Form
    Dim Out As Variant, Arr$()
    WinCmdInit
    For i = LBound(Makro) To UBound(Makro)
        NextErr = InterpretLine((InitMode), Makro(i).LineCommand, Out)
        Select Case NextErr
        Case 1:
            If InitMode <> MODE_TEST Then
                If VarType(Out) = 8 Then
                    If IsOutPutOpen Then
                        x = LineUndoBreak(Out, Arr$())
                        For j = 1 To UBound(Arr)
                            frmOutput.lst_Output.AddItem Trim$(Arr$(j))
                        Next
                    Else
                        MsgBox Out, 0, GetOption("MsgCaption", 0)
                    End If
                End If
            End If
        Case 2: If InitMode <> MODE_TEST Then MsgBox Out, 0, GetOption("MsgCaption", 0)
        Case Is < 0:       ' Sonst ignorieren
            InterpretMakro = Makro(i).LineIndex
            ErrorIndex = NextErr
            Exit Function
        End Select
    Next
    If IsOutPutOpen Then
        ErrorAdd = "CloseOutput"
        ErrorIndex = -8
        InterpretMakro = Makro(UBound(Makro)).LineIndex
    Else InterpretMakro = -1
    End If
End Function

Function LineSplit (ByVal CommandLine$, Arr$())
    Dim Start As Integer, Pos As Integer, NextString As String
    ReDim Arr$(0)
    If Len(CommandLine) = 0 Then Exit Function
    If Left$(CommandLine, 1) = ";" Then Exit Function
    LineSplit = True
    Pos = InStr(1, CommandLine$, ";")
    If Pos > 0 Then CommandLine$ = Left$(CommandLine$, Pos - 1)
    CommandLine$ = Trim$(CommandLine$)
    Arr$(0) = CommandLine$
    Start = 1
    Pos = InStr(Start, CommandLine$, " ")
    Do While Pos > 0
        ReDim Preserve Arr(UBound(Arr) + 1)
        NextString = Mid$(CommandLine$, Start, Pos - Start)
        If Left$(NextString, 1) = "@" Then
            Arr(UBound(Arr)) = Mid$(CommandLine$, Start + 1, Len(CommandLine) + 1 - Start)
            Exit Function
        Else
        Start = Pos + 1
        Arr(UBound(Arr)) = NextString
        Pos = InStr(Start, CommandLine$, " ")
        End If
    Loop
    ReDim Preserve Arr(UBound(Arr) + 1)
    Arr(UBound(Arr)) = Mid$(CommandLine$, Start, Len(CommandLine$) - Start + 1)
End Function

Function LineUndoBreak (ByVal CommandLine$, Arr$())
    Dim Start As Integer, Pos As Integer, NextString As String
    LF$ = Chr$(13) & Chr$(10)
    ReDim Arr$(0)
    Arr$(0) = CommandLine$
    Start = 1
    Pos = InStr(Start, CommandLine$, LF$)
    Do While Pos > 0
        ReDim Preserve Arr(UBound(Arr) + 1)
        Arr(UBound(Arr)) = Mid$(CommandLine$, Start, Pos - Start)
        Start = Pos + 2
        Pos = InStr(Start, CommandLine$, LF$)
    Loop
    ReDim Preserve Arr(UBound(Arr) + 1)
    Arr(UBound(Arr)) = Mid$(CommandLine$, Start, Len(CommandLine$) - Start + 2)
End Function

Function SetOption (OptionString$, OptionValue$, IsTest)
    SetOption = 0
    Select Case UCase(OptionString)
    Case "COMMENT":
        If Len(OptionValue) > 0 Then
            If Not IsTest Then Comment = Left$(OptionValue, 1)
        Else
            SetOption = -5
        End If
    Case "MSGCAPTION": MsgCaption = OptionValue
    Case "OUTPUTCAPTION":
        If Not IsOutPutOpen Then
            SetOption = -7
        Else If Not IsTest Then frmOutput.Caption = OptionValue
        End If
    Case "OUTPUTX"
        If Not IsOutPutOpen Then
            SetOption = -1
        Else
            Select Case Val(OptionValue$)
            Case -1: If Not IsTest Then frmOutput.Left = (Screen.Width - frmOutput.Width) / 2
            Case Is > 0: If Not IsTest Then frmOutput.Left = Val(OptionValue)
            Case Else: SetOption = -9
            End Select
        End If
    Case "OUTPUTY"
        If Not IsOutPutOpen Then
            SetOption = -1
        Else
            Select Case Val(OptionValue$)
            Case -1: If Not IsTest Then frmOutput.Top = (Screen.Height - frmOutput.Height) / 2
            Case Is > 0: If Not IsTest Then frmOutput.Top = Val(OptionValue)
            Case Else: SetOption = -9
            End Select
        End If
    Case Else
        ErrorAdd = OptionString
        SetOption = -4
    End Select
End Function

Sub WinCmdInit ()
    Comment = ";"
    MsgCaption = App.Title
    If IsOutPutOpen Then Unload frmOutput
    IsOutPutOpen = False
End Sub