Automatic sending e-mail

[Encite]

My problem is: I want to make a program with VB that will automatically send an e-mail when somebody press (for example) a commandbutton.

Is this possible? And can somebody help me please.

With kind regards
Encite

[parkes]

Its possible alright, just depends on what application you normally use to send Email with, ie. Outlook or Outlook Express or any other?

[Encite]

Dam I indeed forgot to report that!

I want to use microsoft outlook 2000.

Thnx

[Scand]

Try this one:

Dim Mail As MailItem
Dim objOutlook As Outlook.Application
Set objOutlook = CreateObject("Outlook.Application")

Set Mail = objOutlook.CreateItem(olMailItem)
With Mail
.Subject = "Hello"
.Body = "Body Body Body..."
.Recipients.Add "[email protected]"
.Send
End With

And be sure, that you have added the reference "Mircosoft Outlook 9.0 Object Library" to your project.

Greets
Scand

[Encite]

Scands,

Can you tell me where I can find this:

"Mircosoft Outlook 9.0 Object Library" ?

I use Visual Basic 5.0 (sp3)

Thanx!!

With kind regards

Encite

[parkes]

You'll only find it if you have Outlook 2000 installed, or you could try the Microsoft site and try and locate the desired DLL.

You can use the Outlook Express 5.0 Type Library and to get this you just need a fairly upto date veriosn of IE

[Encite]

Parkes,

Where and how exactly can I find "Mircosoft Outlook 9.0 Object Library".
And how do I add this to my project?!

I know, I'm just a beginner with Visual Basic. So I hope you can tell me some more.

Thanx
Greetings
Encite :-)

Option Explicit

Private Sub cmdAbout_Click()
frmAbout.Show vbModal
End Sub

Private Sub cmdClose_Click()
Unload Me
End Sub

Private Sub cmdSelect_Click()

cmdDialog.ShowOpen
txtAttach = cmdDialog.FileName

End Sub

Private Sub cmdSend_Click()
On Error GoTo errhand
cmdSend.Enabled = False

'If ValidateEntry = False Then MsgBox "Either the server name or to address were left empty.", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub
If ValidateEntry = False Then MsgBox "Enter All The Details", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub

If txtAttach.Text <> "" Then
lblStatus = "Encoding file attachment"
Base64EncodeFile txtAttach.Text, rtfAttach, txtOutput
End If

lblStatus = "Connecting to POP Server"
ConnectToServer txtServer.Text, Winsock1

errhand:
If Err = 11001 Then MsgBox "Enter All Details", vbExclamation + vbOKOnly, "Invalid Information"

End Sub

Private Sub Form_Load()

txtAttach = ""
txtBody = ""
txtFromAddress = ""
txtServer = ""
txtSubject = ""
txtToAddress = ""


End Sub

Private Sub Winsock1_Connect()

lblStatus = "Connected to POP Server"

Wait 0.5

lblStatus = "Sending mail"

If txtAttach.Text = "" Then

SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1

Else

SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1, txtAttach, txtOutput

End If

lblStatus = "Mail sent"

cmdSend.Enabled = True

txtServer.Text = ""
txtFromAddress.Text = ""
txtToAddress.Text = ""
txtSubject.Text = ""
txtAttach.Text = ""
txtBody.Text = ""
'lblStatus = "Status:"

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)

MsgBox "Error Number: " & Number & vbCrLf & Description & vbCrLf & Source, vbCritical + vbOKOnly, Me.Caption

End Sub

Private Function ValidateEntry() As Boolean
Dim i As Integer
Dim i1 As Integer
Dim i2 As Integer
Dim s2 As String
i = InStr(1, txtToAddress, "@")
i = i + 1
i1 = Len(txtToAddress)
i2 = i1
s2 = Mid(txtToAddress, i, i2)
ValidateEntry = True
'If txtServer.Text = "" Or txtToAddress = "" Then ValidateEntry = False
If txtServer.Text = "" Then
txtServer.Text = "mail." & s2

