form1.frm

用VB编写的一个小程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Wap/GPRS 服务"
   ClientHeight    =   6030
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8985
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6030
   ScaleWidth      =   8985
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog cd1 
      Left            =   3360
      Top             =   2400
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command4 
      Caption         =   "获取 URL"
      Height          =   270
      Left            =   2625
      TabIndex        =   13
      Top             =   45
      Width           =   1005
   End
   Begin wapserver.Socket Client 
      Index           =   0
      Left            =   4365
      Top             =   705
      _ExtentX        =   741
      _ExtentY        =   741
   End
   Begin wapserver.Socket Socket1 
      Left            =   1440
      Top             =   -30
      _ExtentX        =   741
      _ExtentY        =   741
   End
   Begin VB.TextBox Text1 
      BackColor       =   &H8000000F&
      BorderStyle     =   0  'None
      ForeColor       =   &H00FF0000&
      Height          =   210
      Left            =   495
      TabIndex        =   11
      Text            =   "(obdaining)"
      Top             =   75
      Width           =   2115
   End
   Begin VB.CommandButton Command3 
      Caption         =   "停止"
      Height          =   315
      Left            =   7425
      TabIndex        =   9
      Top             =   5640
      Width           =   1005
   End
   Begin VB.Frame Frame2 
      Caption         =   "连接列表"
      Height          =   3285
      Left            =   6825
      TabIndex        =   5
      Top             =   315
      Width           =   1830
      Begin VB.CommandButton Command1 
         Caption         =   "客户端"
         Enabled         =   0   'False
         Height          =   330
         Left            =   120
         TabIndex        =   7
         Top             =   2880
         Width           =   1605
      End
      Begin VB.ListBox List1 
         Height          =   2580
         Left            =   90
         TabIndex        =   6
         Top             =   195
         Width           =   1650
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "文件索引"
      Height          =   5325
      Left            =   0
      TabIndex        =   0
      Top             =   315
      Width           =   6765
      Begin VB.CommandButton Command5 
         Caption         =   "保存配置"
         Height          =   315
         Left            =   4215
         TabIndex        =   16
         Top             =   4920
         Width           =   1035
      End
      Begin VB.PictureBox FileList 
         AutoRedraw      =   -1  'True
         BackColor       =   &H00FFFFFF&
         Height          =   4590
         Left            =   90
         OLEDropMode     =   1  'Manual
         Picture         =   "Form1.frx":0000
         ScaleHeight     =   302
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   436
         TabIndex        =   4
         Top             =   225
         Width           =   6600
         Begin VB.PictureBox Picture2 
            AutoRedraw      =   -1  'True
            AutoSize        =   -1  'True
            BackColor       =   &H00CC3300&
            BorderStyle     =   0  'None
            Height          =   480
            Left            =   1575
            ScaleHeight     =   32
            ScaleMode       =   3  'Pixel
            ScaleWidth      =   32
            TabIndex        =   15
            Top             =   2460
            Visible         =   0   'False
            Width           =   480
         End
         Begin VB.PictureBox Picture1 
            AutoRedraw      =   -1  'True
            AutoSize        =   -1  'True
            BorderStyle     =   0  'None
            Height          =   480
            Left            =   1575
            ScaleHeight     =   32
            ScaleMode       =   3  'Pixel
            ScaleWidth      =   32
            TabIndex        =   14
            Top             =   1965
            Visible         =   0   'False
            Width           =   480
         End
         Begin VB.PictureBox iconlist 
            AutoRedraw      =   -1  'True
            AutoSize        =   -1  'True
            BorderStyle     =   0  'None
            Height          =   1440
            Left            =   3165
            Picture         =   "Form1.frx":1EF8
            ScaleHeight     =   96
            ScaleMode       =   3  'Pixel
            ScaleWidth      =   128
            TabIndex        =   12
            Top             =   2370
            Visible         =   0   'False
            Width           =   1920
         End
      End
      Begin VB.CommandButton Command2 
         Caption         =   "添加文件"
         Height          =   315
         Index           =   0
         Left            =   450
         TabIndex        =   3
         Top             =   4920
         Width           =   1035
      End
      Begin VB.CommandButton Command2 
         Caption         =   "删除文件"
         Height          =   315
         Index           =   1
         Left            =   1695
         TabIndex        =   2
         Top             =   4920
         Width           =   1035
      End
      Begin VB.CommandButton Command2 
         Height          =   315
         Index           =   2
         Left            =   2940
         Picture         =   "Form1.frx":AF3A
         Style           =   1  'Graphical
         TabIndex        =   1
         Top             =   4920
         Width           =   1035
      End
   End
   Begin VB.Label Label2 
      Caption         =   "URL:"
      Height          =   195
      Left            =   15
      TabIndex        =   10
      Top             =   75
      Width           =   465
   End
   Begin VB.Label Label1 
      BorderStyle     =   1  'Fixed Single
      Caption         =   "状态: 激活"
      Height          =   270
      Left            =   15
      TabIndex        =   8
      Top             =   5670
      Width           =   7230
   End
   Begin VB.Menu mnuContext 
      Caption         =   "Context"
      Visible         =   0   'False
      Begin VB.Menu mnuPreviewItm 
         Caption         =   "预览"
      End
      Begin VB.Menu mnuContextItm 
         Caption         =   "删除"
         Index           =   0
      End
      Begin VB.Menu mnuContextItm 
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuContextItm 
         Caption         =   "索引设置"
         Index           =   3
      End
      Begin VB.Menu mnuContextItm 
         Caption         =   "设置为 404"
         Index           =   4
      End
      Begin VB.Menu mnuContextItm 
         Caption         =   "设置为 500"
         Index           =   5
      End
   End
   Begin VB.Menu mnuSetAs 
      Caption         =   "设置为"
      Visible         =   0   'False
      Begin VB.Menu mnuSetAsItm 
         Caption         =   "索引"
         Index           =   0
      End
      Begin VB.Menu mnuSetAsItm 
         Caption         =   "页面未找到"
         Index           =   1
      End
      Begin VB.Menu mnuSetAsItm 
         Caption         =   "页面服务器错误"
         Index           =   2
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Download by http://www.codefans.net
'Address already in use means that some instance of the program is
'Listening to port 80 try reopening VB
Private Const SRCCOPY As Long = &HCC0020
Private Const SRCAND As Long = &H8800C6
Private Const SRCINVERT As Long = &H660046
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, _
                                                      ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Type FileItems
 x As Integer
 y As Integer
 Icon As Byte
 text As String
 Path As String
 Special As Byte
