sendmail.cls

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

Public Property Let Recipient(ByVal NewValue As String)

  ' save the new Property value

    utMail.sToAddr = Split(NewValue, psDelimiter)
    TrimWhiteSpace utMail.sToAddr
    ValidateAddress NewValue, ERR_INVALID_REC_EMAIL

End Property

Public Property Get RecipientDisplayName() As String

  ' return the Property value

    RecipientDisplayName = Join(utMail.sToDisplayName, psDelimiter)

End Property

Public Property Let RecipientDisplayName(ByVal NewValue As String)

  ' save the new Property value

    utMail.sToDisplayName = Split(NewValue, psDelimiter)
    TrimWhiteSpace utMail.sToDisplayName

End Property

Public Property Get ReplyToAddress() As String

  ' return the Property value

    ReplyToAddress = utMail.sReplyToAddr

End Property

Public Property Let ReplyToAddress(ByVal NewValue As String)

  ' save the new Property value

    utMail.sReplyToAddr = Trim$(NewValue)

End Property

Public Property Get POP3Host() As String

  ' return the Property value

    POP3Host = psPop3Host

End Property

Public Property Let POP3Host(NewValue As String)

  Dim bValid      As Boolean

    NewValue = Replace(NewValue, vbNullChar, vbNullString)

    ' validate the new host name...
    If Len(NewValue) Then
        Select Case etSMTPHostValidation

          Case VALIDATE_HOST_SYNTAX
            bValid = IsValidIPHost(NewValue)

          Case VALIDATE_HOST_PING
            bValid = Ping(NewValue)

          Case VALIDATE_HOST_DNS
            If GetIPAddress(NewValue) <> "" Then bValid = True

          Case Else
            bValid = True

        End Select
      Else
        bValid = True
    End If

    ' save the new Property value
    If bValid Then
        RegSave "Pop3Host", NewValue
        RemoveError ERR_INVALID_POP_HOST
        psPop3Host = NewValue
      Else
        AddError ERR_INVALID_POP_HOST
    End If

End Property

Public Property Get SMTPHost() As String

  ' return the Property value

    SMTPHost = psSMTPHost

End Property

Public Property Let SMTPHost(NewValue As String)

  Dim bValid      As Boolean

    NewValue = Replace(NewValue, vbNullChar, vbNullString)

    ' validate the new host name...
    If Len(NewValue) Then
        Select Case etSMTPHostValidation

          Case VALIDATE_HOST_SYNTAX
            bValid = IsValidIPHost(NewValue)

          Case VALIDATE_HOST_PING
            bValid = Ping(NewValue)

          Case VALIDATE_HOST_DNS
            If GetIPAddress(NewValue) <> "" Then bValid = True

          Case Else
            bValid = True

        End Select
      Else
        bValid = True
    End If

    ' save the new Property value
    If bValid Then
        RegSave "RemoteHost", NewValue
        RemoveError ERR_INVALID_HOST
        psSMTPHost = NewValue
      Else
        AddError ERR_INVALID_HOST
    End If

End Property

Public Property Get SMTPHostValidation() As VALIDATE_HOST_METHOD

  ' return the Property value

    SMTPHostValidation = etSMTPHostValidation

End Property

Public Property Let SMTPHostValidation(ByVal NewValue As VALIDATE_HOST_METHOD)

  ' save the new Property value

    etSMTPHostValidation = NewValue
    RegSave "SMTPHostValidation", Str$(NewValue)

    ' in case this is set after the host value is set
    If psSMTPHost <> "" Then SMTPHost = psSMTPHost

End Property

Public Property Get SMTPPort() As Long

  ' return the Property value

    SMTPPort = plSMTPPort

End Property

Public Property Let SMTPPort(ByVal NewValue As Long)

  ' save the new Property value

    If NewValue < 1 Or NewValue > 65535 Then
        AddError ERR_INVALID_PORT
      Else
        plSMTPPort = NewValue
        RegSave "RemotePort", Str$(NewValue)
        RemoveError ERR_INVALID_PORT
    End If

End Property

Public Property Get Subject() As String

  ' return the Property value

    Subject = utMail.sSubject

End Property

Public Property Let Subject(ByVal NewValue As String)

  ' save the new Property value

    utMail.sSubject = NewValue

End Property

Public Property Get UseAuthentication() As Boolean

  ' return the Property value

    UseAuthentication = pbUseAuthentication

End Property

Public Property Let UseAuthentication(ByVal NewValue As Boolean)

  ' save the new Property value

    pbUseAuthentication = NewValue
    RegSave "UseAuthentication", CStr(CLng(NewValue))

End Property

Public Property Get UsePopAuthentication() As Boolean

  ' return the Property value

    UsePopAuthentication = pbUsePopAuthentication

End Property

Public Property Let UsePopAuthentication(ByVal NewValue As Boolean)

  ' save the new Property value

    pbUsePopAuthentication = NewValue
    RegSave "UsePopAuthentication", CStr(CLng(NewValue))