If txtToAddress = "" Or txtSubject = "" Or txtAttach = "" Or txtBody = "" Then ValidateEntry = False

End If
End Function

Option Explicit

Private Sub cmdAbout_Click()
frmAbout.Show vbModal
End Sub

Private Sub cmdClose_Click()
Unload Me
End Sub

Private Sub cmdSelect_Click()

cmdDialog.ShowOpen
txtAttach = cmdDialog.FileName

End Sub

Private Sub cmdSend_Click()
On Error GoTo errhand
cmdSend.Enabled = False

'If ValidateEntry = False Then MsgBox "Either the server name or to address were left empty.", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub
If ValidateEntry = False Then MsgBox "Enter All The Details", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub

If txtAttach.Text <> "" Then
lblStatus = "Encoding file attachment"
Base64EncodeFile txtAttach.Text, rtfAttach, txtOutput
End If

lblStatus = "Connecting to POP Server"
ConnectToServer txtServer.Text, Winsock1

errhand:
If Err = 11001 Then MsgBox "Enter All Details", vbExclamation + vbOKOnly, "Invalid Information"

End Sub

Private Sub Form_Load()

txtAttach = ""
txtBody = ""
txtFromAddress = ""
txtServer = ""
txtSubject = ""
txtToAddress = ""


End Sub

Private Sub Winsock1_Connect()

lblStatus = "Connected to POP Server"

Wait 0.5

lblStatus = "Sending mail"

If txtAttach.Text = "" Then

SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1

Else

SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1, txtAttach, txtOutput

End If

lblStatus = "Mail sent"

cmdSend.Enabled = True

txtServer.Text = ""
txtFromAddress.Text = ""
txtToAddress.Text = ""
txtSubject.Text = ""
txtAttach.Text = ""
txtBody.Text = ""
'lblStatus = "Status:"

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)

MsgBox "Error Number: " & Number & vbCrLf & Description & vbCrLf & Source, vbCritical + vbOKOnly, Me.Caption

End Sub

Private Function ValidateEntry() As Boolean
Dim i As Integer
Dim i1 As Integer
Dim i2 As Integer
Dim s2 As String
'Iam using the code below in preventing the user to type the
'name of the POP Server.


i = InStr(1, txtToAddress, "@")
i = i + 1
i1 = Len(txtToAddress)
i2 = i1
s2 = Mid(txtToAddress, i, i2)
ValidateEntry = True
'If txtServer.Text = "" Or txtToAddress = "" Then ValidateEntry = False
If txtServer.Text = "" Then
txtServer.Text = "mail." & s2

If txtToAddress = "" Or txtSubject = "" Or txtAttach = "" Or txtBody = "" Then ValidateEntry = False

End If
End Function

Go and Write email programs happily in VB.

Do not USe any Outlook Library. Just use this simple code snippet.


Module
-------
Option Explicit

' Base64Encode(strOriginal)
' Base64Encode("the") would return "dGjl"
' You can only pass three letters as the arguement

Public Function Base64Encode(strOriginal As String)
Dim intCount As Integer
Dim strBinary As String
Dim intDecimal As Integer
Dim strTemp As String

intDecimal = Asc(Left$(strOriginal, 1))

For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next

If Len(strOriginal) < 3 Then GoTo unfpassone

intDecimal = Asc(Mid$(strOriginal, 2, 1))

For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next

If Len(strOriginal) < 3 Then GoTo unfpassone

intDecimal = Asc(Right$(strOriginal, 1))

For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next

