frmmain.frm

VB实现的Web Server程序

         BackStyle       =   0  'Transparent
         BeginProperty Font 
            Name            =   "Arial"
            Size            =   9.75
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000D&
         Height          =   240
         Left            =   240
         MouseIcon       =   "frmMain.frx":0E46
         TabIndex        =   18
         Top             =   2640
         Width           =   60
      End
      Begin VB.Line Line4 
         BorderColor     =   &H00000000&
         X1              =   0
         X2              =   3720
         Y1              =   3120
         Y2              =   3120
      End
      Begin VB.Line Line3 
         BorderColor     =   &H00000000&
         X1              =   3720
         X2              =   3720
         Y1              =   3120
         Y2              =   -120
      End
      Begin VB.Line Line2 
         BorderColor     =   &H00FFFFFF&
         X1              =   3720
         X2              =   0
         Y1              =   0
         Y2              =   0
      End
      Begin VB.Line Line1 
         BorderColor     =   &H00FFFFFF&
         X1              =   0
         X2              =   0
         Y1              =   0
         Y2              =   3120
      End
   End
   Begin MSComctlLib.TabStrip TabStrip1 
      Height          =   3840
      Left            =   20
      TabIndex        =   0
      Top             =   20
      Width           =   4200
      _ExtentX        =   7408
      _ExtentY        =   6773
      MultiRow        =   -1  'True
      _Version        =   393216
      BeginProperty Tabs {1EFB6598-857C-11D1-B16A-00C0F0283628} 
         NumTabs         =   4
         BeginProperty Tab1 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "Server"
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab2 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "Active Objects"
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab3 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "Security"
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab4 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "Access"
            ImageVarType    =   2
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Verdana"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin MSWinsockLib.Winsock sckWS 
      Index           =   0
      Left            =   120
      Top             =   3960
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Image ServerOff 
      Height          =   240
      Left            =   2280
      Picture         =   "frmMain.frx":1150
      Top             =   3480
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image ServerOn 
      Height          =   240
      Left            =   2520
      Picture         =   "frmMain.frx":129A
      Top             =   3480
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Menu mnuTray 
      Caption         =   "&Tray"
      Visible         =   0   'False
      Begin VB.Menu mnuAbout 
         Caption         =   "&About"
      End
      Begin VB.Menu Sep3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuOptions 
         Caption         =   "Show S&erver"
      End
      Begin VB.Menu Sep2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuStart 
         Caption         =   "&Start"
      End
      Begin VB.Menu Sep1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "&Exit"
      End
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit 
         Caption         =   "&Exit"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "&About"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private requestedPage As String
Private strdata As String
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Sub cmdDirChoose_Click()
frmDirChoose.Show ownerform:=Me
frmMain.Enabled = False
End Sub
Private Sub cmdOK_Click()
If FileExists(AddASlash(txtRoot.Text)) = False Then
MsgBox "Please enter a valid path for Server Directory.", vbMsgBoxSetForeground + vbInformation
Exit Sub
End If
htmlPageDir = txtRoot.Text
Me.Hide
End Sub
Private Sub Command1_Click()
load_defaults
Command2.Visible = True
Command1.Visible = False
End Sub
Private Sub Command2_Click()
stop_server
Command1.Visible = True
Command2.Visible = False
End Sub


Private Sub Form_Load()

