frmdocument.frm

TCP-IP数据库查询.zip

Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public blnDialogShow As Boolean
Public blnConnect As Boolean
Dim strDataLOC As String
Dim strDataREM As String
Dim blnREMOTE As Boolean
Dim blnLOC As Boolean
Dim blnDataREM As Boolean
Dim blnDataLOC As Boolean
Dim speedUP, speedDOWN As Long
Public RTColorRemote As Double
Public RTColorLocaal As Double
Public RemCon As Boolean
Public blnDataExist As Boolean

'Retrieve the IP & data

Private Type LocalIP
    L_addr As String
    L_port As Integer
End Type

Private Type RemoteIP
    R_addr As String
    R_port As Integer
End Type

Dim MyLocalIP As LocalIP
Dim MyRemIP As RemoteIP



Public Sub DisconnectPort()
If blnConnect = True Then
    
    Status.Panels(1) = "Disconnected"
    LOCAAL.Close
    REMOTE.Close
    blnREMOTE = False  'Kan dus nog niets verzenden!
    blnDataREM = False
    tmrSpeed.Enabled = False
    blnConnect = False
    End If

End Sub
Public Sub connectPort()
If blnConnect = False Then

    Status.Panels(1) = "Listen @ Client"
    Me.txtLIST_ON = IP.IPINFO.ListenOnIP
    LOCAAL.Bind MyLocalIP.L_port, MyLocalIP.L_addr
    LOCAAL.Listen
    tmrSpeed.Enabled = True
    blnConnect = True
End If
End Sub


Private Sub cmdClientApply_Click()
'Controle if checkbox is checked..
If chkCDC.Value = 1 Then

    If txtCDC_Source = "" Or txtCDC_Change = "" Then
        MsgBox "enter data in the textbox's or Disable the enable checkbutton !", vbCritical
        Exit Sub
    End If
    fraClientDC.Visible = False
Else
    
    fraClientDC.Visible = False
End If
End Sub

Private Sub cmdServerAppl_Click()
If chkSDC.Value = 1 Then
    
    If txtSDC_Source = "" Or txtSDC_Change = "" Then
        MsgBox "enter data in the textbox's or Disable the enable checkbutton !", vbCritical
        Exit Sub
    End If
    fraServerDC.Visible = False
Else
    
    fraServerDC.Visible = False
End If
End Sub

Private Sub Command1_Click()

If fraExtra.Visible = False Then
fraExtra.Top = Command1.Top + 500
fraExtra.Left = Command1.Left + 10
fraExtra.Visible = True
Else
fraExtra.Visible = False
End If

End Sub





Private Sub Form_Load()
fraExtra.Visible = False
fraServerDC.Visible = False
fraClientDC.Visible = False
On Error GoTo Errors:
'
  'Check if you want to open a file or make a new connection ..
 If Settings.Fileopen = True Then
    Form_Resize
    Settings.Fileopen = False
       Exit Sub
 End If
 
 blnConnect = True
 
 'Get the IP's local & remote incl ports..
 MyLocalIP.L_addr = IP.IPINFO.ListenOnIP
 MyLocalIP.L_port = Val(IP.IPINFO.ListenOnPORT)
 MyRemIP.R_addr = IP.IPINFO.ConnectToIP
 MyRemIP.R_port = Val(IP.IPINFO.ConnectToPORT)
 
 
 Me.Caption = IP.IPINFO.Name
 Me.txtCON_PORT = MyRemIP.R_port
 Me.txtCON_TO = MyRemIP.R_addr
 'Me.txtLIST_ON = IP.IPinfo.ListenOnIP
 Me.txtLIS_ONPORT = MyLocalIP.L_port
 'blnDialogShow = False
 'Statusbar change..
 
 Status.Panels(1) = "Waiting..."
 Status.Panels(2) = " 0 Bit/s"
 Status.Panels(3) = " 0 Bit/s"
 'Set WSLIST to listen..
 LOCAAL.Close
 Me.txtLIST_ON = MyLocalIP.L_addr
 'LOCAAL.LocalPort = IP.IPINFO.ListenOnPORT
 LOCAAL.Bind MyLocalIP.L_port, MyLocalIP.L_addr
 LOCAAL.Listen
 Status.Panels(1) = "Listen @ client"
 blnDataREM = False
 blnREMOTE = False
 
  Form_Resize
    speedUP = 0
    speedDOWN = 0

'Display text in RTBox if checkview Data isn't enabled

'Color Change
Label3(0).ForeColor = IP.RTColorLocaal
Label4.ForeColor = IP.RTColorRemote
Label3(0) = Label3(0)
Label4 = Label4
Exit Sub
Errors:
    MsgBox "An Error Occured , maybe that the local port you want to use , is already in use.., try other port !", vbCritical
    Unload Me
