module1.bas

中日邮件短信网关

Attribute VB_Name = "Module1"
Option Explicit

' Shared variables
Global Server As String
Global Account As String
Global Password As String
Global AttachDir As String
Global MessageDir As String

Global MS As Integer

Global MailInLine() As String            '定义邮件接收队列动态数组
Global MailInCount As Integer            '定义邮件接收队列邮件数

Global MailOutLine() As String           '定义邮件发送队列动态数组
Global MailOutCount As Integer           '邮件发送队列邮件数

Global SMSOutLine() As String            '定义短信发送队列动态数组
Global SMSOutCount As Integer            '短信发送队列邮件数


Global Euserserver As String
Global Eusername As String
Global Euserpass As String




Global price As Single

Global Const APP_NAME = "PowerTCP POP Client"

Public Enum EnableType
    EN_ACTION
    EN_LOGGED_IN
    EN_LOGGED_OUT
End Enum


Public Function GetMessageFileName(ByVal s As String) As String
    s = Replace(s, "<", "")
    s = Replace(s, ">", "")
    s = Replace(s, "|", "")
    s = Replace(s, """", "")
    s = Replace(s, "'", "")
    s = Replace(s, "?", "")
    s = Replace(s, "*", "")
    s = Replace(s, "\", "")
    s = Replace(s, "/", "")
    If s = "" Then s = "Unknown." + CStr(Timer)
    GetMessageFileName = s
End Function

Public Function TranslateStatus(ByVal s As DartMailCtl.PopStatusConstants)
    Select Case s
        Case popBad
            TranslateStatus = "Bad"
        Case popContent
            TranslateStatus = "Content"
        Case popCount
            TranslateStatus = "Count"
        Case popDeleting
            TranslateStatus = "Delete"
        Case popPreview
            TranslateStatus = "Header"
        Case popInfo
            TranslateStatus = "Info"
        Case popOk
            TranslateStatus = "OK"
        Case popPreview
            TranslateStatus = "Preview"
        Case popSize
            TranslateStatus = "Size"
        Case popUidl
            TranslateStatus = "UIDL"
        Case Else
            TranslateStatus = "Unable to resolve: " & s
    End Select
End Function

Public Function TranslateCommand(ByVal c As DartMailCtl.PopMethodConstants)
    Select Case c
        Case popDelete
            TranslateCommand = "Delete"
        Case popGet
            TranslateCommand = "Get"
        Case popLogin
            TranslateCommand = "Login"
        Case popLogout
            TranslateCommand = "Logout"
        Case popReset
            TranslateCommand = "Reset"
        Case popCommand
            TranslateCommand = "Command"
        Case Else
            TranslateCommand = "Unable to resolve: " & c
    End Select
End Function
'解析邮件文件的目标邮件地址============================================================
Public Function Toaddress(str As String) As String
'该函数通过读取收到邮件的内容，判断哪里是邮件信息头，哪里是邮件数据，并将有用数据解析出来
'最后判断哪里是邮件结束，并将邮件内容保存至数据库
'用mailstatus来表示当前邮件正在处理哪个部分
'0=正在处理信息头 1=刚处理完信息头，还有数据要处理 2=只需要处理邮件是数据 3=邮件结束
  
    Dim LineStart  As Integer
    Dim LineEnd    As Integer
    Dim InfoStr    As String
   str = UCase(str)
   LineStart = InStr(15, str, "TO:", vbTextCompare)
   LineEnd = InStr(LineStart, str, vbCrLf)
     InfoStr = Trim(Mid(str, LineStart + 3, LineEnd - LineStart - 1))
   If InStr(1, InfoStr, "<") <> 0 And InStr(1, InfoStr, ">") <> 0 Then
     InfoStr = Trim(Mid(InfoStr, InStr(1, InfoStr, "<") + 1, InStr(1, InfoStr, ">") - InStr(1, InfoStr, "<") - 1))
   End If
   
   
   
   Toaddress = InfoStr
    
    
   
End Function
'解析邮件文件的from邮件地址============================================================
Public Function FromAddress(str As String) As String
'该函数通过读取收到邮件的内容，判断哪里是邮件信息头，哪里是邮件数据，并将有用数据解析出来
'最后判断哪里是邮件结束，并将邮件内容保存至数据库

  
    Dim LineStart  As Integer
    Dim LineEnd    As Integer
    Dim InfoStr    As String
   InfoStr = UCase(str)
   
   If InStr(1, InfoStr, "<") <> 0 And InStr(1, InfoStr, ">") <> 0 Then
     InfoStr = Trim(Mid(InfoStr, InStr(1, InfoStr, "<") + 1, InStr(1, InfoStr, ">") - InStr(1, InfoStr, "<") - 1))
   End If
   
   
   
   FromAddress = InfoStr
    
    
   
End Function
Function IsValidEmail(email As String) '判断email地址格式是否正确
 Dim names, name, i, c
 IsValidEmail = True
 names = Split(email, "@")
 If UBound(names) <> 1 Then
   IsValidEmail = False
   Exit Function
 End If
 For Each name In names
   If Len(name) <= 0 Then
     IsValidEmail = False
     Exit Function
   End If
   For i = 1 To Len(name)
     c = LCase(Mid(name, i, 1))
     If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
       IsValidEmail = False
       Exit Function
     End If
   Next
   If Left(name, 1) = "." Or Right(name, 1) = "." Then
      IsValidEmail = False
      Exit Function
   End If
 Next
 If InStr(names(1), ".") <= 0 Then
   IsValidEmail = False
   Exit Function
 End If
 i = Len(names(1)) - InStrRev(names(1), ".")
 If i <> 2 And i <> 3 Then
   IsValidEmail = False
   Exit Function
 End If
 If InStr(email, "..") > 0 Then
   IsValidEmail = False
 End If

End Function