?? 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
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -