sendmail.cls

简单、实用、特别。 有很多不足之处

                    End If
                    Sleep (10)
                    DoEvents
                Loop
            Loop
        Next iCtr

        If bMimeMultiPart = True Then
            ' send the MIME closing boundry header
            'Sleep (20)
            sckMail.SendData "--" & strBoundry & "--" & vbCrLf
        End If

        ' Send the 'end of mail' string
        pbRequestAccepted = False
        .SendData "." & vbCrLf
        If Not WaitUntilTrue(pbRequestAccepted, plMessageTimeOut, True) Then Exit Sub

    End With

    ' send completion notifications...
    RaiseEvent Progress(100)
    RaiseEvent Status("Transmission Complete...")

    ' if the Public Function Connect() was called,
    ' stay connected to the host, otherwise disconnect
    If Not pbManualDisconnect Then DisconnectFromHost

    RaiseEvent SendSuccesful

Exit Sub

Err_Send:

    ' add the error to the error collection
    AddError Err.Description
    SendFail

End Sub

Public Sub shutdown()

  ' stub function, here to maintain binary
  ' compatibility with previous versions.

End Sub

' ******************************************************************************
' *      Private Class Functions                                               *
' ******************************************************************************

Private Sub AddError(ByVal ErrStr As String)

  ' add error string to the error collection

    On Local Error Resume Next
      pColErrors.Add ErrStr, ErrStr

End Sub

Private Function AddressStringToLong(ByVal tmp As String) As Long

  ' convert an ip address string to a long value
  '
  ' THIS CODE IS BASED ON FUNCTIONS
  ' WITHIN RICHARD DEEMING'S IP UTILITIES:
  ' http://www.freevbcode.com

  Dim sParts()    As String

    sParts = Split(tmp, ".")

    If UBound(sParts) <> 3 Then
        AddressStringToLong = 0
        Exit Function
    End If

    ' build the long value out of the
    ' hex of the extracted strings
    AddressStringToLong = Val("&H" & Right$("00" & Hex$(sParts(3)), 2) & _
                          Right$("00" & Hex$(sParts(2)), 2) & _
                          Right$("00" & Hex$(sParts(1)), 2) & _
                          Right$("00" & Hex$(sParts(0)), 2))

End Function

Private Function bInEXE() As Boolean

  ' ******************************************************************************
  '
  ' Synopsis:     Check if application is running in the VB IDE or stand alone EXE.
  '
  ' Parameters:   none
  '
  ' Return:       True if running in EXE, False if running in IDE
  '
  ' Description:
  '
  ' Debug.print 1/0 will error produce a divide by zero error if running in IDE.
  ' If running in exe debug.print statement will be ignored
  '
  ' ******************************************************************************

  ' modified version of Brian Gillham's code
  ' sample available at www.freevbcode.com

    On Local Error GoTo ErrorHandler

    Debug.Print 1 / 0                               ' this line will fail in the IDE
    bInEXE = True                                   ' this line will execute only in EXE or dll

Exit Function

ErrorHandler:

    bInEXE = False

End Function

