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