POP服务器

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.UserControl UserControl1
   BackStyle       =   0  '透明
   ClientHeight    =   750
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   795
   ClipBehavior    =   0  '无
   ScaleHeight     =   750
   ScaleWidth      =   795
   Begin VB.FileListBox File2
      Height          =   270
      Left            =   360
      Pattern         =   "*.del"
      TabIndex        =   1
      Top             =   480
      Width           =   255
   End
   Begin VB.FileListBox File1
      Height          =   270
      Left            =   480
      Pattern         =   "*.mail"
      TabIndex        =   0
      Top             =   120
      Width           =   135
   End
   Begin MSWinsockLib.Winsock Winsock1
      Left            =   0
      Top             =   0
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
End
Attribute VB_Name = "UserControl1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Dim UserID As String 'Store the UserID
Dim Password As String 'Store the Password
Dim AcceptedId As Boolean 'Toggle betwen the accepting of UserID or Password
Dim SuccessLoging As Boolean 'User logged in Successfully
Dim UserCommand As String
Dim newu As String
Dim bye As Boolean
Dim gpit As Boolean
Dim send As Boolean
Dim froms As String
Dim toin As String
Dim data As Boolean
Dim strsss As String
Private Sub UserControl_Initialize()
    'Initialisation routine
    Winsock1.LocalPort = 110 'Set the telnet port
    Winsock1.Listen 'Set the server to listen for a client request
    UserID = ""
    Password = ""
    UserCommand = ""
    AcceptedId = False
    SuccessLoging = False
    bye = False
End Sub

Private Sub Winsock1_Close()
    'When user wants to close the telnet connection
   
    Winsock1.Close 'Close the telnet port
    Winsock1.LocalPort = 110
    Winsock1.Listen 'Listen for the new user
    'Initialisation of the telnet server variables
    UserID = ""
    Password = ""
    UserCommand = ""
    AcceptedId = False
    SuccessLoging = False
    bye = False
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
    'User wants to connect to the server
    If Winsock1.State <> sckClosed Then Winsock1.Close
    Winsock1.Accept requestID
    'Send him the accepted message and ask him to logon to the server
    Winsock1.SendData "+OK POP3服务器准备好了 " & vbCrLf
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim str1 As String
    Dim MyName As String
    Dim DirList() As String
    Dim DirPointer As Integer
    Dim ii As Integer
    Dim cc As String
    'User sending some information
   
    Winsock1.GetData str1 'Receive the input from the client
    'Check whether user had already had logged in OR not.
        If Asc(str1) = 13 And gpit = False And send = False Then
            If Len(UserCommand) < 5 Then
            cc = ""
            Else
            cc = Right(UserCommand, Len(UserCommand) - 5)
            End If
            Select Case UCase(Left(UserCommand, 4))
                Case "USER"
                    UserID = cc
                    If SuccessLoging = True Then SuccessLoging = False: Winsock1.SendData "+OK 已注销。" & vbCrLf
                    Winsock1.SendData "+OK 请输入""PASS 密码""" & vbCrLf

                Case "PASS"
                    Password = cc
                    If Logins(UserID, Password) Then
                    SuccessLoging = True
                    If LCase(UserID) = "admin" Then
                    Winsock1.SendData "+OK 欢迎管理员登陆。" & vbCrLf
                    Else
                    Winsock1.SendData "+OK 已登陆。" & vbCrLf
                    End If
                    Else
                    SuccessLoging = False
                    Password = ""
                    UserID = ""
                    Winsock1.SendData "-ERR 用户名或密码错误" & vbCrLf
                    End If
                Case "EXIT", "QUIT"
                    Winsock1.SendData "+OK 连接已断开。" & vbCrLf
                DELETEFILE (UserID)
                Case "NEWU"
                    newu = cc
                    Winsock1.SendData "+OK 输入：""NEWP 密码""" & vbCrLf
                Case "NEWP"
                    If newu = "" Or cc = "" Then
                    Winsock1.SendData "-ERR 用户名密码不能为空" & vbCrLf
                    Else
                    If (Dir(App.Path & "/data/" & newu, vbDirectory) = "") Then
                    CreateDirectory App.Path & "/data/" & newu
                    Open App.Path & "/data/" & newu & "/" & cc & ".pwd" For Output As #1
                    Close #1
                    Winsock1.SendData "+OK 注册成功！" & vbCrLf
                    Else
                    Winsock1.SendData "-ERR 用户名已存在！" & vbCrLf
                    End If
                    End If
                    newu = ""
                Case "NOOP"
                    Winsock1.SendData "+OK" & vbCrLf
                Case Else
                If SuccessLoging = True Then phps UCase(Left(UserCommand, 4)), cc, UserID Else Winsock1.SendData "-ERR 权限出错" & vbCrLf
            End Select
            'MsgBox UCase(Left(UserCommand, 4))
            UserCommand = ""
        ElseIf Asc(str1) = 13 And send = False Then
        gpits UserCommand
        UserCommand = ""
        ElseIf Asc(str1) = 13 Then
        senddatas UserCommand
        UserCommand = ""
        ElseIf Asc(str1) = 8 Then
        If Len(UserCommand) > 0 Then UserCommand = Left(UserCommand, Len(UserCommand) - 1)
        Else
            scc = "qwertyui oplkjhgfdsazxcvbnmQWERTYUIOPLKJHGFDSAZXCVBNM1234567890-=]/;;/.,!@#$%^&*()_+}{"":<>?'"
            If InStr(1, scc, str1) = 0 Then
            Else
            UserCommand = UserCommand & str1
            End If
            'Winsock1.SendData str1
        End If