End Sub



Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblExit.ForeColor = 0

End Sub

Private Sub Form_Resize()
    On Error Resume Next
    Line1(0).X2 = Me.Width - 80
    RTBox.Top = 950
    RTBox.Left = 50
    RTBox.Width = Me.Width - 200
    RTBox.Height = Me.Height - 1700
End Sub







Private Sub fraExtra_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblExit.ForeColor = 0
lblHelp.ForeColor = 0
lblSDC.ForeColor = 0
lblCls.ForeColor = 0
lblCDC.ForeColor = 0
End Sub



Private Sub lblCDC_Click()
fraClientDC.Top = Command1.Top + 500
fraClientDC.Left = Command1.Left + 10
fraClientDC.Visible = True
fraExtra.Visible = False
End Sub

Private Sub lblCDC_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblExit.ForeColor = 0
lblHelp.ForeColor = 0
lblSDC.ForeColor = 0
lblCls.ForeColor = 0
lblCDC.ForeColor = vbWhite
End Sub

Private Sub lblCls_Click()
RTBox.Text = ""
fraExtra.Visible = False
End Sub

Private Sub lblCls_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblExit.ForeColor = 0
lblHelp.ForeColor = 0
lblSDC.ForeColor = 0
lblCDC.ForeColor = 0
lblCls.ForeColor = vbWhite
End Sub

Private Sub lblExit_Click()
fraExtra.Visible = False
End Sub

Private Sub lblExit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblExit.ForeColor = vbWhite
lblHelp.ForeColor = 0
lblCls.ForeColor = 0
lblCDC.ForeColor = 0
lblSDC.ForeColor = 0
End Sub

Private Sub lblHelp_Click()
frmHelp.Show
fraExtra.Visible = False
End Sub

Private Sub lblHelp_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblHelp.ForeColor = vbWhite
lblExit.ForeColor = 0
lblCls.ForeColor = 0
lblSDC.ForeColor = 0
lblCDC.ForeColor = 0
End Sub

Private Sub lblSDC_Click()
fraServerDC.Top = Command1.Top + 500
fraServerDC.Left = Command1.Left + 10
fraExtra.Visible = False

If blnConnect = True Then
        'Disconnect
        lblSDC.Caption = "Connect"
        DisconnectPort
Else
        'Connect
        lblSDC.Caption = "Disconnect"
        connectPort
End If
'fraServerDC.Visible = True
End Sub

Private Sub lblSDC_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblExit.ForeColor = 0
lblHelp.ForeColor = 0
lblCls.ForeColor = 0
lblCDC.ForeColor = 0
lblSDC.ForeColor = vbWhite
End Sub

Private Sub LOCAAL_ConnectionRequest(ByVal requestID As Long)
    ' Check if the control's State is closed. If not,
    ' close the connection before accepting the new
    ' connection.
    If LOCAAL.State <> sckClosed Then _
    LOCAAL.Close
    ' Accept the request with the requestID
    ' parameter.
    LOCAAL.Accept requestID
    Status.Panels(1) = "in progress"
    Connecteer
End Sub
Sub Connecteer()
REMOTE.Connect MyRemIP.R_addr, MyRemIP.R_port
'Wachten van data binnenhalen locaal.. indien host nog niet gevonden..
RemCon = False
End Sub
Private Sub LOCAAL_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)
' Idien adres - port in gebruik is..
If Number = 10048 Then
MsgBox "Port is in use.. choose other port"
Dialog.Show
Exit Sub
End If
Status.Panels(1) = " Error!! "
RTBox.SelColor = vbWhite
RTBox.SelText = "Client Error !"
RTBox.SelText = "ERROR :> " & Number & "  " & Description & "  " & Scode & "  " & Source
If Number = sckConnectAborted Then
LOCAAL.Close
End If

End Sub

Private Sub LOCAAL_Close()
LOCAAL.Close
REMOTE.Close
Status.Panels(1) = "Disconnected!"
'cmd_CON_DISCON.Caption = "Connect"
blnREMOTE = False  'Kan dus nog niets verzenden!
blnDataREM = False
blnConnect = False
tmrSpeed.Enabled = False
End Sub


Private Sub Form_Unload(Cancel As Integer)
LOCAAL.Close
REMOTE.Close
tmrSpeed.Enabled = False
End Sub
Private Sub LOCAAL_DataArrival(ByVal bytesTotal As Long)
'This will accept the data from the Client application.
Dim str As String
Status.Panels(1) = "in progress.."

LOCAAL.GetData strDataLOC, vbByte, bytesTotal
str = strDataLOC
'------------------------------------------------
'Changing the string str
'------------------------------------------------
'Put the data in the RT Box Color RED
If Settings.EnableTXT = True Then
RTBox.SelStart = Len(RTBox.TextRTF)
RTBox.SelColor = IP.RTColorLocaal
'Check of it must be send to RTBOX in Hex Format
If Check1.Value = 1 Then
str = StringToHex(strDataLOC)
End If