unfpassone:
For intCount = 1 To 19 Step 6
Select Case Val(Mid$(strBinary, intCount, 6))
Case 0
strTemp = strTemp & "A"
Case 1
strTemp = strTemp & "B"
Case 10
strTemp = strTemp & "C"
Case 11
strTemp = strTemp & "D"
Case 100
strTemp = strTemp & "E"
Case 101
strTemp = strTemp & "F"
Case 110
strTemp = strTemp & "G"
Case 111
strTemp = strTemp & "H"
Case 1000
strTemp = strTemp & "I"
Case 1001
strTemp = strTemp & "J"
Case 1010
strTemp = strTemp & "K"
Case 1011
strTemp = strTemp & "L"
Case 1100
strTemp = strTemp & "M"
Case 1101
strTemp = strTemp & "N"
Case 1110
strTemp = strTemp & "O"
Case 1111
strTemp = strTemp & "P"
Case 10000
strTemp = strTemp & "Q"
Case 10001
strTemp = strTemp & "R"
Case 10010
strTemp = strTemp & "S"
Case 10011
strTemp = strTemp & "T"
Case 10100
strTemp = strTemp & "U"
Case 10101
strTemp = strTemp & "V"
Case 10110
strTemp = strTemp & "W"
Case 10111
strTemp = strTemp & "X"
Case 11000
strTemp = strTemp & "Y"
Case 11001
strTemp = strTemp & "Z"
Case 11010
strTemp = strTemp & "a"
Case 11011
strTemp = strTemp & "b"
Case 11100
strTemp = strTemp & "c"
Case 11101
strTemp = strTemp & "d"
Case 11110
strTemp = strTemp & "e"
Case 11111
strTemp = strTemp & "f"
Case 100000
strTemp = strTemp & "g"
Case 100001
strTemp = strTemp & "h"
Case 100010
strTemp = strTemp & "i"
Case 100011
strTemp = strTemp & "j"
Case 100100
strTemp = strTemp & "k"
Case 100101
strTemp = strTemp & "l"
Case 100110
strTemp = strTemp & "m"
Case 100111
strTemp = strTemp & "n"
Case 101000
strTemp = strTemp & "o"
Case 101001
strTemp = strTemp & "p"
Case 101010
strTemp = strTemp & "q"
Case 101011
strTemp = strTemp & "r"
Case 101100
strTemp = strTemp & "s"
Case 101101
strTemp = strTemp & "t"
Case 101110
strTemp = strTemp & "u"
Case 101111
strTemp = strTemp & "v"
Case 110000
strTemp = strTemp & "w"
Case 110001
strTemp = strTemp & "x"
Case 110010
strTemp = strTemp & "y"
Case 110011
strTemp = strTemp & "z"
Case 110100
strTemp = strTemp & "0"
Case 110101
strTemp = strTemp & "1"
Case 110110
strTemp = strTemp & "2"
Case 110111
strTemp = strTemp & "3"
Case 111000
strTemp = strTemp & "4"
Case 111001
strTemp = strTemp & "5"
Case 111010
strTemp = strTemp & "6"
Case 111011
strTemp = strTemp & "7"
Case 111100
strTemp = strTemp & "8"
Case 111101
strTemp = strTemp & "9"
Case 111110
strTemp = strTemp & "+"
Case 111111
strTemp = strTemp & "/"
End Select
Next

Base64Encode = strTemp

End Function

' Base64EncodeFile(strFile,rtfTemp,txtOutput)
' Base64EncodeFile "c:\windows\autoexec.bat",rtfBox,txtBox
' The second parameter must be a rtf box or a control that supports the
' LoadFile command

Public Sub Base64EncodeFile(strFile As String, rtfTemp As RichTextBox, txtOutput As TextBox)

Dim intCount As Integer
Dim strTemp As String
Dim lngMax As Long

lngMax = 0
txtOutput.Text = ""
rtfTemp.LoadFile strFile

For intCount = 1 To Len(rtfTemp.Text) Step 3

strTemp = Mid(rtfTemp.Text, intCount, 3)
txtOutput.Text = txtOutput.Text & Base64Encode(strTemp)
lngMax = lngMax + 4

If lngMax = 72 Then
lngMax = 0
txtOutput.Text = txtOutput.Text & vbCrLf
End If

DoEvents
Next intCount

