 |
|
 |
JLRodgers
Level: Moderator
Registered: 04-04-2002
Posts: 1617
|
Re: E-Mail w/o Client
This is what was used at a company I worked at:
Class Module
'local variable(s) to hold property value(s)
'Just related to the SMTP code
Dim Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String, Ninth As String
Dim Start As Single, tmr As Single
Public Function SendEmail() As Boolean
'This is where we actually send the email.
'This form contains the Winsock control
'Validate the fields first.
'Don't want to start something that isn't going to work
If mvarFromName = Empty Then
mvarErrorMessage = "You must have a from name"
SendEmail = False
Exit Function
End If
If mvarFromEmailAddress = Empty Then
mvarErrorMessage = "You must have a from email address"
SendEmail = False
Exit Function
End If
If mvarToEmailAddress = Empty Then
mvarErrorMessage = "You must have a to email address"
SendEmail = False
Exit Function
End If
If mvarEmailSubject = Empty Then
mvarErrorMessage = "You must have a subject"
SendEmail = False
Exit Function
End If
If mvarEmailMessage = Empty Then
mvarErrorMessage = "You must have an actual message"
SendEmail = False
Exit Function
End If
Dim frmTemp As New frmInvisible
Load frmTemp
'Can leave blank if on network.
If mvarEmailServer = Empty Then
mvarEmailServer = "DEFAULT SERVER NAME"
End If
frmTemp.cmdSend_Click
ErrResponse = "In Progress"
Start = Timer ' Time Event so won't Get stuck In Loop
Do While ErrResponse = "In Progress"
tmr = Timer - Start
DoEvents ' Let System keep checking For incoming response **IMPORTANT**
If tmr > 100 Then Exit Do
Loop
If ErrResponse = True Then
SendEmail = True
ElseIf ErrResponse = False Then
SendEmail = False
End If
If SendEmail = False Then
If mvarErrorMessage = Empty Then
mvarErrorMessage = "An unexpected error occurred. Please check property values"
End If
End If
'Closing Form - TEST statements (07/12/00)
Unload frmTemp
Set frmTemp = Nothing
End Function
Public Property Let EmailMessage(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.EmailMessage = 5
mvarEmailMessage = vData
End Property
Public Property Get EmailMessage() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.EmailMessage
If IsObject(mvarEmailMessage) Then
Set EmailMessage = mvarEmailMessage
Else
EmailMessage = mvarEmailMessage
End If
End Property
Public Property Let EmailSubject(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.EmailSubject = 5
mvarEmailSubject = vData
End Property
Public Property Get EmailSubject() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.EmailSubject
EmailSubject = mvarEmailSubject
End Property
Public Property Let ToEmailAddress(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.ToEmailAddress = 5
mvarToEmailAddress = vData
End Property
Public Property Get ToEmailAddress() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.ToEmailAddress
If IsObject(mvarToEmailAddress) Then
Set ToEmailAddress = mvarToEmailAddress
Else
ToEmailAddress = mvarToEmailAddress
End If
End Property
Public Property Let FromEmailAddress(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.FromEmailAddress = 5
mvarFromEmailAddress = vData
End Property
Public Property Get FromEmailAddress() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.FromEmailAddress
If IsObject(mvarFromEmailAddress) Then
Set FromEmailAddress = mvarFromEmailAddress
Else
FromEmailAddress = mvarFromEmailAddress
End If
End Property
Public Property Let FromName(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.FromName = 5
mvarFromName = vData
End Property
Public Property Get FromName() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.FromName
If IsObject(mvarFromName) Then
Set FromName = mvarFromName
Else
FromName = mvarFromName
End If
End Property
Public Property Let EmailServer(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.EmailServer = 5
mvarEmailServer = vData
End Property
Public Property Get EmailServer() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.EmailServer
If IsObject(mvarEmailServer) Then
Set EmailServer = mvarEmailServer
Else
EmailServer = mvarEmailServer
End If
End Property
Public Property Get ErrorMessage() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.EmailSubject
ErrorMessage = mvarErrorMessage
End Property
Public Property Let FileAttachment(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.EmailSubject = 5
mvarAttachment = vData
End Property
Public Property Get FileAttachment() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.EmailSubject
FileAttachment = mvarAttachment
End Property
Sub WaitFor(ResponseCode As String)
Start = Timer ' Time Event so won't Get stuck In Loop
While Len(Response) = 0
tmr = Timer - Start
DoEvents ' Let System keep checking For incoming response **IMPORTANT**
If tmr > 50 Then ' Time In seconds To wait
'MsgBox "SMTP service error, timed out While waiting For response", 64, MsgTitle
Exit Sub
End If
Wend
While Left(Response, 3) <> ResponseCode
DoEvents
If tmr > 50 Then
'MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
Exit Sub
End If
Wend
Response = "" ' Sent response code To blank **IMPORTANT**
End Sub
|
Form (frmInvisible) - have a winsock control on it
Public Sub cmdSend_Click()
'
Dim i As Integer
'
If mvarAttachment <> Empty Then
m_strEncodedFiles = m_strEncodedFiles & _
UUEncodeFile(mvarAttachment) & vbCrLf
End If
Winsock1.Connect Trim$(mvarEmailServer), 25
m_State = mail_connect
'
End Sub
Private Sub Form_Load()
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim strServerResponse As String
Dim strResponseCode As String
Dim strDataToSend As String
'
'Retrive data from winsock buffer
'
Winsock1.GetData strServerResponse
'
Debug.Print strServerResponse
'
'Get server response code (first three symbols)
'
strResponseCode = Left(strServerResponse, 3)
'
'Only these three codes tell us that previous
'command accepted successfully and we can go on
'
If strResponseCode = "250" Or _
strResponseCode = "220" Or _
strResponseCode = "354" Then
Select Case m_State
Case mail_connect
'Change current state of the session
m_State = MAIL_HELO
'
'Remove blank spaces
strDataToSend = Trim$(mvarToEmailAddress)
'
'Retrieve mailbox name from e-mail address
strDataToSend = Left$(mvarToEmailAddress, _
InStr(1, mvarToEmailAddress, "@") - 1)
'Send HELO command to the server
Winsock1.SendData "HELO " & strDataToSend & vbCrLf
'
Debug.Print "HELO " & strDataToSend
'
Case MAIL_HELO
'
'Change current state of the session
m_State = MAIL_FROM
'
'Send MAIL FROM command to the server
Winsock1.SendData "MAIL FROM:" & Trim$(mvarFromName) & vbCrLf
'
Debug.Print "MAIL FROM:" & Trim$(mvarFromName)
'
Case MAIL_FROM
'
'Change current state of the session
m_State = MAIL_RCPTTO
'
'Send RCPT TO command to the server
Winsock1.SendData "RCPT TO:" & Trim$(mvarToEmailAddress) & vbCrLf
'
Debug.Print "RCPT TO:" & Trim$(mvarToEmailAddress)
'
Case MAIL_RCPTTO
'
'Change current state of the session
m_State = MAIL_DATA
'
'Send DATA command to the server
Winsock1.SendData "DATA" & vbCrLf
'
Debug.Print "DATA"
'
Case MAIL_DATA
'
'Change current state of the session
m_State = MAIL_DOT
'
'So now we are sending a message body
'Each line of text must be completed with
'linefeed symbol (Chr$(10) or vbLf) not with vbCrLf
'
'Send Subject line
Winsock1.SendData "Subject:" & mvarEmailSubject & vbLf & vbCrLf
'
Debug.Print "Subject:" & mvarEmailSubject
'
Dim varLines As Variant
Dim varLine As Variant
Dim strMessage As String
'
'Add atacchments
strMessage = mvarEmailMessage & vbCrLf & vbCrLf & m_strEncodedFiles
'clear memory
m_strEncodedFiles = ""
'Parse message to get lines (for VB6 only)
varLines = Split(strMessage, vbCrLf)
'clear memory
strMessage = ""
'
'Send each line of the message
For Each varLine In varLines
Winsock1.SendData CStr(varLine) & vbLf
'
Debug.Print CStr(varLine)
Next
'
'Send a dot symbol to inform server
'that sending of message comleted
Winsock1.SendData "." & vbCrLf
'
Debug.Print "."
'
Case MAIL_DOT
'Change current state of the session
m_State = MAIL_QUIT
'
'Send QUIT command to the server
Winsock1.SendData "QUIT" & vbCrLf
'
Debug.Print "QUIT"
Case MAIL_QUIT
'
'Close connection
Winsock1.Close
'
End Select
Else
'
'If we are here server replied with
'unacceptable respose code therefore we need
'close connection and inform user about problem
'
Winsock1.Close
'
If Not m_State = MAIL_QUIT Then
mvarErrorMessage = "SMTP Error: " & strServerResponse
ErrResponse = False
Else
ErrResponse = True
End If
'
End If
End Sub
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
WinSockErrorNumber = "Winsock Error number " & Number & vbCrLf & _
Description
End Sub
|
Module):
' /************
' * FOR MAIL *
' */**********
' Error structure used by the program
Type ErrorStructure
Location As String
Description As String
End Type
' Error structure used by the mail routine
Type ErrorMailStructure
Description As String
Source As String
Number As Single
End Type
' Mail Globals
Public Response As String
Public WinSockErrorNumber As Variant
Public m_State As SMTP_State
Public m_strEncodedFiles As String
Public Enum SMTP_State
mail_connect '= 0
MAIL_HELO '= 1
MAIL_FROM '= 2
MAIL_RCPTTO '= 3
MAIL_DATA '= 4
MAIL_DOT '= 5
MAIL_QUIT '= 6
End Enum
Public ErrResponse As Variant
'Class
Public mvarEmailServer As Variant 'local copy
Public mvarFromName As Variant 'local copy
Public mvarFromEmailAddress As Variant 'local copy
Public mvarToEmailAddress As Variant 'local copy
Public mvarEmailSubject As String 'local copy
Public mvarEmailMessage As Variant 'local copy
Public mvarErrorMessage As String 'local copy
Public mvarAttachment As String 'local copy
Public ErrorMail As ErrorMailStructure
' /************
' * END MAIL *
' */**********
Public Sub EMail(Optional ByVal sSubject As String, Optional ByVal sBody As String, Optional ByVal bError As Boolean, Optional ByVal sTo As String, Optional ByVal sName As String)
On Error Resume Next
If sTo = "" Then
sTo = "default to address"
End If
If sName = "" Then
sName = "name"
End If
If sBody = "" And sSubject <> "" Then
sBody = sSubject
End If
If Not bError Then
If sSubject = "" And sBody <> "" Then
If Len(sBody) >= 10 Then
sSubject = Left(sBody, 10)
Else
sSubject = sBody
End If
End If
Else
' Errormail is defined above
With ErrorMail
sSubject = sSubject & " " & _
.Description & " " & _
.Number & " " & _
.Source
End With
End If
DoEvents
' Where sUsername=the username
sBody = sBody & vbCrLf & "User: " & sUserName & vbCrLf & "Date: " & Date & vbCrLf & "Time: " & Time
Dim Mail As New clsSMTP
Set Mail = New clsSMTP
With Mail
.EmailMessage = sBody
DoEvents
.EmailSubject = sSubject
DoEvents
.FromEmailAddress = "fromaddress@domain.com"
DoEvents
.FromName = "From Name"
DoEvents
.ToEmailAddress = sTo
DoEvents
.SendEmail
DoEvents
End With
End Sub
|
____________________________
Everywhere's Local (classifieds, job postings, & more for everycity in the world - user entered)
|
|
04-11-2003 at 10:41 PM |
|
|
JLRodgers
Level: Moderator
Registered: 04-04-2002
Posts: 1617
|
Re: E-Mail w/o Client
Depends on how they're setup I think... The one at the company was setup to accept any connections (that were from local IPs)
____________________________
Everywhere's Local (classifieds, job postings, & more for everycity in the world - user entered)
|
|
06-11-2003 at 09:08 PM |
|
|
|
|
 |
|
