home *** CD-ROM | disk | FTP | other *** search
VERSION 5.00 Object = "{60F3DD10-54A1-416D-835C-B8371C544B98}#4.0#0"; "WebX.ocx" Begin VB.Form frmWebXSampleApp BorderStyle = 1 'Fixed Single Caption = "WebX Sample Application" ClientHeight = 6630 ClientLeft = 45 ClientTop = 330 ClientWidth = 7215 Icon = "WebXSampleApp.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 6630 ScaleWidth = 7215 StartUpPosition = 2 'CenterScreen Begin WebXServer.WebX WebX1 Height = 1080 Left = 6000 Top = 4500 Width = 1080 _ExtentX = 1905 _ExtentY = 1905 ServerName = "kcsnt02" End Begin VB.Frame Frame1 Caption = "Options" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1215 Left = 60 TabIndex = 27 Top = 4380 Width = 5835 Begin VB.CheckBox chkTrap Caption = "Trap Requests" Height = 255 Left = 4020 TabIndex = 8 Top = 240 Value = 1 'Checked Width = 1755 End Begin VB.TextBox txtServerPort Height = 285 Left = 1020 TabIndex = 3 Text = "80" Top = 540 Width = 675 End Begin VB.CheckBox chkHTMLFunc Caption = "HTML Functions" Height = 255 Left = 4020 TabIndex = 9 Top = 480 Value = 1 'Checked Width = 1755 End Begin VB.CheckBox chkISAPI Caption = "ISAPI Scripts" Height = 255 Left = 2160 TabIndex = 7 Top = 720 Value = 1 'Checked Visible = 0 'False Width = 1755 End Begin VB.CheckBox chkSSI Caption = "SSI Variables" Height = 255 Left = 2160 TabIndex = 6 Top = 480 Value = 1 'Checked Width = 1755 End Begin VB.CheckBox chkCGI Caption = "CGI Scripts" Height = 255 Left = 2160 TabIndex = 5 Top = 240 Value = 1 'Checked Width = 1755 End Begin VB.CheckBox chkEnableLB Caption = "Enable List Box" Height = 255 Left = 120 TabIndex = 4 ToolTipText = "Enable list box above. If enabled, test app will run slower." Top = 900 Value = 1 'Checked Width = 1755 End Begin VB.CheckBox chkVerboseErrors Caption = "Verbose Errors" Height = 255 Left = 4020 TabIndex = 10 Top = 720 Value = 1 'Checked Width = 1755 End Begin VB.TextBox txtMaxConn Height = 285 Left = 1020 TabIndex = 2 Text = "1" Top = 240 Width = 675 End Begin VB.Label Label9 Caption = "HTTP Port" Height = 195 Left = 120 TabIndex = 31 Top = 600 Width = 855 End Begin VB.Label Label6 Caption = "Max Conn" Height = 195 Left = 120 TabIndex = 28 Top = 300 Width = 855 End End Begin VB.Frame frmSepBottom Height = 70 Left = 60 TabIndex = 26 Top = 5640 Width = 7095 End Begin VB.OptionButton Option1 Caption = "&Start Server" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00008000& Height = 375 Left = 4440 Style = 1 'Graphical TabIndex = 0 Top = 5820 Width = 1335 End Begin VB.Timer tmrStats Enabled = 0 'False Interval = 1000 Left = 3960 Top = 5820 End Begin VB.Frame frmStats Caption = "Stats" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 795 Left = 60 TabIndex = 13 Top = 3480 Width = 7095 Begin VB.Label Label7 BackStyle = 0 'Transparent Caption = "Requests:" Height = 255 Left = 4800 TabIndex = 25 Top = 480 Width = 1035 End Begin VB.Label lblReqs Height = 255 Left = 5580 TabIndex = 24 Top = 480 Width = 1335 End Begin VB.Label lblSocketFree Height = 255 Left = 1080 TabIndex = 23 Top = 480 Width = 1335 End Begin VB.Label lblUpTime Height = 255 Left = 1080 TabIndex = 22 Top = 240 Width = 1335 End Begin VB.Label lblReceived Height = 255 Left = 3180 TabIndex = 21 Top = 240 Width = 1335 End Begin VB.Label lblSent Height = 255 Left = 3180 TabIndex = 20 Top = 480 Width = 1335 End Begin VB.Label lblErrors Height = 255 Left = 5580 TabIndex = 19 Top = 240 Width = 1335 End Begin VB.Label Label5 BackStyle = 0 'Transparent Caption = "Free Conns:" Height = 255 Left = 120 TabIndex = 18 Top = 480 Width = 1035 End Begin VB.Label Label1 BackStyle = 0 'Transparent Caption = "Errors:" Height = 255 Left = 4800 TabIndex = 17 Top = 240 Width = 1035 End Begin VB.Label Label2 BackStyle = 0 'Transparent Caption = "Sent:" Height = 255 Left = 2640 TabIndex = 16 Top = 480 Width = 1035 End Begin VB.Label Label3 BackStyle = 0 'Transparent Caption = "Rcvd:" Height = 255 Left = 2640 TabIndex = 15 Top = 240 Width = 1035 End Begin VB.Label Label4 BackStyle = 0 'Transparent Caption = "Up Time:" Height = 255 Left = 120 TabIndex = 14 Top = 240 Width = 1035 End End Begin VB.CommandButton cmdExit Caption = "E&xit" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 5820 Style = 1 'Graphical TabIndex = 1 Top = 5820 Width = 1335 End Begin VB.ListBox List1 Height = 3375 Left = 0 TabIndex = 11 Top = 0 Width = 7215 End Begin VB.Label Label8 Caption = "For information about the WebX go to:" Height = 255 Left = 60 TabIndex = 30 Top = 5760 Width = 3435 End Begin VB.Label lblWebSite Caption = "http://www.futurewavetech.com" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FF0000& Height = 255 Left = 60 TabIndex = 29 ToolTipText = "Click here to go to http://www.futurewavetech.com" Top = 6000 Width = 3435 End Begin VB.Label lblStatus BorderStyle = 1 'Fixed Single Height = 255 Left = 0 TabIndex = 12 Top = 6360 Width = 7215 End Attribute VB_Name = "frmWebXSampleApp" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit '************************************************** ' API Declares '************************************************** ' ShellExecute - used to launch browser when user ' clicks on web link label Private Declare Function ShellExecute Lib "shell32.dll" _ Alias "ShellExecuteA" (ByVal hWnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long _ ) As Long '************************************************** ' Form Events '************************************************** Private Sub Form_Initialize() With WebX1 ' Server Params ******************************* ' in minutes, zero = infinite .ConnectionTimeout = 10 ' HTML Setup Parameters .VirtualPath = App.Path & "\html" .CGIDirectory = App.Path & "\scripts" .IndexPageNames = "index.html, default.htm" .DirectoryBrowseEnable = True ' Uncomment next two lines to use a text file as the ' source of the mime types supported '.ContentTypeSourceFile = App.Path & "\mime_lst.txt" '.ContentTypeSource = File ' Uncomment next line to use the internal table as the ' source of the mime types supported '.ContentTypeSource = Internal ' The default ContentTypeSource is the registry '.ContentTypeSource = Registry ' Uncomment next two lines to use a global text file as the ' source of the authentication (i.e username and password) file ' If a directory has a htaccess.txt file, this global text file ' will be used for authentication, and the contents of the ' directories htaccess.txt file will be ignored '.AuthenticationSourceFile = App.Path & "\pswd_lst.txt" '.AuthenticationSource = GolbalFile ' Uncomment next line to use the the htaccess.txt file that ' exists within the target directory .AuthenticationSource = DirectoryFile ' The default AuthenticationSource is the registry (i.e. NT User List) '.AuthenticationSource = Registry End With End Sub Private Sub Form_Load() ' In the Demo App the timer interval is set to a small value ' for the purpose of iilusation. Normally, the value would be higher ' (e.g. 5000 or greater) in a production app. tmrStats.Interval = 1000 tmrStats.Enabled = False End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) ' Dim sResponse As String ' sResponse = MsgBox("Are you sure you want to exit?", vbYesNo, "Exit?") ' If sResponse = vbNo Then Cancel = 1 End Sub Private Sub Form_Unload(Cancel As Integer) ' Do NOT use END. It will not clean up properly. ' After setting classes, recordsets, etc. = nothing ' unload all the forms you have in the app. ' If the server is running, stop it If WebX1.ServerRunning = True Then tmrStats.Enabled = False WebX1.StopServer End If Unload Me End Sub '************************************************** ' Control Events '************************************************** Private Sub cmdExit_click() Unload Me End Sub Private Sub lblWebSite_Click() ' Click on web link label will execute shell command that ' will launch default browser Call ShellExecute(0&, vbNullString, lblWebSite.Caption, vbNullString, vbNullString, vbNormalFocus) End Sub Private Sub Option1_Click() ' Option1 has its TabIndex property = 0. This causes it to fire on ' Form_Load. Set it to another value to make startup of the web ' server engine a manual operation. 'On Error GoTo ERROR_W3 Option1.Enabled = False With WebX1 If .ServerRunning = False Then Option1.Caption = "Starting Server..." List1.Clear ' Some Server Setup .TrapFileTypes = "html" .VerboseErrorsEnable = False .CGIEnable = False .SSIEnable = False .HTMLFunctionsEnable = False .TrapFileEnable = False If chkVerboseErrors = vbChecked Then .VerboseErrorsEnable = True If chkCGI.Value = vbChecked Then .CGIEnable = True If chkSSI.Value = vbChecked Then .SSIEnable = True If chkHTMLFunc.Value = vbChecked Then .HTMLFunctionsEnable = True If chkTrap.Value = vbChecked Then .TrapFileEnable = True .MaxConnections = Val(txtMaxConn.Text) .ServerPort = Val(txtServerPort.Text) .StartServer tmrStats.Enabled = True Option1.Caption = "&Stop Server" Option1.ForeColor = vbRed ElseIf .ServerRunning = True Then Option1.Caption = "Stopping Server..." tmrStats.Enabled = False .StopServer Option1.Caption = "&Start Server" Option1.ForeColor = &H8000& Else ' End If End With Option1.Value = False Option1.Enabled = True Exit Sub ERROR_W3: If Err.Number = 10048 Then ' Address and port number are already used by another web sever MsgBox "There is another Web Server Port number you have " & vbCrLf & _ "specified. Please choose another HTTP Port." _ , vbOKOnly, "Error Starting Web Server" WebX1.StopServer With Option1 .Value = False .Caption = "&Start Server" .ForeColor = &H8000& .Enabled = True End With With txtServerPort .SetFocus .SelLength = Len(.Text) End With Else ' All other errors MsgBox "There has been an error. " & vbCrLf & vbCrLf & _ "Error Number = " & Err.Number & vbCrLf & _ "Error Description = " & Err.Description, vbCritical End If End Sub Private Sub tmrStats_Timer() ' Use with caution. On a busy system you do not want to poll the server ' more than really necessary. ' You probably do not want stats reporting to down the App On Error Resume Next With WebX1 If .ServerRunning = False Then tmrStats.Enabled = False Else lblUpTime = .Stats_UpTime lblReceived = .Stats_BytesReceived lblSent = .Stats_BytesSent lblSocketFree = .Stats_FreeConnections lblErrors = .Stats_Errors lblReqs = .Stats_Requests End If End With DoEvents End Sub '************************************************** ' WebX Events '************************************************** Private Sub WebX1_FileRequest(Index As Integer, FileName As String, UserAuthentication As String) 'Debug.Print WebX1.CGIValue(Index, "", vbCrLf) Debug.Print FileName 'Debug.Print UserAuthentication If UCase(FileName) = UCase("/trap.html") Then ' Send data back to Server Engine WebX1.TrapFileData Index, "A Trapped Page.", False Else WebX1.TrapFileData Index, "", True End If End Sub Private Sub WebX1_LogEvent(LogEvent As String) ' Log to a file or event log If chkEnableLB.Value = vbUnchecked Then Exit Sub If List1.ListCount > 1000 Then List1.Clear List1.AddItem Now & ": " & LogEvent List1.ListIndex = List1.ListCount - 1 End Sub Private Sub WebX1_StatusLine(Data As String) lblStatus = " " & Data End Sub Private Sub WebX1_HTTPLog(Data As String) ' The ListBox is used in this Demo App, but should not be used ' in production applications due to it relativly high CPU usage. ' Also, do not let the list get too big becuase things really ' slow down then. If chkEnableLB.Value = vbUnchecked Then Exit Sub If List1.ListCount > 1000 Then List1.Clear List1.AddItem Now & ": " & Data List1.ListIndex = List1.ListCount - 1 End Sub Private Sub WebX1_CallFunction(Index As Integer, FunctionName As String) ' Index - The connection number that requested the function. Index has to be ' passed back to WebX when using the .ReturnData method. ' sFunctionName - The name of the function called from HTML. ' sQueryString - The Query String passed to the page. You can also use ' .QueryStringCount and .QueryString to enumerate and ' retrieve individual values using WebX. On Error GoTo eh ' In the Demo App we use the Select statement to decide which function ' to call. This allows the Function name in the HTML to be different ' than the App function name. ' As seen below, "MyFunction" is the name of the function in HTML, but ' the name of the VB function actaully called is "TestFunction" Select Case FunctionName Case "MyFunction" WebX1.ReturnData Index, TestFunction() Case "MyBadFunction" WebX1.ReturnData Index, TestFunctionError() Case Else ' If the function does not exists, send something back, either "" ' or a message saying that the function was not found. This will ' depend if errors should be masked (hidden) from users, or if they ' should be exposed to the user. 'WebX1.ReturnData Index, "" WebX1.ReturnData Index, "Error: The Function Call failed. Function " & _ FunctionName & " was not found." End Select Exit Sub ' Remember we are sending back HTML WebX1.ReturnData Index, "There has been an error in Function " & FunctionName & "." & _ "<br><br>[Error Location: " & Err.Source & "]" & _ "[Error Number: " & Err.Number & "]" & _ "[Error Description: " & Err.Description & "]" End Sub Public Function TestFunction() ' Return some sample HTML, but this could really be anything. You could ' get some roWebX1 from a database, format them in a table and send them back. ' If you do format then, keep it simple, let as much of the 'flash' be written ' into in the HTML file. Note the use of line numbers to help in debugging. 10000 On Error GoTo eh 10001 Dim sTemp As String 10002 sTemp = "<font face=""Verdana"" size=""2"" font color=#FF0000>This is HTML that was called from the function TestFunction in the Test Application.</font>" & vbCrLf 10003 sTemp = sTemp & "<BR>" & vbCrLf '10004 sTemp = sTemp & "Passed String = " & sQS & vbCrLf 10005 sTemp = sTemp & "<BR>" & vbCrLf 'Uncomment to force an error for testing 10006 'sTemp = 4 / 0 10007 TestFunction = sTemp Exit Function Err.Raise Err.Number, "TestFunction::" & Erl, Err.Description End Function Public Function TestFunctionError() ' This is the same function TestFunction, but we are forcing an error to ' test error handling. 10000 On Error GoTo eh 10001 Dim sTemp As String 10002 sTemp = "<font face=""Verdana"" size=""2"" font color=#FF0000>This is HTML that was called from the function TestFunction in the Test Application.</font>" & vbCrLf 10003 sTemp = sTemp & "<BR>" & vbCrLf 10004 sTemp = sTemp & "Forcing an error here, to test Error Handling." & vbCrLf 10005 sTemp = sTemp & "<BR>" & vbCrLf 10006 sTemp = 4 / 0 10007 TestFunctionError = sTemp Exit Function Err.Raise Err.Number, "TestFunctionError::" & Erl, Err.Description End Function 
(.txt)