End Sub

' ConnectToServer(strServer, wsk, strSrvPort)
' ConnectToServer "pop.microsoft.com", Winsock1, 25
' Normally leave out the last arguement and let the Winsock control use
' the default port.

Public Sub ConnectToServer(strServer As String, wsk As Winsock, Optional strSrvPort As String)

wsk.RemoteHost = strServer

If strSrvPort = "" Then
wsk.RemotePort = 25
Else
wsk.RemotePort = Val(strSrvPort)
End If

wsk.Connect

End Sub

' ExtractArgument(ArgNum, srchstr, Delim)
' ExtractArgument(3, "No 1, No 2, No 3", ",") Would return No 3
' I did not have time to sort out the variable names in this function,
' so if you can be bothered to, please send it to me at [email protected]

Private Function ExtractArgument(ArgNum As Integer, srchstr As String, Delim As String) As String

On Error GoTo Err_ExtractArgument

Dim ArgCount As Integer
Dim LastPos As Integer
Dim Pos As Integer
Dim Arg As String

Arg = ""
LastPos = 1
If ArgNum = 1 Then Arg = srchstr
Do While InStr(srchstr, Delim) > 0
Pos = InStr(LastPos, srchstr, Delim)
If Pos = 0 Then
If ArgCount = ArgNum - 1 Then Arg = Mid(srchstr, LastPos)
Exit Do
Else
ArgCount = ArgCount + 1
If ArgCount = ArgNum Then
Arg = Mid(srchstr, LastPos, Pos - LastPos)
Exit Do
End If
End If
LastPos = Pos + 1
Loop
ExtractArgument = Arg

Exit Function

Err_ExtractArgument:
MsgBox "Error " & Err & ": " & Error
Resume Next
End Function

' SendMail(strFrom, strTo, strSubject, strBody, wsk, strAttachName, txtEncodedFile)
' SendMail "[email protected]", "[email protected]", "Test Message", "Body", Winsock1, "myfile.ext", txtEncodedFile
' If you omit the last two arguements then no file is attached
' Before attaching a file, you must first encode it using the Base64EncodeFile function

Public Sub SendMail(strFrom As String, strTo As String, strSubject As String, strBody As TextBox, wsk As Winsock, Optional strAttachName As String, Optional txtEncodedFile As Control)

Dim intCount As Integer

Wait 0.5

wsk.SendData "EHLO " & wsk.LocalIP & vbCrLf
wsk.SendData "MAIL FROM:" & strFrom & vbCrLf

Wait 0.5

wsk.SendData "RCPT TO:" & strTo & vbCrLf
wsk.SendData "DATA" & vbCrLf

Wait 0.5

wsk.SendData "MIME-Version: 1.0" & vbCrLf
wsk.SendData "From: " & ExtractArgument(1, strFrom, "@") & " <" & strFrom & ">" & vbCrLf
wsk.SendData "To: <" & strTo & ">" & vbCrLf
wsk.SendData "Subject: " & strSubject & vbCrLf
wsk.SendData "Content-Type: multipart/mixed;" & vbCrLf
wsk.SendData " boundary=Unique-Boundary" & vbCrLf & vbCrLf
wsk.SendData " [ Random garbage here ]" & vbCrLf & vbCrLf
wsk.SendData vbCrLf & "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-type: text/plain; charset=US-ASCII" & vbCrLf & vbCrLf
wsk.SendData strBody.Text & vbCrLf & vbCrLf

If LTrim(RTrim(strAttachName)) <> "" Then

For intCount = Len(strAttachName) To 1 Step -1

If Mid(strAttachName, intCount, 1) = "\" Then
strAttachName = Mid(strAttachName, intCount + 1)
GoTo lala
End If