End Sub

Private Sub Winsock1_SendComplete()
If bye Then Winsock1_Close
End Sub

Private Function Logins(User, Password)
If (Dir(App.Path & "/data/" & User & "/" & Password & ".pwd") = "") Then
Logins = False
Else
Logins = True
End If
End Function

'创建指定的目录(可以是多级目录)

Private Function CreateDirectorys(ByVal sDirectory As String) As Boolean
'创建指定的目录(可以是多级目录)，sDirectory:要创建的文件夹
On Error GoTo ErrHandle
Dim lngResult As Long
sDirectory = checkpaths(sDirectory)
lngResult = MakeSureDirectoryPathExists(sDirectory)
CreateDirectorys = IIf(lngResult = 0, False, True)
ErrHandle:
If Err <> 0 Then
CreateDirectorys = False
End If
End Function

Private Function checkpaths(ByVal sPath As String) As String
If Right$(sPath, 1) = "/" Then
checkpaths = sPath
Else
checkpaths = sPath & "/"
End If
End Function
 Private Function GetDirTotalBytes(CurrentPath As String, Optional i As Long) As Long
        Static totbyte     As Long
        Dim nI     As Integer, nDirectory       As Integer
        Dim sFileName     As String, sDirectoryList()       As String
        'Initial   totbyte,   if   it   is   not   the   Recursive   call   the   function
        If i <> 1 Then
              totbyte = 0
        End If
        'First   list   all   normal   files   in   this   directory
        sFileName = Dir(CurrentPath, vbNormal + vbHidden + vbReadOnly + vbSystem + vbArchive)
        Do While sFileName <> ""
              If Right(sFileName, 5) = ".mail" Then
              totbyte = totbyte + FileLen(CurrentPath + sFileName)
              End If
              sFileName = Dir
        Loop
        'Next   build   temporary   list   of   subdirectories
        sFileName = Dir(CurrentPath, vbDirectory)
          Do While sFileName <> ""
                'Ignore   current   and   parent   directories
                If sFileName <> "." And sFileName <> ".." Then
'                      Ignore nondirectories
                        If GetAttr(CurrentPath & sFileName) _
                                    And vbDirectory Then
                              nDirectory = nDirectory + 1
                              ReDim Preserve sDirectoryList(nDirectory)
                              sDirectoryList(nDirectory) = CurrentPath & sFileName
                        End If
                End If
                sFileName = Dir
            Loop
          'Recursively   process   each   directory
            For nI = 1 To nDirectory
                    GetDirTotalBytes sDirectoryList(nI) & "/", 1
            Next nI
            GetDirTotalBytes = totbyte
          End Function
Private Function DirUsedBytess(ByVal dirName As String) As Long
Dim FileName As String
Dim FileSize As Currency
If Right$(dirName, 1) <> "/" Then
dirName = dirName & "/"
End If
FileSize = 0
FileName = Dir$(dirName & "*.mail")
Do While FileName <> ""
FileSize = FileSize + _
FileLen(dirName & FileName)
FileName = Dir$
Loop
DirUsedBytess = FileSize
End Function

Private Function phps(Cmd, cc, User)
Dim str, str1, i
On Error GoTo xx
If User = "" Then Winsock1.SendData "-ERR 权限出错" & vbCrLf: Exit Function
File1.Path = App.Path & "/data/" & User & "/"
File1.Path = App.Path & "/data/" & User & "/mail/"
File2.Path = App.Path & "/data/" & User & "/"
File2.Path = App.Path & "/data/" & User & "/mail/"
Select Case Cmd
Case "STAT"
    Winsock1.SendData "+OK " & File1.ListCount & " " & GetDirTotalBytes(App.Path & "/data/" & User & "/mail/") & " Bytes" & vbCrLf
Case "RETR"
    On Error Resume Next
    Open App.Path & "/data/" & User & "/mail/" & cc & ".mail" For Input As #1
    While Not (EOF(1))
    Line Input #1, str1
    str = str & vbCrLf & str1
    Wend
    Winsock1.SendData "+OK" & str & vbCrLf & "." & vbCrLf
    Close #1
    On Error GoTo xx
Case "TOPS"
    On Error Resume Next
    Open App.Path & "/data/" & User & "/mail/" & Left(cc, InStr(1, cc, " ") - 1) & ".mail" For Input As #1
    For i = 1 To Right(cc, Len(cc) - InStr(1, cc, " "))
    If EOF(1) Then
    Winsock1.SendData "-ERR 出现错误 ：输入超出文件尾" & vbCrLf
    Close #1
    Exit Function
    End If
    Line Input #1, str1
    str = str & vbCrLf & str1
    Next
    Winsock1.SendData "+OK" & str & vbCrLf & "." & vbCrLf
    Close #1
    On Error GoTo xx
