sendmail.cls

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

    End If

    SocketsCleanup

End Function

Public Function GetIPHost() As String

  ' Resolves the local host name
  '
  ' THIS CODE IS BASED ON FUNCTIONS
  ' WITHIN RICHARD DEEMING'S IP UTILITIES:
  ' http://www.freevbcode.com

  Dim sHostName   As String
  Dim iPtr        As Integer

    ' create a buffer
    sHostName = String$(256, Chr$(0))

    ' init winsock api
    If Not SocketsInitialize() Then Exit Function

    ' get the loacal hosts name
    If gethostname(sHostName, Len(sHostName)) = ERROR_SUCCESS Then
        iPtr = InStr(sHostName, Chr$(0))
        If iPtr > 1 Then GetIPHost = Mid$(sHostName, 1, iPtr - 1)
    End If

    SocketsCleanup

End Function

Public Function IsValidEmailAddress(AddressString As String)  ' As Boolean

  Dim sTmp()      As String

    ' assume failure
    IsValidEmailAddress = False

    ' sould have one "@"
    sTmp = Split(AddressString, "@")
    If UBound(sTmp) <> 1 Then Exit Function

    IsValidEmailAddress = IsValidIPHost(sTmp(1))

End Function

Public Function MXQuery(Optional IPDomain As String = "") As String

  Dim sDomain     As String

    ' return the best server found in an MX Query

    If bInEXE Then On Local Error GoTo Err_MXQuery

    sDomain = Trim$(IPDomain)

    If Len(sDomain) Then
        RaiseEvent Status("Performing MX Query, Domain: " & sDomain)
      Else
        RaiseEvent Status("Performing MX Query")
    End If

    MXQuery = MX_Query(sDomain)

Exit Function

Err_MXQuery:

    MXQuery = vbNullString
    RaiseEvent Status(Err.Description)

End Function

Public Function Ping(Address As String, _
                     Optional RoundTripTime As String = "", _
                     Optional DataSize As String = "", _
                     Optional DataMatch As Boolean = False) As Boolean

  ' Ping a remote host
  '
  ' THIS CODE IS BASED ON FUNCTIONS
  ' WITHIN RICHARD DEEMING'S IP UTILITIES:
  ' http://www.freevbcode.com

  Dim ECHO            As ICMP_ECHO_REPLY
  Dim iPtr            As Integer
  Dim Dt              As String
  Dim sAddress        As String
  Dim hPort           As Long
  Dim lAddress        As Long
  Dim bytAddr(3)      As Byte

    If bInEXE Then On Local Error GoTo DPErr

    ' assume failure
    Ping = False

    ' if passed a name, get the IP address
    If Not IsDottedQuad(Address) Then
        sAddress = GetIPAddress(Address)
      Else
        sAddress = Address
    End If

    If sAddress = "" Then Exit Function

    If SocketsInitialize Then

        ' build string of random characters
        For iPtr = 1 To DATA_SIZE
            Dt = Dt & Chr$(Rnd() * 254 + 1)
        Next iPtr

        ' ping an ip address, passing the
        ' address and the ECHO structure
        lAddress = AddressStringToLong(sAddress)
        hPort = IcmpCreateFile()
        IcmpSendEcho hPort, lAddress, Dt, Len(Dt), 0, ECHO, Len(ECHO), PING_TIMEOUT
        IcmpCloseHandle hPort

        ' get the results from the ECHO structure
        RoundTripTime = ECHO.RoundTripTime
        CopyMemory bytAddr(0), ECHO.Address, 4
        Address = CStr(bytAddr(0)) & "." & _
                  CStr(bytAddr(1)) & "." & _
                  CStr(bytAddr(2)) & "." & _
                  CStr(bytAddr(3))

        DataSize = ECHO.DataSize & " bytes"

        iPtr = InStr(ECHO.Data, Chr$(0))
        If iPtr > 1 Then DataMatch = (Left$(ECHO.Data, iPtr - 1) = Dt)
        If ECHO.Status = 0 And ECHO.Address = lAddress Then Ping = True

        SocketsCleanup

    End If

Exit Function

DPErr:

End Function

Public Sub send()

  Dim sSenderName         As String
  Dim sToHeader           As String
  Dim sCcHeader           As String
  Dim iCtr                As Integer
  Dim sAuth               As String
  Dim sTxt                As String
  Dim strBoundry          As String
  Dim bMimeMultiPart      As Boolean
  Dim fStart              As Single
  Dim fTimeOut            As Single
  Dim lSendBuffSize       As Long
  Dim bRelatedLinks       As Boolean

    ' general catch all error handler only
    ' works when running in stand alone EXE
    If bInEXE Then On Local Error GoTo Err_Send

    ' check for multipart MIME
    If etEncodeType = MIME_ENCODE And utMail.lAttachCount > 0 Then
        bMimeMultiPart = True
      Else
        bMimeMultiPart = False
    End If

    ' check sender
    If Len(utMail.sFromAddr) = 0 Then AddError ERR_INVALID_SND_EMAIL

    ' HTML & UU Encode are mutually exclusive
    If pbHtmlText = True And etEncodeType = UU_ENCODE Then AddError ERR_HTML_REQUIRES_MIME

    ' check recipient count
    If UBound(utMail.sToAddr) + UBound(utMail.sCcAddr) + UBound(utMail.sBccAddr) = -3 Then AddError ERR_NO_REC_EMAIL
    If UBound(utMail.sToAddr) + UBound(utMail.sCcAddr) + UBound(utMail.sBccAddr) + 3 > MAX_RECIPIENTS Then AddError ERR_RECIPIENT_COUNT

    ' resize the display name arrays to match the recipient arrays
    iCtr = UBound(utMail.sToAddr)
    If iCtr >= 0 Then ReDim Preserve utMail.sToDisplayName(iCtr)
    iCtr = UBound(utMail.sCcAddr)
    If iCtr >= 0 Then ReDim Preserve utMail.sCcDisplayName(iCtr)

    ' we won't try to send if there's already an error
    If pColErrors.Count > 0 Then
        SendFail
        Exit Sub
    End If

    ' get the Content-Location for any linked objects
    If utMail.lAttachCount Then bRelatedLinks = GetAttachCID

    ' get the mail size
    plMailSize = EstimateMailSize

    ' this flag gets set when a socket error occurs or the host cannot process an
    ' input command, see 'SendFail', 'sckMail_DataArrival' & 'WaitUntilTrue' Subs
    pbExitImmediately = False

    With sckMail

        ' if not already conected then connect to the remote host
        If .State <> sckConnected Then
            If Not ConnectToHost Then Exit Sub
        End If

        ' reset the progress counter
        plBytesSent = 0

        ' tell the host who the mail is 'From
        RaiseEvent Status("Sending Sender Information...")
        pbRequestAccepted = False
        If pbAuthMailFromOK Then sAuth = " AUTH=" & utMail.sFromAddr Else sAuth = vbNullString
        .SendData "MAIL FROM: <" & utMail.sFromAddr & ">" & sAuth & vbCrLf
        If Not WaitUntilTrue(pbRequestAccepted, plMessageTimeOut, True) Then Exit Sub
        If pbExitImmediately Then Exit Sub

        ' tell the host who the recipients are
        ' build the 'To:' header string 'sToHeader' too
        RaiseEvent Status("Sending Recipient Information...")
        For iCtr = 0 To UBound(utMail.sToAddr)
            ' send the recipient address & wait for a reply
            pbRequestAccepted = False
            .SendData "RCPT TO: <" & utMail.sToAddr(iCtr) & ">" & vbCrLf
            If Not WaitUntilTrue(pbRequestAccepted, plMessageTimeOut, True) Then Exit Sub
            If pbExitImmediately Then Exit Sub

            ' build the 'To:' header string for later...
            If Len(utMail.sToDisplayName(iCtr)) Then
                sToHeader = sToHeader & CText(utMail.sToDisplayName(iCtr), True)
              Else
                sToHeader = sToHeader & """" & Trim$(utMail.sToAddr(iCtr)) & """"
            End If
            sToHeader = sToHeader & " <" & utMail.sToAddr(iCtr) & ">"
            If iCtr < UBound(utMail.sToAddr) Then sToHeader = sToHeader & ", " & vbCrLf & vbTab
        Next iCtr

        ' send Cc: recipient addresses (just more 'RCPT TO' addresses)
        ' build the 'Cc:' header string too
        For iCtr = 0 To UBound(utMail.sCcAddr)
            ' send the recipient address & wait for a reply
            pbRequestAccepted = False
            .SendData "RCPT TO: <" & utMail.sCcAddr(iCtr) & ">" & vbCrLf
            If Not WaitUntilTrue(pbRequestAccepted, plMessageTimeOut, True) Then Exit Sub
            If pbExitImmediately Then Exit Sub

            ' build the 'Cc:' header string for later...
            If Len(utMail.sCcDisplayName(iCtr)) Then
                sCcHeader = sCcHeader & CText(utMail.sCcDisplayName(iCtr), True)
              Else
                sCcHeader = sCcHeader & """" & Trim$(utMail.sCcAddr(iCtr)) & """"
            End If

            sCcHeader = sCcHeader & " <" & utMail.sCcAddr(iCtr) & ">"
            If iCtr < UBound(utMail.sCcAddr) Then sCcHeader = sCcHeader & ", " & vbCrLf & vbTab
        Next iCtr

        ' send Bcc: recipient addresses (more of the same)
        ' no display headers here, these are blind
        For iCtr = 0 To UBound(utMail.sBccAddr)
            ' send the recipient address & wait for a reply
            pbRequestAccepted = False
            .SendData "RCPT TO: <" & Trim$(utMail.sBccAddr(iCtr)) & ">" & vbCrLf
            If Not WaitUntilTrue(pbRequestAccepted, plMessageTimeOut, True) Then Exit Sub
            If pbExitImmediately Then Exit Sub
        Next iCtr

        ' tell the remote host we're ready to send data
        RaiseEvent Status("Sending Message...")
        pbDataOK = False
        .SendData "DATA" & vbCrLf
        If Not WaitUntilTrue(pbDataOK, plMessageTimeOut, True) Then Exit Sub
        If pbExitImmediately Then Exit Sub

        ' OK, the host is ready for data, this is where the mail message starts
        ' Send the mail headers (the ones displayed on the target email client)
        pbRequestAccepted = False

        ' from, to, cc & subject headers..
        If Len(Trim$(utMail.sFromDisplayName)) Then
            sSenderName = CText(utMail.sFromDisplayName, True)
          Else
            sSenderName = """" & utMail.sFromAddr & """"
        End If
        sSenderName = sSenderName & " <" & utMail.sFromAddr & ">"
        .SendData "From: " & sSenderName & vbCrLf
        .SendData "To: " & sToHeader & vbCrLf
        If Len(sCcHeader) Then .SendData "Cc: " & sCcHeader & vbCrLf
        .SendData "Subject: " & CText(utMail.sSubject) & vbCrLf
        If Len(utMail.sReplyToAddr) Then .SendData "Reply-to: <" & utMail.sReplyToAddr & ">" & vbCrLf
        ' send English foramted date/time string
        .SendData "Date: " & psDay(Weekday(Now)) & ", " & Day(Now) & " " & psMonth(Month(Now)) & _
                  Format$(Now, " yyyy hh:nn:ss ") & psTimeZoneBias & vbCrLf

        ' MIME headers...
        If etEncodeType = MIME_ENCODE Then
            ' create a Unique-Boundary string for multi-part MIME encoding
            strBoundry = "----_=_NextPart_000_" & Right$("00000000" & Hex$(Date), 8) & "." & Right$("00000000" & Hex$(CLng(Time * 10 ^ 8)), 8)
            
            .SendData "MIME-Version: 1.0" & vbCrLf
            If etPriority <> NORMAL_PRIORITY Then
                .SendData "X-Priority: " & Trim$(Str$(etPriority)) & vbCrLf
                .SendData "X-MSMail-Priority: " & psPriority & vbCrLf
            End If
            If pbReceipt Then .SendData "Disposition-Notification-To: " & sSenderName & vbCrLf
            ' if it's multi part send the boundry info
            If bMimeMultiPart Then
                If bRelatedLinks Then
                    .SendData "Content-Type: multipart/related;" & vbCrLf
                  Else
                    .SendData "Content-Type: multipart/mixed;" & vbCrLf
                End If
                .SendData vbTab & "boundary=" & """" & strBoundry & """" & vbCrLf & vbCrLf
                .SendData "This is a multi-part message in MIME format." & vbCrLf & vbCrLf
                ' send the MIME boundry and content headers for the message body
                .SendData "--" & strBoundry & vbCrLf
            End If
            ' plain or html text...
            If pbHtmlText Then sTxt = "text/html;" Else sTxt = "text/plain;"
            .SendData "Content-Type: " & sTxt & vbCrLf
            .SendData vbTab & "charset=" & """" & CHAR_SET & """" & vbCrLf
            If pb8BitMail Then sTxt = "8bit" Else sTxt = "7bit"
            .SendData "Content-Transfer-Encoding: " & sTxt & vbCrLf
            ' if we're sending html & the user supplied the content base then send it too
            If pbHtmlText Then If Len(psContentBase) Then .SendData "Content-Base: " & """" & psContentBase & """" & vbCrLf
        End If

        .SendData vbCrLf & vbCrLf

        ' Send the message body
        .SendData utMail.sMailMessage & vbCrLf & vbCrLf & vbCrLf

        ' Send attachments, if any...
        For iCtr = 0 To utMail.lAttachCount - 1
            If utMail.bAttachCID(iCtr) Then
                RaiseEvent Status("Sending Embedded File, " & utMail.sAttachNameOnly(iCtr) & "...")
              Else
                RaiseEvent Status("Sending Attachment, " & utMail.sAttachNameOnly(iCtr) & "...")
            End If
            If etEncodeType = MIME_ENCODE Then
                ' send the next MIME boundry & content headers
                .SendData "--" & strBoundry & vbCrLf
                .SendData "Content-Type: " & GetContentType(utMail.sAttachNameOnly(iCtr)) & ";" & vbCrLf
                .SendData vbTab & "name=" & """" & utMail.sAttachNameOnly(iCtr) & """" & vbCrLf
                .SendData "Content-Transfer-Encoding: base64" & vbCrLf
                .SendData "Content-Disposition: attachment;" & vbCrLf
                .SendData vbTab & "filename=" & """" & utMail.sAttachNameOnly(iCtr) & """" & vbCrLf
                If (bRelatedLinks And utMail.bAttachCID(iCtr)) Then
                    .SendData "Content-ID: <" & utMail.sAttachNameOnly(iCtr) & ">" & vbCrLf
                End If
                .SendData vbCrLf
                ' send the encoded file
                EncodeAndSendFile utMail.sAttachment(iCtr), MIME_ENCODE
                If pbExitImmediately Then Exit Sub
                .SendData vbCrLf
              Else
                ' start a UUEncode session
                .SendData "begin 600 " & utMail.sAttachNameOnly(iCtr) & vbCrLf
                ' send the encoded file
                EncodeAndSendFile utMail.sAttachment(iCtr), UU_ENCODE
                If pbExitImmediately Then Exit Sub
                ' send the ending sequence
                .SendData "end" & vbCrLf
            End If

            ' the sckMail Send buffer now holds the current file
            ' if its a large file, wait here for the buffer to
            ' empty before loading the next one
            Do While plBytesRemaining > 4096
                ' timeout code...
                fStart = Timer
                ' Deal with timer being reset at Midnight
                If fStart + plMessageTimeOut < 86400 Then
                    fTimeOut = fStart + plMessageTimeOut
                  Else
                    fTimeOut = (fStart - 86400) + plMessageTimeOut
                End If
                ' wait for a change in the send buffer
                ' if it's changing, everything is OK
                lSendBuffSize = plBytesRemaining
                Do Until lSendBuffSize <> plBytesRemaining
                    If plBytesRemaining < 4096 Then Exit Do
                    If Timer >= fTimeOut Then
                        Timeout
                        Exit Sub