'***********************************************************************
' GENERAL
'Modul ismi : clsSMTPSendMail
'***********************************************************************
'Aciklama : SMTP sunucusu uzerinden mail gondermek,
' UUEncode algoritmasi
'Yazan : Levent YILDIZ
'Sirket :
'Tarih : 21.08.2003
'Notlar :
'***********************************************************************
' PUBLIC SUBS
'
'***********************************************************************
'AddAttachFile : Mail'e dosya eklemek
' (ByVal vFilePath As String)
'ClearAttachedFiles : Mail'e eklenen dosyalari silmek
'***********************************************************************
' PRIVATE SUBS
'
'***********************************************************************
'***********************************************************************
' PUBLIC FUNCTIONS
'
'***********************************************************************
'UUEncodeFile : Attach dosyalarin UUencode algoritmasi ile
' SMTP attachment formatina uyarlanmasi.
' Attachment gonderimi
' "begin 664 dosyaismi.uzanti" veya
' "begin 644 dosyaismi.uzanti"
' satiri ile baslar,
' "`" & vbcrlf & "end" satirlari ile biter
' Ornek:
' begin 664 abc.txt
' --encode edilmis dosya--
' `
' end
' (strFilePath As String) As String
'***********************************************************************
' PRIVATE FUNCTIONS
'
'***********************************************************************
'WaitForResponse : SMTP sunucusundan vData cevabi gelene kadar
' beklemek.
' (vData As String) As Boolean
'***********************************************************************
' EVENTS
'
'***********************************************************************
Event TransferStatus(ByRef StatCode As Short) '1 = Baglaniyor
' 2 = Baglandi
' 3 = Mesaj gonderiliyor
' 4 = Baglanti kesiliyor
' 5 = SMTP zaman asimi.Yanit bek
' lerken islem zaman asimina
' ugradi
' 6 = SMTP sunucu hatasi.
' Gecersiz komut
' 7 = Acik bir baglanti mevcut.
' Islem gerceklestirilemiyor
Event SMTPServerResponse(ByRef Response As String)
' SMTP sunucusundan gelen
' cevaplar.
'***********************************************************************
' DECLERATIONS
'
'***********************************************************************
Private mvarSMTPServerName As String
Private mvarSenderName As String
Private mvarSenderEmailAddress As String
Private mvarRecipientName As String
Private mvarRecipientEmailAddress As String
Private mvarEmailSubject As String
Private mvarEmailBody As String
Private mvarAttachFiles() As String
Private mvarSMTPTimeOut As Short
Private mvarSMTPRemotePort As Integer
Private WithEvents mvarWSocket As AxMSWinsockLib.AxWinsock

Private mlocData As String
'***********************************************************************

Sub AddAttachFile(ByVal vFilePath As String)
'***********************************************************************
'Yazan : Levent YILDIZ
'Sirket :
'Tarih : 22.08.2003
'Amac : Mail'e dosya eklemek
'Giris :
'Cikis :
'Not :
'***********************************************************************
'Degisiklikler
'***********************************************************************
vFilePath = Trim(vFilePath)
If vFilePath = "" Then Exit Sub
If mvarAttachFiles(0) "" Then
ReDim Preserve mvarAttachFiles(UBound(mvarAttachFiles) + 1)
mvarAttachFiles(UBound(mvarAttachFiles)) = vFilePath
Else
mvarAttachFiles(UBound(mvarAttachFiles)) = vFilePath
End If
End Sub
Sub ClearAttachedFiles()
'***********************************************************************
'Yazan : Levent YILDIZ
'Sirket :
'Tarih : 22.08.2003
'Amac : Mail'e eklenen dosyalari silmek
'Giris :
'Cikis :
'Not :
'***********************************************************************
'Degisiklikler
'***********************************************************************
ReDim mvarAttachFiles(0)
End Sub
Function SendEmail() As Boolean
'***********************************************************************
'Yazan : Levent YILDIZ
'Sirket :
'Tarih : 21.08.2003
'Amac :
'Giris :
'Cikis :
'Not :
'***********************************************************************
'Degisiklikler
'***********************************************************************
Dim strDate As String
Dim strSend1 As String
Dim strSend2 As String
Dim strSend3 As String
Dim strSend4 As String
Dim strSend5 As String
Dim strSend6 As String
Dim strSend7 As String
Dim strSend8 As String
Dim strEncodedData As String