SendMessage Command1.hWnd, &HF4&, &H0&, 0&
SendMessage Command2.hWnd, &HF4&, &H0&, 0&
SendMessage cmdOK.hWnd, &HF4&, &H0&, 0&
SendMessage cmdDirChoose.hWnd, &HF4&, &H0&, 0&
Dim OS As OSVERSIONINFO
OS.dwOSVersionInfoSize = Len(OS)
GetVersionEx OS
If OS.dwMajorVersion < 4 Then
MsgBox "Sorry. You must have Windows 95, Windows 98, NT4 or later!", vbInformation, "Program closed!"
End
End If
If App.PrevInstance Then 'This checks if webserver is allready started
MsgBox "Sorry, but you have Webserver allready started.", vbMsgBoxSetForeground + vbInformation
End
End If
Left = Screen.Width \ 2 - Width \ 2
Top = Screen.Height \ 2 - Height \ 2
TakeOutMenu Me, SC_CLOSE ', SC_MOVE
gHW = Me.hWnd
myNID.cbSize = Len(myNID)
myNID.hWnd = gHW
myNID.uID = uID
myNID.uFlags = NIF_MESSAGE Or NIF_TIP Or NIF_ICON
myNID.uCallbackMessage = cbNotify
myNID.hIcon = ServerOff
myNID.szTip = "Server Inactive" & Chr(0)
ShellNotifyIcon NIM_ADD, myNID
Hook
SetWindowPos Me.hWnd, -1, 0, 0, 0, 0, 3
ttlConnections = 0 'Set the ttlConnections varible to zero. :)
Server.Caption = "Inactive"
If FileExists(AddASlash(App.Path) & "Webserver.ini") = True Then
Dim Cache As String
Files = FreeFile
Open AddASlash(App.Path) & "Webserver.ini" For Input As #Files
Do While Not EOF(Files)
Line Input #Files, Cache
If Mid(Chache, 1, 1) <> "[" Then
If Mid(Cache, 1, 10) = "ServerRoot" Then
If FileExists(AddASlash(Mid(Cache, 12, Len(Cache)))) = True Then
txtRoot.Text = Mid(Cache, 12, Len(Cache))
Else
txtRoot.Text = App.Path
End If
ElseIf Mid(Cache, 1, 7) = "Logging" Then
If Mid(Cache, 9, 1) = "1" Then
cheLogging.Value = 1
End If
ElseIf Mid(Cache, 1, 9) = "Guestbook" Then
If Mid(Cache, 11, 1) = "1" Then
cheGuest.Value = 1
End If
ElseIf Mid(Cache, 1, 7) = "Counter" Then
If Mid(Cache, 9, 1) = "1" Then
cheCounter.Value = 1
End If
ElseIf Mid(Cache, 1, 9) = "Minimized" Then
If Mid(Cache, 11, 1) = "1" Then
cheMinimized = 1
Me.Hide
End If
ElseIf Mid(Cache, 1, 11) = "TempOffline" Then
If Mid(Cache, 13, 1) = "1" Then
Check1.Value = 1
End If
ElseIf Mid(Cache, 1, 15) = "ActivateOnStart" Then
If Mid(Cache, 17, 1) = "1" Then
cheActivate.Value = 1
load_defaults
Command2.Visible = True
Command1.Visible = False
End If
End If
End If
Loop
Close #Files
Else
txtRoot.Text = App.Path
cheGuest.Value = 1
cheCounter.Value = 1
cheLogging.Value = 1
cheMinimized.Value = 0
cheActivate.Value = 0
End If
htmlPageDir = txtRoot.Text
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call stop_server
Files = FreeFile
Open AddASlash(App.Path) & "Webserver.ini" For Output As Files
Buffer = ""
Buffer = "[Webserver Options]" & vbCrLf
Buffer = Buffer & "ServerRoot=" & txtRoot.Text & vbCrLf
Buffer = Buffer & "Logging=" & cheLogging.Value & vbCrLf
Buffer = Buffer & "Guestbook=" & cheGuest.Value & vbCrLf
Buffer = Buffer & "Counter=" & cheCounter.Value & vbCrLf
Buffer = Buffer & "Minimized=" & cheMinimized & vbCrLf
Buffer = Buffer & "TempOffline=" & Check1.Value & vbCrLf
Buffer = Buffer & "ActivateOnStart=" & cheActivate.Value & vbCrLf
Print #Files, Buffer
Close #Files
SetWindowPos Me.hWnd, -2, 0, 0, 0, 0, 3
Unhook
ShellNotifyIcon NIM_DELETE, myNID
End Sub

