jagu98
asked on
Automating Outlook EXPRESS 5 from VB6
I'm tring to write an app( more of a formless service) that checks for a certain time then dials an ISP and sends out an email with an attachment that changes daily. I want to do it with Outlook Express 5 not Outlook 97 or 98 or whatever other version. I'm working on a Win95 platform with VB6 SP3.
Thanks for your help folks.
Thanks for your help folks.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
paste into vb
VERSION 5.00
Begin VB.Form frmSendMail
Caption = "Send E-mail using Outlook Express"
ClientHeight = 3690
ClientLeft = 270
ClientTop = 1020
ClientWidth = 5490
LinkTopic = "Form1"
ScaleHeight = 3690
ScaleWidth = 5490
Begin VB.CheckBox chkSendEnter
Caption = "S&end to Outbox (i.e. send Ctrl-Enter)"
Height = 495
Left = 2520
TabIndex = 9
Top = 2520
Width = 2055
End
Begin VB.CommandButton cmSend
Caption = "Send &Now"
Height = 375
Left = 2760
TabIndex = 10
Top = 3120
Width = 1215
End
Begin VB.CommandButton cmCancel
Cancel = -1 'True
Caption = "Close"
Height = 375
Left = 4080
TabIndex = 11
Top = 3120
Width = 1215
End
Begin VB.CheckBox chkOffer
Caption = "&Offer"
Height = 315
Left = 180
TabIndex = 8
Top = 3060
Value = 1 'Checked
Width = 1455
End
Begin VB.CheckBox chkInvoice
Caption = "&Invoice"
Height = 315
Left = 180
TabIndex = 7
Top = 2760
Value = 1 'Checked
Width = 1455
End
Begin VB.TextBox txtMsg
Height = 1065
Left = 60
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 5
Top = 1320
Width = 5355
End
Begin VB.TextBox txtSubject
Height = 285
Left = 1140
TabIndex = 4
Text = "Invoice no 101"
Top = 900
Width = 3975
End
Begin VB.TextBox txtRecip
Height = 285
Left = 1140
TabIndex = 2
Text = "<xxyy@usa.net>, <ameba @zg.tel.hr>"
Top = 540
Width = 3975
End
Begin VB.CheckBox chkBcc
Caption = "&Bcc - Recipients cannot see who receives a msg"
Height = 375
Left = 900
TabIndex = 0
TabStop = 0 'False
Top = 60
Width = 4215
End
Begin VB.Label Label4
Caption = "Attachments:"
Height = 195
Left = 180
TabIndex = 6
Top = 2520
Width = 1455
End
Begin VB.Label Label2
Alignment = 1 'Right Justify
Caption = "S&ubject:"
Height = 195
Left = 180
TabIndex = 3
Top = 960
Width = 915
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Caption = "&To:"
Height = 195
Left = 180
TabIndex = 1
Top = 600
Width = 915
End
End
Attribute VB_Name = "frmSendMail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Send email using Outlook Express (IE4 required)
' Created by: Bruno Paris, ameba @zg.tel.hr
Option Explicit
' API declarations
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL = 1
'
Private Const bnd = "_NextPart_001_" ' boundary
Private Const charset = "iso-8859-2" ' or windows-1250
Private Sub cmCancel_Click()
Unload Me
End Sub
Private Sub cmSend_Click()
' Send email
Dim i As Integer
Dim iRet As Long, numfile%, FileName$
Dim recips As String ' recipients
On Error GoTo SendErr ' enable error handling
'-------------------------
' Create string for field "To:"
recips = txtRecip.Text
' or:
' RecipArray() holds email addresses, List1 holds names
' For i = 0 To List1.ListCount - 1
' If List1.Selected(i) = True Then
' If Len(recips) > 0 Then recips = recips & ", "
' recips = recips & "<" & RecipArray(List1.ItemData(
' End If
' Next
'-------------------------
numfile% = FreeFile
' Open temporary file
FileName$ = getapppath() & "~temp.eml"
Open FileName$ For Output As #numfile%
' display hourglass
Screen.MousePointer = vbHourglass
DoEvents
' start writing to temporary file
'-------------------------
' "Blind carbon copy" or "To"
If chkBcc.Value = 1 Then
Print #numfile%, "Bcc: " & recips
Else
Print #numfile%, "To: " & recips
End If
'-------------------------
' subject
Print #numfile%, "Subject: " & txtSubject.Text
'-------------------------
Print #numfile%, "MIME-Version: 1.0" & vbCrLf & "Content-Type: multipart/mixed;"
Print #numfile%, vbTab & "boundary=""" & bnd & """"
Print #numfile%, "X-Unsent: 1"
Print #numfile%,
Print #numfile%,
Print #numfile%, "--" & bnd
Print #numfile%, "Content-Type: text/plain;"
Print #numfile%, vbTab & "charset=""" & charset & """"
Print #numfile%, "Content-Transfer-Encoding
Print #numfile%,
'-------------------------
' msg body
Print #numfile%, txtMsg.Text
'-------------------------
' simple text file, max 60 characters per line
If chkInvoice > 0 Then ' attach file1
Dim att As String
att = "invoice.txt"
Print #numfile%, "--" & bnd
Print #numfile%, "Content-Type: text/plain;"
Print #numfile%, vbTab & "name=""" & att & """"
Print #numfile%, "Content-Transfer-Encoding
Print #numfile%, "Content-Disposition: attachment;"
Print #numfile%, vbTab & "filename=""" & att & """"
Print #numfile%,
' write invoice data to file
Print #numfile%, "Invoice"
Print #numfile%,
Print #numfile%,
Print #numfile%, "No: " & vbTab & "101/99"
Print #numfile%, "Date:" & vbTab & Format$(Now, "Short Date")
Print #numfile%,
Print #numfile%, "QUANTITY DESCRIPTION UNIT PRICE AMOUNT"
Print #numfile%, "5 PC $890 $4450"
Print #numfile%,
Print #numfile%, "SUBTOTAL:"
Print #numfile%, "SALES TAX:"
Print #numfile%, "TOTAL DUE:"
Print #numfile%,
Print #numfile%,
Print #numfile%, "SALESPERSON:"
Print #numfile%,
Print #numfile%, "Make all checks payable to: Your Company Name"
Print #numfile%, "If you have any questions concerning this invoice, call: Contact Name, Phone Number"
Print #numfile%,
Print #numfile%,
Print #numfile%, "THANK YOU FOR YOUR BUSINESS!"
Print #numfile%,
End If
' simple text file, max 60 characters per line
If chkOffer.Value Then ' attach file2
att = "offer.txt"
Print #numfile%, "--" & bnd
Print #numfile%, "Content-Type: text/plain;"
Print #numfile%, vbTab & "name=""" & att & """"
Print #numfile%, "Content-Transfer-Encoding
Print #numfile%, "Content-Disposition: attachment;"
Print #numfile%, vbTab & "filename=""" & att & """"
Print #numfile%,
' write offer data to file
Print #numfile%, "Offer"
Print #numfile%,
Print #numfile%, "Created: " & Format$(Now, "Short Date")
Print #numfile%, "etc."
Print #numfile%,
Print #numfile%, "Thank you for considering our offer!"
Print #numfile%,
End If
'-------------------------
Print #numfile%, "--" & bnd & "--"
' close temporary file
Close #numfile%
Reset ' flush all file buffers
' wait 1-2 seconds
For i = 1 To 10
Sleep (100)
DoEvents
Next
'-------------------------
' now, open created file with default e-mail program
iRet = ShellExecute(Me.hwnd, "Open", _
FileName$, _
"", "c:\", SW_SHOWNORMAL)
' if default e-mail program is Outlook Express,
' this will show "New Message" window
'-------------------------
DoEvents
Sleep (200)
On Error Resume Next
Dim numrtr As Integer
rtr:
numrtr = numrtr + 1
DoEvents
Sleep (100)
' set focus to "Outlook Express" window with new msg
AppActivate txtSubject.Text
If Err <> 0 Then
Err = 0
' if set focus was not succesfull, wait a while and retry
If numrtr < 100 Then GoTo rtr
Else
' now, press Ctrl-Enter to send to outbox
If chkSendEnter.Value Then SendKeys "^~"
End If
' After mail is in Outbox, we might want to connect if needed:
' If IsConnected() = False Then
' StartConnection
' End If
Screen.MousePointer = vbNormal
Exit Sub
SendErr:
Screen.MousePointer = vbNormal
MsgBox Err.Description
Exit Sub
End Sub
Function getapppath() As String
' returns path
Dim sTemp As String
sTemp = App.Path
If Right$(sTemp, 1) <> "\" Then sTemp = sTemp & "\"
getapppath = sTemp
End Function
Private Sub Form_Load()
txtMsg.Text = "My dear customer," & vbCrLf & _
"This is the offer you cannot refuse." & vbCrLf & vbCrLf & _
"Salesperson"
End Sub