Private Function ConnectToHost() As Boolean

  Dim iCtr            As Integer
  Dim sHello          As String

    If bInEXE Then On Local Error GoTo Connect_Error

    ' already connected?
    If sckMail.State = sckConnected Then
        ConnectToHost = True
        Exit Function
      ElseIf sckMail.State <> sckClosed Then
        sckMail.CloseSocket
    End If

    ' check the SMTP host
    If Len(psSMTPHost) = 0 Then
        psSMTPHost = MXQuery
        If Len(psSMTPHost) = 0 Then
            AddError ERR_INVALID_HOST
            Exit Function
        End If
    End If

    ' Pop3 Authentication first?
    If pbUsePopAuthentication Then
        RaiseEvent Status("Connecting to POP3 Server (" & Me.POP3Host & ")...")
        pbExitImmediately = False
        pbConnected = False
        pbPopAuthOk = False
        plPop3Status = 0
        If Len(psPop3Host) = 0 Then
            AddError ERR_INVALID_POP_HOST
            SendFail
            Exit Function
        End If
        ' open POP3 connection
        With sckMail
            .RemoteHost = psPop3Host
            .RemotePort = POP3_PORT
            For iCtr = 1 To plConnectRetry
                If .State <> sckConnected Then
                    If .State = sckClosed Then .Connect
                    If WaitUntilTrue(pbConnected, plConnectTimeout, False) Then Exit For
                    If pbExitImmediately Then Exit Function
                    If .State = sckError Then .CloseSocket
                  Else
                    pbConnected = True
                    Exit For
                End If
            Next iCtr
            ' data arival event responds automatically
            WaitUntilTrue pbPopAuthOk, plConnectTimeout, False
            .CloseSocket
        End With
        DoEvents
        If pbExitImmediately Then Exit Function
        RaiseEvent Status("POP3 Authentication Successful...")
    End If

    ' reset var's
    pbRequestAccepted = False
    pbDataOK = False
    pbAuthLoginSupported = False
    pbAuthMailFromOK = False
    pbAuthLoginSuccess = False
    pbExitImmediately = False
    ConnectToHost = False
    pbConnected = False

    ' open an SMTP session...
    With sckMail

        ' setup the port
        If .State <> sckClosed Then .CloseSocket
        .RemoteHost = psSMTPHost
        .RemotePort = plSMTPPort

        ' open a connection with the remote host
        ' try 'plConnectRetry' times before giving up
        RaiseEvent Status("Connecting to SMTP Server (" & Me.SMTPHost & ")...")
        For iCtr = 1 To plConnectRetry
            If .State <> sckConnected Then
                If .State = sckClosed Then .Connect
                If WaitUntilTrue(pbConnected, plConnectTimeout, False) Then Exit For
                If pbExitImmediately Then Exit Function
                If .State = sckError Then .CloseSocket
              Else
                pbConnected = True
                Exit For
            End If
        Next iCtr

        ' if the connect attempt failed, exit
        If Not pbConnected Or Not WaitUntilTrue(pbRequestAccepted, plConnectTimeout, False) Then
            Timeout
            Exit Function
        End If

        ' once a connection is established, say 'hello
        RaiseEvent Status("Initializing Communications...")
        pbRequestAccepted = False
        ' EHLO is the extended (ESMTP) hello command, HELO is the standard hello command
        If pbUseAuthentication Then sHello = "EHLO " Else sHello = "HELO "
        .SendData sHello & Mid$(utMail.sFromAddr, InStr(utMail.sFromAddr, "@") + 1) & vbCrLf
        If Not WaitUntilTrue(pbRequestAccepted, plConnectTimeout, True) Then Exit Function

        ' Login Authentication ...
        ' the 'EHLO" command will cause the host to send a list of supported extensions
        ' via a series of 250 replies, wait to see if 'Auth Logon' is listed. The Sub
        ' sckMail_DataArrival will set pbUseAuthentication = True if Auth Login is
        ' supported by the remote host. If it is supported, Sub sckMail_DataArrival will
        ' respond to the host's Username & Password requests (psUserName, psPassword).
        If pbUseAuthentication = True Then
            If WaitUntilTrue(pbAuthLoginSupported, 5, False) Then
                RaiseEvent Status("Sending Login Authentication...")
                .SendData "AUTH Login" & vbCrLf
                If WaitUntilTrue(pbAuthLoginSuccess, 5, False) Then
                    RaiseEvent Status("Host Login OK!")
                  Else
                    RaiseEvent Status("Host Login Failed!")
                    Exit Function
                End If
                If pbExitImmediately Then Exit Function
              Else
                RaiseEvent Status("Login Not Supported by Host, Continuing...")
            End If
        End If

    End With

    ConnectToHost = True

Connect_Error:

End Function