Dim strLines() As String
Dim lngI As Integer
'***********************************************************************
'fn degeri ataniyor
SendEmail = False
'attachmentlar UUencode algoritmasiyla gonderiliyor
strEncodedData = ""
For lngI = 0 To UBound(mvarAttachFiles)
If mvarAttachFiles(lngI) "" Then
strEncodedData = strEncodedData & UUEncodeFile(mvarAttachFiles(lngI))
End If
Next
'attachmentlar temizleniyor
ClearAttachedFiles()
'gonderim baslatiliyor
With mvarWSocket
If .CtlState = MSWinsockLib.StateConstants.sckClosed Then

strDate = VB6.Format(Today, "Ddd") & ", " & VB6.Format(Today, "dd Mmm YYYY") & " " & VB6.Format(TimeOfDay, "hh:mm:ss") & "" & " -0600"
strSend1 = "mail from: " & SenderEmailAddress & vbCrLf
strSend2 = "rcpt to: " & RecipientEmailAddress & vbCrLf
strSend3 = "Date: " & strDate & vbCrLf
strSend4 = "From: """ & SenderName & """ " & vbCrLf
strSend5 = "To: " & RecipientName & vbCrLf
strSend6 = "Subject: " & EmailSubject & vbCrLf
strSend7 = EmailBody & vbCrLf
strSend8 = "X-Mailer: STMP Sender" & vbCrLf

.LocalPort = 0
.Protocol = MSWinsockLib.ProtocolConstants.sckTCPProtocol
.RemoteHost = SMTPServerName
.RemotePort = SMTPRemotePort
.Connect()

If Not WaitForResponse("220") Then .Close() : Exit Function
RaiseEvent TransferStatus(1)
.SendData(("HELO " & SMTPServerName & vbCrLf))

If Not WaitForResponse("250") Then .Close() : Exit Function
RaiseEvent TransferStatus(2)
.SendData((strSend1))
RaiseEvent TransferStatus(3)

If Not WaitForResponse("250") Then .Close() : Exit Function
.SendData((strSend2))

If Not WaitForResponse("250") Then .Close() : Exit Function
.SendData(("data" & vbCrLf))

'mesaj gonderiliyor -
If Not WaitForResponse("354") Then .Close() : Exit Function
.SendData((strSend4 & strSend3 & strSend8 & strSend5 & strSend6 & vbCrLf))

If strEncodedData "" Then
.SendData((strSend7))

'Attachment gonderiliyor -
strLines = Split(strEncodedData, vbLf)
For lngI = 0 To UBound(strLines) - 1
.SendData(strLines(lngI) & vbCrLf)
Next
'hafiza temizleniyor
Erase strLines
strEncodedData = ""
'Attachment gonderiliyor +
Else
.SendData((strSend7 & vbCrLf))
End If

.SendData(("." & vbCrLf))
'mesaj gonderiliyor +

If Not WaitForResponse("250") Then .Close() : Exit Function
.SendData(("quit" & vbCrLf))
RaiseEvent TransferStatus(4)

If Not WaitForResponse("221") Then .Close() : Exit Function
.Close()
Else
RaiseEvent TransferStatus(7)
Exit Function
End If
End With
'fn degeri ataniyor
SendEmail = True
End Function
Private Function WaitForResponse(ByRef vData As String) As Boolean
'***********************************************************************
'Yazan : Levent YILDIZ
'Sirket :
'Tarih : 21.08.2003
'Amac : SMTP sunucusundan vData cevabi gelene kadar beklemek.
'Giris :
'Cikis :
'Not :
'***********************************************************************
'Degisiklikler
'***********************************************************************
Dim mlocStart As Single
Dim mlocTmr As Single
'***********************************************************************
'fn degeri ataniyor
WaitForResponse = False
'beklenen cevap icin donguye giriliyor
mlocStart = VB.Timer()
Do
mlocTmr = VB.Timer() - mlocStart
System.Windows.Forms.Application.DoEvents()
If Len(mlocData) > 0 Then
If Left(mlocData, 3) vData Then
If mlocTmr > mvarSMTPTimeOut Then
RaiseEvent TransferStatus(6)
Exit Function
End If
Else
mlocData = ""
'fn degeri ataniyor
WaitForResponse = True
Exit Function
End If
Else
If mlocTmr > mvarSMTPTimeOut Then
RaiseEvent TransferStatus(5)
Exit Function
End If
End If
Loop
End Function
Private Sub mvarWSocket_DataArrival(ByVal eventSender As System.Object, ByVal eventArgs As AxMSWinsockLib.DMSWinsockControlEvents_DataArrivalEvent) Handles mvarWSocket.DataArrival
mvarWSocket.GetData(mlocData)
RaiseEvent SMTPServerResponse(mlocData)
System.Diagnostics.Debug.WriteLine(mlocData)
End Sub
Function UUEncodeFile(ByRef strFilePath As String) As String
'***********************************************************************
'Yazan : Levent YILDIZ
'Sirket :
'Tarih : 21.08.2003
'Amac : Attach dosyalarin UUencode algoritmasi ile SMTP attachment
' formatina uyarlanmasi.Attachment gonderimi "begin 664
' dosyaismi.uzanti" veya "begin 644 dosyaismi.uzanti"
' satiri ile baslar, "`" & vbcrlf & "end" satirlari ile biter
' Ornek:
' begin 664 abc.txt
' --encode edilmis dosya--
' `
' end
'Giris :
'Cikis :
'Not : Kaynak:http://www.vbip.com/winsock/winsock_uucode_01.asp
'***********************************************************************
'Degisiklikler
'***********************************************************************
Dim intFile As Short 'file handler
Dim intTempFile As Short 'temp file
Dim lFileSize As Integer 'size of the file
Dim strFilename As String 'name of the file
Dim strFileData As String 'file data chunk
Dim lEncodedLines As Integer 'number of encoded lines
Dim strTempLine As String 'temporary string
Dim I As Integer 'loop counter
Dim j As Short 'loop counter
Dim strResult As String
'***********************************************************************
'Get file name
strFilename = Mid(strFilePath, InStrRev(strFilePath, "\") + 1)
'Insert first marker: "begin 664 ..."
strResult = "begin 664 " & strFilename & vbLf
'Get file size
lFileSize = FileLen(strFilePath)
lEncodedLines = lFileSize \ 45 + 1
'Prepare buffer to retrieve data from
'the file by 45 symbols chunks
strFileData = Space(45)
intFile = FreeFile
FileOpen(intFile, strFilePath, OpenMode.Binary)
For I = 1 To lEncodedLines
'Read file data by 45-bytes cnunks
If I = lEncodedLines Then
'Last line of encoded data often is not
'equal to 45, therefore we need to change
'size of the buffer
strFileData = Space(lFileSize Mod 45)
End If
'Retrieve data chunk from file to the buffer
'UPGRADE_WARNING: Get was upgraded to FileGet and has a new behavior. Click for more: 'ms-help://MS.VSCC/commoner/redir/redirect.htm?keyword="vbup1041"'
FileGet(intFile, strFileData)
'Add first symbol to encoded string that informs
'about quantity of symbols in encoded string.
'More often "M" symbol is used.
strTempLine = Chr(Len(strFileData) + 32)
If I = lEncodedLines And (Len(strFileData) Mod 3) Then
'If the last line is processed and length of
'source data is not a number divisible by 3, add one or two
'blankspace symbols
strFileData = strFileData & Space(3 - (Len(strFileData) Mod 3))
End If
For j = 1 To Len(strFileData) Step 3
'Breake each 3 (8-bits) bytes to 4 (6-bits) bytes
'1 byte
strTempLine = strTempLine & Chr(Asc(Mid(strFileData, j, 1)) \ 4 + 32)
'2 byte
strTempLine = strTempLine & Chr((Asc(Mid(strFileData, j, 1)) Mod 4) * 16 + Asc(Mid(strFileData, j + 1, 1)) \ 16 + 32)
'3 byte
strTempLine = strTempLine & Chr((Asc(Mid(strFileData, j + 1, 1)) Mod 16) * 4 + Asc(Mid(strFileData, j + 2, 1)) \ 64 + 32)
'4 byte
strTempLine = strTempLine & Chr(Asc(Mid(strFileData, j + 2, 1)) Mod 64 + 32)
Next j
'replace " " with "`"
strTempLine = Replace(strTempLine, " ", "`")
'add encoded line to result buffer
strResult = strResult & strTempLine & vbLf
'reset line buffer
strTempLine = ""
Next I
FileClose(intFile)
'add the end marker
strResult = strResult & "`" & vbLf & "end" & vbLf
'asign return value
UUEncodeFile = strResult
End Function

'***********************************************************************
Property SMTPServerName() As String
Get
SMTPServerName = Trim(mvarSMTPServerName)
End Get
Set(ByVal Value As String)
mvarSMTPServerName = Trim(Value)
End Set
End Property
'***********************************************************************
Property SenderName() As String
Get
SenderName = Trim(mvarSenderName)
End Get
Set(ByVal Value As String)
mvarSenderName = Trim(Value)
End Set
End Property
'***********************************************************************
Property SenderEmailAddress() As String
Get
SenderEmailAddress = Trim(mvarSenderEmailAddress)
End Get
Set(ByVal Value As String)
mvarSenderEmailAddress = Trim(Value)
End Set
End Property
'***********************************************************************
Property RecipientName() As String
Get
RecipientName = Trim(mvarRecipientName)
End Get
Set(ByVal Value As String)
mvarRecipientName = Trim(Value)
End Set
End Property
'***********************************************************************
Property RecipientEmailAddress() As String
Get
RecipientEmailAddress = Trim(mvarRecipientEmailAddress)
End Get
Set(ByVal Value As String)
mvarRecipientEmailAddress = Trim(Value)
End Set
End Property
'***********************************************************************
Property EmailSubject() As String
Get
EmailSubject = Trim(mvarEmailSubject)
End Get
Set(ByVal Value As String)
mvarEmailSubject = Trim(Value)
End Set
End Property
'***********************************************************************
Property EmailBody() As String
Get
EmailBody = Trim(mvarEmailBody)
End Get
Set(ByVal Value As String)
mvarEmailBody = Trim(Value)
End Set
End Property
'***********************************************************************
Property LocData() As String
Get
LocData = mlocData
End Get
Set(ByVal Value As String)
mlocData = Value
End Set
End Property
'***********************************************************************
Property SMTPTimeOut() As Short
Get
SMTPTimeOut = mvarSMTPTimeOut
End Get
Set(ByVal Value As Short)
mvarSMTPTimeOut = Value
End Set
End Property
'***********************************************************************
WriteOnly Property WSocket() As AxMSWinsockLib.AxWinsock
Set(ByVal Value As AxMSWinsockLib.AxWinsock)
mvarWSocket = Value
End Set
End Property
'***********************************************************************
Property SMTPRemotePort() As Integer
Get
SMTPRemotePort = mvarSMTPRemotePort
End Get
Set(ByVal Value As Integer)
mvarSMTPRemotePort = Value
End Set
End Property
'***********************************************************************
ReadOnly Property AttachFiles(ByVal Index As Short) As String
Get
If Index > UBound(mvarAttachFiles) Then Exit Property
AttachFiles = mvarAttachFiles(Index)
End Get
End Property
'***********************************************************************

ClassSMTP.WSocket = sckSMTP

ClassSMTP.SenderName = "Gonderici ismi"
ClassSMTP.SenderEmailAddress = "gonderen@abc.com"
ClassSMTP.SMTPServerName = "10.10.10.1"
ClassSMTP.RecipientName = "Alici ismi"
ClassSMTP.RecipientEmailAddress = "alici@abc.com"
ClassSMTP.EmailSubject = "Test"
ClassSMTP.EmailBody = "Merhabalar"
ClassSMTP.AddAttachFile("c:\abcd.txt")
ClassSMTP.SendEmail()