Case "GPIT"
    If LCase(User) = "admin" Then
    Winsock1.SendData "+OK" & vbCrLf & "-----管理目录-----" & vbCrLf
    gpit = True
    Else
    Winsock1.SendData "-ERR 权限出错" & vbCrLf
    End If
Case "SEND"
    send = True
    Winsock1.SendData "+OK 进入邮件发送模式。" & vbCrLf
Case "DELE"
    Name App.Path & "/data/" & User & "/mail/" & cc & ".mail" As App.Path & "/data/" & User & "/mail/" & cc & ".DEL"
    Winsock1.SendData "+OK 邮件已经删除。" & vbCrLf
Case "QDEL"
    DELETEFILE UserID
    bye = False
Case "REST"
    For i = 0 To File2.ListCount - 1
    Name App.Path & "/data/" & User & "/mail/" & File2.List(i) As App.Path & "/data/" & User & "/mail/" & Left(File2.List(i), Len(File2.List(i)) - 4) & ".mail"
    Next
    Winsock1.SendData "+OK 删除邮件已经恢复。" & vbCrLf
Case "UIDL"
    Winsock1.SendData "+OK" & vbCrLf
    For i = 0 To File1.ListCount - 1
    Winsock1.SendData i + 1 & " " & User & File1.List(i) & vbCrLf
    Next
    Winsock1.SendData "." & vbCrLf
Case "LIST"
    Winsock1.SendData "+OK" & vbCrLf
    For i = 0 To File1.ListCount - 1
    Winsock1.SendData Left(File1.List(i), Len(File1.List(i)) - 5) & " " & FileLen(App.Path & "/data/" & User & "/mail/" & File1.List(i)) & vbCrLf
    Next
    Winsock1.SendData "." & vbCrLf
Case Else
    Winsock1.SendData "-ERR 命令无效！" & vbCrLf
End Select
Exit Function
xx:
    Winsock1.SendData "-ERR 出现错误 ：" & Err.Description & vbCrLf
End Function

Private Function DELETEFILE(User)
Dim i
If User <> "" And SuccessLoging = True Then
    Dim s
    File2.Path = App.Path & "/data/" & User & "/"
    File2.Path = App.Path & "/data/" & User & "/mail/"
    s = File2.ListCount
    For i = 0 To File2.ListCount - 1
    Kill App.Path & "/data/" & User & "/mail/" & File2.List(0)
    File2.Path = App.Path & "/data/" & User & "/"
    File2.Path = App.Path & "/data/" & User & "/mail/"
    Next
    bye = True
    Winsock1.SendData "+OK 删除邮件 " & s & " 个" & vbCrLf
    Else
    bye = True
End If

End Function
Private Function gpits(Cmd As String)
Select Case UCase(Left(Cmd, 4))
Case "QUIT", "EXIT"
Winsock1.SendData "+OK 退出管理模式。" & vbCrLf
gpit = False
Case Else
Winsock1.SendData "-ERR 对不起,命令不存在。" & vbCrLf
End Select
'Winsock1.SendData Cmd
End Function
Private Function senddatas(Cmd As String)
On Error Resume Next
If data = False Then
Dim cc
If Len(Cmd) < 5 Then cc = "" Else cc = Right(Cmd, Len(Cmd) - 5)
Select Case UCase(Left(Cmd, 4))
Case "QUIT", "EXIT"
Winsock1.SendData "+OK 退出邮件发送模式。" & vbCrLf
send = False
Case "FROM"
froms = cc
Winsock1.SendData "+OK FROM:<" & cc & ">" & vbCrLf
Case "INTO"
toin = cc
Winsock1.SendData "+OK TO:<" & cc & ">" & vbCrLf
Case "DATA"
If froms = "" Then froms = UserID
Winsock1.SendData "+OK 输入内容，以<CR><LF>.<CR><LF>(<CR><LF>就是回车)结束。" & vbCrLf
data = True
Case Else
Winsock1.SendData "-ERR 对不起,命令不存在。" & vbCrLf
End Select
Else
If Cmd = "." Then
'Winsock1.SendData App.Path & "/data/" & toin & "/mail/" & froms & Time & ".mail"
i = FreeFile
Open App.Path & "/data/" & toin & "/mail/" & Replace(Date, "/", "-") & Replace(Time, ":", ",") & ".mail" For Output As #i
Print #i, "From:<" & froms & ">" & vbCrLf & Left(strsss, Len(strsss) - 1)
Close #i
If Err.Number = 0 Then
Winsock1.SendData "+OK 邮件发送成功：从。" & froms & "到" & toin & "。" & vbCrLf
Else
Winsock1.SendData "-ERR 出现错误：" & Err.Description & "。" & vbCrLf
End If
strsss = ""
data = False
froms = ""
toin = ""
Else
strsss = strsss & Cmd & vbCrLf
End If
End If
End Function