Send Email

Sending email and attach files using Vb 6.0

Source Code:

Option Explicit

Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim schema As String



Private Sub cmdSend_Click()
    If IsReadyToSendEmail = True Then
        cmdSend.Enabled = True
        SendEmail Trim(TxtEmailTo)
    Else
        cmdSend.Enabled = False
    End If
End Sub

Private Sub cmdAttach_Click()
    On Error GoTo ErrorHandler
        cd.CancelError = True
        cd.DialogTitle = "Select Attach files ..."
        cd.Flags = cdlOFNHideReadOnly
        cd.Filter = "Excel Files|*.xls|*.xlsx"
        cd.FilterIndex = 2
        cd.FileName = ""
        cd.ShowOpen
        TxtAttach = cd.FileName
        If Dir(TxtAttach) <> "" Then
           If Right(TxtAttach, 4) = ".xls" Or Right(TxtAttach, 5) = ".xlsx" Then
                
           Else
                MsgBox "Selected file is not Excel file! Select Excel file and Try again", vbOKOnly + vbInformation, "Attach files"
                Exit Sub
           End If
        Else
            MsgBox "Selected file can not found! Try again", vbOKOnly + vbInformation, "Attach files"
            Exit Sub
        End If
    Exit Sub
ErrorHandler:
End Sub

Private Sub Form_Activate()
    If TxtEmailTo = "" Then
        TxtEmailTo.SetFocus
    ElseIf TxtSubject = "" Then
        TxtSubject.SetFocus
    ElseIf TxtBody = "" Then
        TxtBody.SetFocus
    Else
        cmdContact.SetFocus
    End If
End Sub

Private Sub Form_Load(): dCenter Me
    Me.Top = Me.Top + 1000: Me.Left = Me.Left + 1500
    lblEmail.Caption = Trim("Account : xxxxxx@gmail.com")
    bEnabledSend
End Sub

Private Function IsReadyToSendEmail() As Boolean
    IsReadyToSendEmail = True
    If TxtEmailTo = "" Then IsReadyToSendEmail = False
End Function

Sub SendEmail(ByVal sEmailTo As String)
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    Set Flds = iConf.Fields
   
    schema = "http://schemas.microsoft.com/cdo/configuration/"
    Flds.Item(schema & "sendusing") = 2
    Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
    Flds.Item(schema & "smtpserverport") = 465
    Flds.Item(schema & "smtpauthenticate") = 1
    Flds.Item(schema & "sendusername") = "xxxxxx@gmail.com"
    Flds.Item(schema & "sendpassword") = "xxxxx"
    Flds.Item(schema & "smtpusessl") = 1
    Flds.Update
   
    With iMsg
        .To = Trim(sEmailTo)
        .From = "xxxxxx@gmail.com"
        .Subject = TxtSubject
        .HTMLBody = TxtBody
        .AddAttachment TxtAttach
       
        Set .Configuration = iConf
        .Send
        MsgBox "email was sent successfully!", vbInformation, "Email"
        ObjClear Me
    End With
   
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub

Private Sub cmdContact_Click()
    TxtEmailTo = ""
    frm_ContactEmail.Show 1
End Sub

Private Sub bEnabledSend()
    If IsReadyToSendEmail = True Then
        cmdSend.Enabled = True
    Else
        cmdSend.Enabled = False
    End If
End Sub

Private Sub TxtBody_KeyPress(KeyAscii As Integer)
    If KeyAscii = 27 Then
        TxtSubject.SetFocus
    End If
End Sub

Private Sub TxtEmailTo_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        TxtSubject.SetFocus
    ElseIf KeyAscii = 8 Then
        If Len(TxtEmailTo) <= 1 Then
            bEnabledSend
        End If
    Else
        bEnabledSend
    End If
End Sub

Private Sub TxtSubject_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        TxtBody.SetFocus
    ElseIf KeyAscii = 27 Then
        TxtEmailTo.SetFocus
    End If
End Sub