Note: This is not the complete source code--just the main source file.
You can download the full source (with include files) from our sample code archive by clicking on the diskette icons.
VERSION 5.00
Begin VB.Form Form1
BorderStyle = 3 'Fixed Dialog
Caption = "TcpQuery"
ClientHeight = 6930
ClientLeft = 45
ClientTop = 345
ClientWidth = 8910
ClipControls = 0 'False
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6930
ScaleWidth = 8910
StartUpPosition = 1 'CenterOwner
Begin VB.TextBox txtTimeout
Height = 285
Left = 4920
TabIndex = 13
Top = 1080
Width = 1455
End
Begin VB.ComboBox cboServer
Height = 315
ItemData = "VbTcpQuery.frx":0000
Left = 120
List = "VbTcpQuery.frx":0016
TabIndex = 12
Text = "Combo1"
Top = 360
Width = 4455
End
Begin VB.CommandButton cmdExit
Cancel = -1 'True
Caption = "Exit"
Height = 375
Left = 7800
TabIndex = 3
TabStop = 0 'False
Top = 960
Width = 975
End
Begin VB.CommandButton cmdGo
Caption = "Go"
Default = -1 'True
Height = 375
Left = 6720
TabIndex = 2
TabStop = 0 'False
Top = 960
Width = 975
End
Begin VB.TextBox txtQuery
Height = 285
Left = 120
TabIndex = 0
Top = 1080
Width = 4455
End
Begin VB.TextBox txtResponse
BeginProperty Font
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4095
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 1
Top = 1800
Width = 8655
End
Begin VB.Frame Frame1
Caption = "Service"
Height = 615
Left = 4800
TabIndex = 7
Top = 120
Width = 3975
Begin VB.OptionButton optService
Caption = "Whois"
Height = 255
Index = 0
Left = 240
TabIndex = 11
Top = 240
Value = -1 'True
Width = 855
End
Begin VB.OptionButton optService
Caption = "Finger"
Height = 255
Index = 1
Left = 1200
TabIndex = 10
Top = 240
Width = 855
End
Begin VB.OptionButton optService
Caption = "HTTP"
Height = 255
Index = 2
Left = 2160
TabIndex = 9
Top = 240
Width = 855
End
Begin VB.OptionButton optService
Caption = "Echo"
Height = 255
Index = 3
Left = 3120
TabIndex = 8
Top = 240
Width = 735
End
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Caption = "Timeout (ms)"
Height = 255
Left = 4920
TabIndex = 22
Top = 840
Width = 1335
End
Begin VB.Label lblLicenseB
BackStyle = 0 'Transparent
Caption = "licenseB"
Height = 255
Index = 1
Left = 5400
TabIndex = 21
Top = 6600
Width = 2895
End
Begin VB.Label lblLicenseA
BackStyle = 0 'Transparent
Caption = "licenseA"
Height = 255
Index = 1
Left = 5400
TabIndex = 20
Top = 6360
Width = 2895
End
Begin VB.Label lblVersion
BackStyle = 0 'Transparent
Caption = "version"
Height = 255
Index = 1
Left = 5400
TabIndex = 19
Top = 6120
Width = 2895
End
Begin VB.Label Label4
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "HexLookup"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 1
Left = 4080
TabIndex = 18
Top = 6120
Width = 1215
End
Begin VB.Label lblLicenseB
BackStyle = 0 'Transparent
Caption = "licenseB"
Height = 255
Index = 0
Left = 1440
TabIndex = 17
Top = 6600
Width = 2655
End
Begin VB.Label lblLicenseA
BackStyle = 0 'Transparent
Caption = "licenseA"
Height = 255
Index = 0
Left = 1440
TabIndex = 16
Top = 6360
Width = 2655
End
Begin VB.Label lblVersion
BackStyle = 0 'Transparent
Caption = "version"
Height = 255
Index = 0
Left = 1440
TabIndex = 15
Top = 6120
Width = 2655
End
Begin VB.Label Label4
Alignment = 1 'Right Justify
BackStyle = 0 'Transparent
Caption = "HexTcpQuery"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 0
Left = 120
TabIndex = 14
Top = 6120
Width = 1215
End
Begin VB.Label Label3
Caption = "Server"
Height = 255
Left = 120
TabIndex = 6
Top = 120
Width = 1335
End
Begin VB.Label Label2
Caption = "Response"
Height = 255
Left = 120
TabIndex = 5
Top = 1560
Width = 1215
End
Begin VB.Label Label1
Caption = "Query"
Height = 255
Left = 120
TabIndex = 4
Top = 840
Width = 735
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'// TcpQuery sample program
'//
'// Demonstrates use of HexTcpQuery and HexLookup
'// (but not necessarily good programming style :)
'//
'// Copyright (C) 1998 Hexillion Technologies. All rights reserved.
'//
Option Explicit
Private m_oTcpq As HexTcpQuery
Private m_oLkup As HexLookup
Private Const m_sUserAgent As String = "User-Agent: VbTcpQuery sample (http://www.hexillion.com)"
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdGo_Click()
cmdGo.Enabled = False
txtResponse = ""
DoEvents
'Look up remote server IP address, exit on failure
Dim lAddr As Long
lAddr = m_oLkup.LookUp(cboServer)
If 0 = lAddr Then
txtResponse = "Lookup of " & cboServer & " failed."
cmdGo.Enabled = True
Exit Sub
End If
m_oTcpq.Timeout = CLng(txtTimeout)
Dim vStart
vStart = Timer
'Tell HexTcpQuery the server IP address
m_oTcpq.RemoteAddr = lAddr
'Set port and do query according to service selection
If optService(0) Then
m_oTcpq.RemotePort = hexTcpqPortWhois
txtResponse = m_oTcpq.Query(txtQuery & vbCrLf)
ElseIf optService(1) Then
m_oTcpq.RemotePort = hexTcpqPortFinger
txtResponse = m_oTcpq.Query(txtQuery & vbCrLf)
ElseIf optService(2) Then
m_oTcpq.RemotePort = hexTcpqPortHttp
txtResponse = m_oTcpq.Query(txtQuery & vbCrLf & _
m_sUserAgent & vbCrLf & _
"Host: " & cboServer & vbCrLf & _
vbCrLf)
Else
'The following block of code demonstrates QueryBinary.
m_oTcpq.RemotePort = hexTcpqPortEcho
'Convert query string to byte array
Dim sQuery As String, sResponse As String
Dim i As Integer, iQueryLen As Integer
sQuery = txtQuery
iQueryLen = Len(sQuery)
ReDim byQuery(1 To iQueryLen) As Byte
For i = 1 To iQueryLen
byQuery(i) = Asc(Mid$(sQuery, i, 1))
Next
'Do the query
'There are two query lines below: one that
'passes the byte array to QueryBinary, one that
'passes the string. You can use either one--
'they both achieve the same result.
Dim vResponse As Variant
vResponse = m_oTcpq.QueryBinary(byQuery)
' vResponse = m_oTcpq.QueryBinary(sQuery)
'Convert the byte array response to characters
For i = LBound(vResponse) To UBound(vResponse)
txtResponse = txtResponse & Chr$(vResponse(i))
Next
End If
'Interpret the value of the Error property
Select Case m_oTcpq.Error
Case hexTcpqErrSuccess
'Do nothing
Case hexTcpqErrConnectionRefused
txtResponse = txtResponse & vbCrLf & "[Connection refused]"
Case hexTcpqErrConnectionReset
txtResponse = txtResponse & vbCrLf & "[Connection dropped by remote host]"
Case hexTcpqErrHostUnreachable
txtResponse = txtResponse & vbCrLf & "[Host unreachable]"
Case hexTcpqErrNetworkUnreachable
txtResponse = txtResponse & vbCrLf & "[Network unreachable]"
Case hexTcpqErrTimedOut
txtResponse = txtResponse & vbCrLf & "[Query timed out]"
Case Else
txtResponse = txtResponse & vbCrLf & "[Error " & m_oTcpq.Error & "]"
End Select
txtResponse = txtResponse & vbCrLf & "[Query time: " & (Timer - vStart) & "s]"
cmdGo.Enabled = True
End Sub
Private Sub Form_Initialize()
Set m_oTcpq = New HexTcpQuery
Set m_oLkup = New HexLookup
End Sub
Private Sub Form_Load()
'// Display version and license information
lblVersion(0) = m_oTcpq.Version
If hexTcpqErrSuccess <> m_oTcpq.Error Then
lblLicenseA(0) = GetLicenseErrorString(m_oTcpq.Error)
lblLicenseB(0) = "Evaluation expires " & m_oTcpq.Expires
ElseIf 0 = m_oTcpq.LicensedProcessors Then
lblLicenseA(0) = "Runtime license"
lblLicenseB(0) = ""
Else
lblLicenseA(0) = GetLicenseType(m_oTcpq.LicensedProcessors) & " license"
lblLicenseB(0) = m_oTcpq.LicensedUser
End If
lblVersion(1) = m_oLkup.Version
If hexLuErrSuccess <> m_oLkup.Error Then
lblLicenseA(1) = GetLicenseErrorString(m_oLkup.Error)
lblLicenseB(1) = "Evaluation expires " & m_oLkup.Expires
ElseIf 0 = m_oLkup.LicensedProcessors Then
lblLicenseA(1) = "Runtime license"
lblLicenseB(1) = ""
Else
lblLicenseA(1) = GetLicenseType(m_oLkup.LicensedProcessors) & " license"
lblLicenseB(1) = m_oLkup.LicensedUser
End If
cboServer.ListIndex = 0
txtQuery = "help"
txtTimeout = m_oTcpq.Timeout
End Sub
Private Sub Form_Terminate()
Set m_oTcpq = Nothing
Set m_oLkup = Nothing
End Sub
Private Sub optService_Click(Index As Integer)
If Index = 2 Then txtQuery = "GET / HTTP/1.0"
End Sub