RTBox.SelText = str & vbCrLf
End If
'record the speed connection
speedUP = speedUP + Len(strDataLOC)
'------------------------------------------------
' NEW *******************************************
' Change data from client appl before it will send to the server
If chkCDC.Value = 1 Then
    
    Debug.Print strDataLOC
    If InStr(1, strDataLOC, txtCDC_Source, vbTextCompare) <> 0 Then
        strDataLOC = Replace(strDataLOC, txtCDC_Source, txtCDC_Change)
        RTBox.SelColor = &H800080
        RTBox.SelStart = Len(RTBox.TextRTF)
        RTBox.SelText = "************ Source Data found from Client Appl & changed ! *********" & _
        vbCrLf & strDataLOC & "************** end changed part *************" & vbCrLf
        
    End If
End If
' -----------------------------------------------
'Send the data to Server socket
SendToServer (strDataLOC)
End Sub



Sub SendToServer(Data As String)
While (blnDataREM = False)
'wanneer vorige data nog niet volledig verzonden is..
DoEvents
Wend
'kijken of er geconecteerd is naar de server..
While (RemCon = False)
DoEvents
Wend

REMOTE.SendData (Data)
End Sub



Private Sub LOCAAL_SendComplete()
blnDataExist = False
End Sub

Private Sub REMOTE_DataArrival(ByVal bytesTotal As Long)
Dim str As String

blnDataExist = True

REMOTE.GetData strDataREM, vbString, bytesTotal
str = strDataREM
'Check to change to hex value..
If Check1.Value = 1 Then
str = StringToHex(strDataREM)
End If
'-----------------------------------------
RTBox.SelColor = vbBlue
RTBox.SelStart = Len(RTBox.TextRTF)
RTBox.SelText = str
'*********** NEW PART  Server data change ****************
If chkSDC.Value = 1 Then
    
     If InStr(1, strDataREM, txtSDC_Source, vbBinaryCompare) <> 0 Then
        strDataREM = Replace(strDataREM, txtSDC_Source, txtSDC_Change)
        LOCAAL.SendData strDataREM
        RTBox.SelColor = &H808080
        RTBox.SelStart = Len(RTBox.TextRTF)
        RTBox.SelText = "************* String found in Server Data & changed ! *********" & _
        vbCrLf & strDataREM & "*************** end changed part *************" & vbCrLf
        
    End If
End If
'Record the speed DOWNLOAD
speedDOWN = speedDOWN + Len(strDataREM)
LOCAAL.SendData strDataREM
End Sub
Private Sub REMOTE_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)
Status.Panels(1) = "Error "
RTBox.SelColor = vbWhite
RTBox.SelText = "Server Error !" & vbCrLf
RTBox.SelText = "ERROR :> " & Number & "  " & Description & "  " & Scode & "  " & Source
If Number = 11001 Then
    MsgBox "Hostadress not found !"
End If
lblSDC_Click
End Sub

Private Sub REMOTE_SendComplete()
blnDataREM = True
End Sub

Private Sub REMOTE_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
blnDataREM = False
End Sub
Private Sub REMOTE_Connect()
blnREMOTE = True
blnDataREM = True
RemCon = True
End Sub

Private Sub REMOTE_Close()
REMOTE.Close


LOCAAL.Close
Status.Panels(1) = "Disconnected"
'cmd_CON_DISCON.Caption = "Connect"
blnConnect = True
tmrSpeed.Enabled = False
End Sub

Private Sub RTBox_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblExit.ForeColor = 0
lblHelp.ForeColor = 0
lblSDC.ForeColor = 0
lblCls.ForeColor = 0
lblCDC.ForeColor = 0
End Sub

Private Sub tmrSpeed_Timer()
Dim UP, DOWN As Long

'Show the upload speed in the box
If (speedUP * 2) < 1000 Then
Status.Panels(2) = "UP: " & (speedUP * 2) & " Bytes/s"
Else
UP = (speedUP * 2) / 1000
UP = Round(UP, 2)
Status.Panels(2) = "UP: " & UP & " kB/s"
End If
If (speedDOWN * 2) < 1000 Then
Status.Panels(3) = "DN: " & (speedDOWN * 2) & " Bytes/s"
Else
DOWN = (speedDOWN * 2) / 1000
DOWN = Round(DOWN, 2)
Status.Panels(3) = "DN: " & DOWN & " kB/s"

End If
speedUP = 0
speedDOWN = 0
End Sub

Private Sub txtLIST_ON_Change()
txtLIST_ON = MyLocalIP.L_addr

End Sub