End Type
   Const IconSpacingX& = 58 + 20
   Const IconSpacingY& = 58 + 20

Dim FileItem() As FileItems
Private Type ClientDataArrivals
    cData As String
    cCompleted As Boolean
End Type
Dim ClientDataArrival(100) As ClientDataArrivals
Dim CRC&
Dim SelectedFileIndex&
Dim bSent(100) As Boolean

Public Function GetFilePath(file As String) As String
  Dim i&
  On Error Resume Next
  For i = 0 To UBound(FileItem)
    If FileItem(i).text = file Then GetFilePath = FileItem(i).Path
  Next
End Function


Sub RenderFileList(Optional ExcludeX% = -1, Optional ExcludeY% = -1)
   Dim i&, txCapt$
   For i = 1 To UBound(FileItem)
     
       BitBlt Picture1.hdc, 0, 0, 32, 32, iconlist.hdc, FileItem(i).Icon * 32, 0, SRCCOPY
       AlphaBlend Picture1.hdc, 0, 0, 32, 32, Picture2.hdc, 0, 0, 32, 32, &H10000 * 128
       BitBlt Picture1.hdc, 0, 0, 32, 32, iconlist.hdc, FileItem(i).Icon * 32, 64, SRCAND
       
       
       BitBlt FileList.hdc, FileItem(i).x * IconSpacingX + 10 + IconSpacingX& / 2 - 16, FileItem(i).y * IconSpacingY + 10, 32, 32, iconlist.hdc, FileItem(i).Icon * 32, 32, SRCAND
       If ExcludeX = FileItem(i).x And ExcludeY = FileItem(i).y Then
         BitBlt FileList.hdc, FileItem(i).x * IconSpacingX + 10 + IconSpacingX& / 2 - 16, FileItem(i).y * IconSpacingY + 10, 32, 32, Picture1.hdc, 0, 0, SRCINVERT
       Else
         BitBlt FileList.hdc, FileItem(i).x * IconSpacingX + 10 + IconSpacingX& / 2 - 16, FileItem(i).y * IconSpacingY + 10, 32, 32, iconlist.hdc, FileItem(i).Icon * 32, 0, SRCINVERT
       End If
       txCapt = Mid(FileItem(i).text, 1, Len(FileItem(i).text) - 4)
       FileList.CurrentX = FileItem(i).x * IconSpacingX + 10 + (IconSpacingX - FileList.TextWidth(txCapt)) / 2
       If ExcludeX = FileItem(i).x And ExcludeY = FileItem(i).y Then AlphaBlend FileList.hdc, FileItem(i).x * IconSpacingX + 10 + (IconSpacingX - FileList.TextWidth(txCapt)) / 2 - 2, FileItem(i).y * IconSpacingY + 10 + 34, FileList.TextWidth(txCapt) + 4 + 2, FileList.TextHeight("|") + 2, Picture2.hdc, 0, 0, 32, 32, &H10000 * 128
       FileList.CurrentY = FileItem(i).y * IconSpacingY + 10 + 34
       FileList.Print txCapt
       
   Next
End Sub

Private Sub Client_ConnectionRequest(Index As Integer, ByVal requestID As Long)
  'THIS CODE REFFERS TO CLIENT(0) THAT IS ALWAYS LISTENING
  Dim DontCreateNewSocks As Boolean, AvailiableSockIndex As Integer
  'Sees if a loaded socks control is free. if so assigns request to that one, else it creates a new one
  For i = 1 To Client.Count - 1
     If Client(i).State = sckClosed Then
        DontCreateNewSocks = True
        AvailiableSockIndex = i
        Exit For
     End If
  Next i
  If DontCreateNewSocks = False Then
     AvailiableSockIndex = Client.Count
     Load Client(AvailiableSockIndex)
  End If
  Client(AvailiableSockIndex).Accept requestID
  
End Sub

Private Sub Client_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim a$, L&, Request$, DCrLfPos&, ContentLengthPos&, ContentLength&
Client(Index).GetData a
  
'''HERE WE CHECK IF THE REQUEST IS COMPLETE OR IS MISSING ANY PIECE'''
  If InStr(1, a, " ") <> 0 Then Request = Mid(a, 1, InStr(1, a, " ") - 1)
  
  If Request = "GET" Or Request = "POST" Or Request = "OPTION" Then
  'If it's a fresh request
     'Store the data-arrived to cData
     ClientDataArrival(Index).cData = a
     'Mark as incomplete (check will be preformed later to see if complete or not)
     ClientDataArrival(Index).cCompleted = False
  ElseIf ClientDataArrival(Index).cCompleted = False Then
  'If last data-arrived was incomplete then add to cData the current data-arrived
     ClientDataArrival(Index).cData = ClientDataArrival(Index).cData & a