End Property

Public Property Get Username() As String

  ' return the Property value

    Username = psUserName

End Property

Public Property Let Username(ByVal NewValue As String)

  ' save the new Property value

    psUserName = NewValue
    RegSave "Username", NewValue

End Property

' ******************************************************************************
' *      Class Methods                                                         *
' ******************************************************************************

Public Function Connect() As Boolean

  ' public version of ConnectToHost
  ' sets pbManualDisconnect flag so Send Sub
  ' will not disconnect when finished....

    pbManualDisconnect = True
    Connect = ConnectToHost

End Function

Public Sub Disconnect()

  ' public version of DisconnectFromHost
  ' clears pbManualDisconnect flag

    pbManualDisconnect = False
    DisconnectFromHost

End Sub

Public Function GetContentType(ByVal strFile As String, Optional strDefault As String = "application/octet-stream") As String

  ' ******************************************************************************
  '
  ' Synopsis:     Get the Content Type from the Registry.
  '
  ' Parameters:   strFile     - The filename to get the Content Type for
  '               strDefault  - The default data to return if nothing is found
  '
  ' Return:       The Content Type string
  '
  ' Description:
  ' The Content Type string for registered file extensions is located in
  ' the system registry, in the root key HKEY_CLASSES_ROOT. Open the registry
  ' key for the given file extension and read the 'Content Type' value. If the
  ' key and/or value are not found, assign a default value of
  ' 'application/octet-stream'
  '
  ' ******************************************************************************

  Dim hKey                As Long                 ' key handle
  Dim strBuff             As String               ' buffer for API to write to
  Dim lBuffLen            As Long                 ' lenght of API return string
  Dim lRet                As Long                 ' API return code
  Dim lValueType          As Long                 ' data type for retun value
  Dim iPtr                As Integer              ' scratch pointer
  Dim strValueName        As String               ' registry 'value name
  Dim strKeyName          As String               ' registry 'key name

    If bInEXE Then On Local Error GoTo ERR_GetContentType

    GetContentType = strDefault

    ' registry value name
    strValueName = "Content Type"

    ' get the passed in key name. We only want
    ' the file extension here e.g. .exe, .doc, etc.
    ' if an extension is not found, assign default
    ' value and return
    iPtr = InStrRev(strFile, ".")
    If iPtr Then
        strKeyName = Mid$(strFile, iPtr)
      Else
        Exit Function
    End If

    ' open the Registry key, if key not found, return the defaut value
    lRet = RegOpenKey(HKEY_CLASSES_ROOT, strKeyName, hKey)
    If lRet <> ERROR_SUCCESS Then Exit Function

    ' query the key value to get it's data type & length
    lRet = RegQueryValueEx(hKey, strValueName, 0&, lValueType, 0&, lBuffLen)

    ' should be type string...
    If lValueType = REG_SZ Then
        ' create a buffer & call the API again
        strBuff = String$(lBuffLen, " ")
        lRet = RegQueryValueEx(hKey, strValueName, 0&, lValueType, ByVal strBuff, lBuffLen)
        ' get the string value, drop the trailing '0'
        If lRet = ERROR_SUCCESS Then GetContentType = Left$(strBuff, lBuffLen - 1)
    End If

    ' close the key
    If hKey Then lRet = RegCloseKey(hKey)

Exit Function

ERR_GetContentType:

    If hKey Then lRet = RegCloseKey(hKey)
    GetContentType = strDefault

End Function

Public Function GetIPAddress(sHostName As String) As String

  ' Resolves host-name to an IP address (DNS)
  '
  ' THIS CODE IS BASED ON FUNCTIONS
  ' WITHIN RICHARD DEEMING'S IP UTILITIES:
  ' http://www.freevbcode.com

  Dim lpHost          As Long
  Dim HOST            As HostEnt
  Dim dwIPAddr        As Long
  Dim tmpIPAddr()     As Byte
  Dim I               As Integer
  Dim sIPAddr         As String

    ' init winsock api
    If Not SocketsInitialize() Then
        GetIPAddress = ""
        Exit Function
    End If

    ' if no name given, use local host
    If sHostName = "" Then sHostName = GetIPHost
    sHostName = Trim$(sHostName) & Chr$(0)

    ' call api
    lpHost = gethostbyname(sHostName)

    If lpHost Then
        ' extract the data...
        CopyMemory HOST, ByVal lpHost, Len(HOST)
        CopyMemory dwIPAddr, ByVal HOST.hAddrList, 4
        ReDim tmpIPAddr(1 To HOST.hLen)
        CopyMemory tmpIPAddr(1), ByVal dwIPAddr, HOST.hLen

        ' convert format
        For I = 1 To HOST.hLen
            sIPAddr = sIPAddr & tmpIPAddr(I) & "."
        Next I

        ' set the return value
        GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)

      Else
        WSAGetLastError
        GetIPAddress = ""