Next intCount
lala:
wsk.SendData "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-Type: multipart/parallel; boundary=Unique-Boundary-2" & vbCrLf & vbCrLf
wsk.SendData "--Unique-Boundary-2" & vbCrLf
wsk.SendData "Content-Type: application/octet-stream;" & vbCrLf
wsk.SendData " name=" & strAttachName & vbCrLf
wsk.SendData "Content-Transfer-Encoding: base64" & vbCrLf
wsk.SendData "Content-Disposition: inline;" & vbCrLf
wsk.SendData " filename=" & strAttachName & vbCrLf & vbCrLf
wsk.SendData txtEncodedFile.Text & "==" & vbCrLf
wsk.SendData "--Unique-Boundary-2----Unique-Boundary--"

End If

wsk.SendData vbCrLf & "." & vbCrLf

Wait 0.5

wsk.SendData "QUIT" & vbCrLf

Wait 0.5

wsk.Close

End Sub

' Wait(WaitTime)
' Wait 0.5

Public Sub Wait(WaitTime)

Dim StartTime As Double

StartTime = Timer

Do While Timer < StartTime + WaitTime
If Timer > 86395 Or Timer = 0 Then Exit Do
DoEvents
Loop

End Sub

Form
----
Option Explicit

Private Sub cmdAbout_Click()
frmAbout.Show vbModal
End Sub

Private Sub cmdClose_Click()
Unload Me
End Sub

Private Sub cmdSelect_Click()

cmdDialog.ShowOpen
txtAttach = cmdDialog.FileName

End Sub

Private Sub cmdSend_Click()
On Error GoTo errhand
cmdSend.Enabled = False

'If ValidateEntry = False Then MsgBox "Either the server name or to address were left empty.", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub
If ValidateEntry = False Then MsgBox "Enter All The Details", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub

If txtAttach.Text <> "" Then
lblStatus = "Encoding file attachment"
Base64EncodeFile txtAttach.Text, rtfAttach, txtOutput
End If

lblStatus = "Connecting to POP Server"
ConnectToServer txtServer.Text, Winsock1

errhand:
If Err = 11001 Then MsgBox "Enter All Details", vbExclamation + vbOKOnly, "Invalid Information"

End Sub

Private Sub Form_Load()

txtAttach = ""
txtBody = ""
txtFromAddress = ""
txtServer = ""
txtSubject = ""
txtToAddress = ""


End Sub

Private Sub Winsock1_Connect()

lblStatus = "Connected to POP Server"

Wait 0.5

lblStatus = "Sending mail"

If txtAttach.Text = "" Then

SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1

Else

SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1, txtAttach, txtOutput

End If

lblStatus = "Mail sent"

cmdSend.Enabled = True

txtServer.Text = ""
txtFromAddress.Text = ""
txtToAddress.Text = ""
txtSubject.Text = ""
txtAttach.Text = ""
txtBody.Text = ""
'lblStatus = "Status:"

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)

MsgBox "Error Number: " & Number & vbCrLf & Description & vbCrLf & Source, vbCritical + vbOKOnly, Me.Caption

End Sub

Private Function ValidateEntry() As Boolean
Dim i As Integer
Dim i1 As Integer
Dim i2 As Integer
Dim s2 As String
i = InStr(1, txtToAddress, "@")
i = i + 1
i1 = Len(txtToAddress)
i2 = i1
s2 = Mid(txtToAddress, i, i2)
ValidateEntry = True
'If txtServer.Text = "" Or txtToAddress = "" Then ValidateEntry = False
If txtServer.Text = "" Then
txtServer.Text = "mail." & s2

If txtToAddress = "" Or txtSubject = "" Or txtAttach = "" Or txtBody = "" Then ValidateEntry = False

End If
End Function



Go and Write Code for transparently sending the emails.

[Scand]

You can add the reference in VB 6.0 by Project/References...
and select the "Microsoft Outlook 9.0 Object Library" and klick OK.

I'm not sure if it's the same in VB 5.0

I hope it helps you.

Greets
Scand

[Encite]

Thank you thank you!

It works now!
Thank you very much, all of you!

With kind regards,

A very happy
Encite