Private Sub mnuAbout_Click()
frmAbout.Show ownerform:=Me
frmMain.Enabled = False
End Sub
Private Sub mnuExit_Click()
Unload Me
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub mnuHelpAbout_Click()
frmAbout.Show ownerform:=Me
frmMain.Enabled = False
End Sub
Private Sub mnuOptions_Click()
frmMain.Visible = True
AppActivate frmMain.Caption
End Sub
Private Sub mnuStart_Click()
If mnuStart.Caption = "&Start" Then
load_defaults
Command1.Visible = False
Command2.Visible = True
Else
stop_server
End If
End Sub
Private Sub sckWS_ConnectionRequest(Index As Integer, ByVal requestID As Long)
On Error Resume Next
If Index = 0 Then
If Check1.Value = 1 Then Exit Sub
If sckWS(ttlConnections).RemoteHostIP = "192.168.0.5" Then Exit Sub
ttlConnections = ttlConnections + 1  'add 1 to the total # of connections
numConnections = numConnections + 1 'number of connected clients + 1
If numConnections = maxConnections Then GoTo done 'if we've reached the max # of connections, exit sub.
Load sckWS(ttlConnections) 'load a new instance of sckWS.
sckWS(ttlConnections).LocalPort = 0 'set its local port to 0
sckWS(ttlConnections).Accept requestID 'Accept the connection request.
List1.AddItem sckWS(ttlConnections).RemoteHostIP & " Connected"
StartOver:
DoEvents 'DoEvents so it doesn't freeze while we wait.
If requestedPage$ = "" Then GoTo StartOver 'if we havent gotten the page request yet, go back to startOver.
List1.AddItem "Requested: " & requestedPage$
If cheLogging.Value = 1 Then
Logging = FreeFile      'This is for the logging function
Open AddASlash(App.Path) & "Log.log" For Append As #Logging
Print #Logging, Format(Date, "Long Date") & " " & Format(Time, "Long Time") & " ; " & sckWS(ttlConnections).RemoteHostIP & "; " & Mid(strdata$, InStr(1, UCase(strdata$), "USER-AGENT:") + 12, InStr(InStr(1, UCase(strdata$), "USER-AGENT:") + 12, UCase(strdata$), vbCrLf) - InStr(1, UCase(strdata$), "USER-AGENT:") - 12) & "; requested Language: " & Mid(strdata$, InStr(1, UCase(strdata$), "ACCEPT-LANGUAGE:") + 17, InStr(InStr(1, UCase(strdata$), "ACCEPT-LANGUAGE:") + 17, UCase(strdata$), vbCrLf) - InStr(1, UCase(strdata$), "ACCEPT-LANGUAGE:") - 17) & "; requested page: " & requestedPage$
Close #Logging
End If
If requestedPage$ = "/" Then
requestedPage$ = htmlIndexPage$ ' if the page '/' was requested, set requested page to the index html page.
Else
requestedPage$ = Mid(requestedPage$, 2, Len(requestedPage$) - 1)
End If
If cheGuest.Value = 1 Then
If UCase(requestedPage$) = "GUESTBOOK.CGI" Then 'This is check if the Guestbook.cgi is requested
NameStart = InStr(UCase(strdata$), "NAME=")
NameEnd = InStr(NameStart + 5, strdata$, "&")
NameValue = Mid$(strdata$, NameStart + 5, NameEnd - (NameStart + 5))
MailStart = InStr(UCase(strdata$), "E-MAIL=")
MailEnd = InStr(MailStart + 7, strdata$, "&")
MailValue = Mid$(strdata$, MailStart + 7, MailEnd - (MailStart + 7))
CommentStart = InStr(UCase(strdata$), "COMMENT=")
CommentEnd = InStr(CommentStart + 8, strdata$, "&")
CommentValue = Mid$(strdata$, CommentStart + 8, CommentEnd - (CommentStart + 8))
CommentValue = ReplaceStr(CommentValue, "+", " ")
CommentValue = ReplaceStr(CommentValue, "%0D%0A", "<br>")
CommentValue = ReplaceStr(CommentValue, "%21", "!")
CommentValue = ReplaceStr(CommentValue, "%22", "&quot;")
CommentValue = ReplaceStr(CommentValue, "%A7", "