Private Function CText(sIn As String, Optional bAddQuotesIfNotConverted As Boolean = False) As String

  '   'B' or 'Q' encode an ASCII string, defined in RFC 2047...
  '   The "B" encoding is identical to the "BASE64" encoding defined by RFC 1521.
  '   The "Q" encoding is similar to the "Quoted-Printable" content-
  '   transfer-encoding defined in RFC 1521.  It is designed to allow text
  '   containing mostly ASCII characters to be decipherable on an ASCII
  '   terminal without decoding.

  '   perform both & return the smaller of the two

  Dim iPtr            As Integer
  Dim bNeedsEncoding  As Boolean
  Dim iMax            As Integer
  Dim sChr            As String
  Dim sLine           As String
  Dim sQCode          As String
  Dim sBCode          As String
  Dim bytTmp()        As Byte

    If bInEXE Then On Local Error GoTo Err_Qtext

    ' scan for 8bit characters
    bytTmp() = StrConv(sIn, vbFromUnicode)

    For iPtr = 0 To UBound(bytTmp)
        If bytTmp(iPtr) > 126 Then
            bNeedsEncoding = True
            Exit For
        End If
    Next iPtr

    If Not bNeedsEncoding Then
        If bAddQuotesIfNotConverted Then
            ' if its part of an address string it needs
            ' to be quoted if it's returned as plain text
            CText = """" & sIn & """"
          Else
            CText = sIn
        End If
        Exit Function
    End If

    ' Q encode
    iMax = 54
    For iPtr = 1 To Len(sIn)
        sChr = Mid$(sIn, iPtr, 1)
        Select Case Asc(sChr)
            ' pass printable ascii as is, except "=" "?" "_" " "
          Case 33 To 60, 62, 64 To 94, 96 To 126
            sLine = sLine & sChr
            ' convert space to underscore (for readability)
          Case 32
            sLine = sLine & "_"
            ' Q Code everything else
          Case Else
            sLine = sLine & "=" & Right$("00" & Hex$(Asc(sChr)), 2)
        End Select
        If Len(sLine) >= iMax Then
            sQCode = sQCode & Q_CODE_HDR & sLine & CODE_END
            If iPtr < Len(sIn) Then sQCode = sQCode & vbCrLf & vbTab
            sLine = ""
        End If
    Next iPtr
    sQCode = sQCode & Q_CODE_HDR & sLine & CODE_END

    ' B encode
    iMax = 42
    sLine = sIn
    Do While Len(sLine)
        ' encode a line, maximun lenght is 76 characters
        ' <header><base64encoded text><end><CrLf>
        sBCode = sBCode & B_CODE_HDR & EncodeBase64String(Mid$(sLine, 1, iMax))
        ' strip off the CrLf & add END_CODE , CrLF & Tab
        sBCode = Mid$(sBCode, 1, Len(sBCode) - 2) & CODE_END
        ' get ready for the next line
        sLine = Mid$(sLine, iMax + 1)
        If Len(sLine) Then sBCode = sBCode & vbCrLf & vbTab
    Loop

    If Len(sQCode) < Len(sBCode) Then
        CText = sQCode
      Else
        CText = sBCode
    End If

Exit Function

Err_Qtext:

    CText = sIn

End Function

Public Function DecodeBase64String(ByVal str2Decode As String) As String

  ' ******************************************************************************
  '
  ' Synopsis:     Decode a Base 64 string
  '
  ' Parameters:   str2Decode  - The base 64 encoded input string
  '
  ' Return:       decoded string
  '
  ' Description:
  ' Coerce 4 base 64 encoded bytes into 3 decoded bytes by converting 4, 6 bit
  ' values (0 to 63) into 3, 8 bit values. Transform the 8 bit value into its
  ' ascii character equivalent. Stop converting at the end of the input string
  ' or when the first '=' (equal sign) is encountered.
  '
  ' ******************************************************************************

  Dim lPtr            As Long
  Dim iValue          As Integer
  Dim iLen            As Integer
  Dim iCtr            As Integer
  Dim Bits(1 To 4)    As Byte
  Dim strDecode       As String

    ' for each 4 character group....
    For lPtr = 1 To Len(str2Decode) Step 4
        iLen = 4
        For iCtr = 0 To 3
            ' retrive the base 64 value, 4 at a time
            iValue = InStr(1, BASE64CHR, Mid$(str2Decode, lPtr + iCtr, 1), vbBinaryCompare)
            Select Case iValue
                ' A~Za~z0~9+/
              Case 1 To 64
                Bits(iCtr + 1) = iValue - 1
                ' =
              Case 65
                iLen = iCtr