Outlook mail message into excel using VBA - outlook

Excel File Link
This is a code from an you-tube video. The below code is giving an Compiler error : Userdefined Type not defined.
Sub SendEmail(what_address As String, Subject_line As String, mail_body As String)
'Dim olApp As Outlook.Application
Set olApp = CreateObject("outlook.Application")
'Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = Subject_line
olMail.body = mial_body
olMail.send
End Sub
Sub SendMassEmail()
row_number = 1
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim Promoscode As String
mail_body_message = Sheet1.Range("J2")
full_name = Sheet1.Range("B" & row_number) & " " & Sheet1.Range("C" & row_number)
promo_code = Sheet1.Range("D" & row_number)
mial_body_message = Replace(mail_body_message, "replace_name_here", full_name)
Call SendEmail(Sheet1.Range("A1" & row_number), "This is a test e-mail", mail_body_message)
Loop Until row_number = 6
End Sub
I am having an compiler error, I have checked everything but...not sure what is cousing this issue.

Use the Recipients property of the MailItem class to specify the recipients instead of the To property.
The Recipients class provides the Add method which allows to create and add a new recipient to the collection. Then use the Resolve method to attempt to resolve a Recipient object against the Address Book.
Sub AssignTask()
Dim myItem As Outlook.TaskItem
Dim myDelegate As Outlook.Recipient
Set MyItem = Application.CreateItem(olTaskItem)
MyItem.Assign
Set myDelegate = MyItem.Recipients.Add("DL name")
myDelegate.Resolve
If myDelegate.Resolved Then
myItem.Subject = "Prepare Agenda For Meeting"
myItem.DueDate = Now + 30
myItem.Display
myItem.Send
End If
End Sub

Related

Saving email headers as .msg

Dear StackOverflowers.
I know a few programming languages, but unfortunately VBA is not one of them.
I'm trying to make a script that saves the headers from selected mails in Outlook as .msg-files.
I found a script that opens the headers as new messages, but how to I save them as e.g. [senders domain]_[date recieved].msg instead of opening them as new mails?
The script that I have:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
' Purpose: Returns the internet headers of a message.'
' Written: 4/28/2009'
' Author: BlueDevilFan'
' //techniclee.wordpress.com/
' Outlook: 2007'
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
Use the MailItem.SaveAs method which saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. For example:
Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
So you want an MSG file that has no recipients, attachments, subject, etc, only the MIME headers as the body? Why do you want the MSG format then?
You can create an populate a text file using the Scripting.FileSystemObject and use its CreateTextFile method.
Thank you, Eugene.
I managed to put in your code.
But it doesn't give the file a name, it's only called ".msg", and it doesn't work, when I try to select more than one email.
Also, how do I avoid, that it opens a new mail with the header?
I have this script now:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.SenderEmailAddress
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.saveas "C:\temp\" & strname & ".msg", OLTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function

userform vlookup in textbox

I am really new to VBA, was trying to play around with really basic things, userform and vlookup. Couldn't figure out vlookup error after many hours. Appreciate any input!
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdSend_Click()
' emailcommand Macro
'
Dim oApp As Outlook.Application
Dim oMail As MailItem
Set oApp = New Outlook.Application
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = emailaddress.Value
.Subject = Subjectbox.Value
.Body = "Hi, " & Fundname.Value & " is ready"
.Display
Application.SendKeys "%s"
End With
End Sub
Private Sub Fundnumber_Change()
Dim ws As Worksheet
Set ws = Sheets("Matrix")
With Me
.Fundname.Text = Application.VLookup(.Fundnumber.Text, ws.Range("A2:D141"), 4, False)
End With
End Sub

Connection String in Textbox

I'am new in programming and my problem is. i have put my ado db connection string into a text box how can i call that text box? i'm creating my program in vb 6 and here's my code.
Private Sub lvButtons_H2_Click()
On Error GoTo errtrap
If Label47.Caption = "True" Then
MsgBox "INITIAL SETTING FOR SHIP ACCOUNT IS BEING PERFORMED", vbOKOnly, "ABORT"
Exit Sub
End If
Dim conas As New ADODB.Connection, rs01 As New ADODB.Recordset, rsx1 As New ADODB.Recordset, RS9 As New ADODB.Recordset
conas.Connectio`enter code here`nString = Text1155.Text
conas.Open
Set RS9 = New ADODB.Recordset
RS9.ActiveConnection = conas
RS9.CursorType = 3
RS9.LockType = 3
RS9.Open ("SELECT * FROM [SHIPACCOUNT].[dbo].[SPARE PART LIST BOND 29 MONTHLY] WHERE NAMECODE = " & Text2.Text & "")
Set DataReport2.DataSource = RS9
DataReport2.Sections("Section2").Controls.item("LABEL12").Caption = Text1.Text
DataReport2.Sections("Section2").Controls.item("LABEL11").Caption = Text3.Text
DataReport2.Sections("Section1").Controls.item("TEXT1").DataField = RS9![PARTSNAME].Name
DataReport2.Sections("Section1").Controls.item("TEXT2").DataField = RS9![Price].Name
DataReport2.Sections("Section1").Controls.item("TEXT3").DataField = RS9![unit].Name
DataReport2.Sections("Section1").Controls.item("TEXT4").DataField = RS9![QTYAPPLY].Name
DataReport2.Sections("Section1").Controls.item("TEXT5").DataField = RS9!QTYAPPROVE.Name
DataReport2.Sections("Section1").Controls.item("TEXT6").DataField = RS9![AMOUNTAPPROVE].Name
DataReport2.Sections("Section1").Controls.item("TEXT7").DataField = RS9![Date].Name
DataReport2.Show 1
Exit Sub
errtrap:
MsgBox Err.Description, vbCritical, "The system encountered an error"
End Sub
You can pass the connection string as parameter to the Connection.Open method
Such as (assuming the name of the textbox is Text1155):
Dim conas As New ADODB.Connection
conas.Open Text1155.Text
(You don't need parenthesis for calling a Sub in vb6)
Your code looks right otherwize...

VB6.0 with DataControl Database Programming

can you help out access the database... I have been reading some tutorials but I don't know where to start doing this one. I used DataControl to access the database. First, the program will prompt for the ID Number and then Search for the further information and display it in texboxes when Search Employee button clicked. I know how to set the properties of textboxes in order to appear the value of my database to my output without clicking the Search Employee button but I want to click first the button Search Employee. I'm a beginner in VB6. Please help me out! I need this project now.
Ok, I had some time to spare, here you go, first add a reference to Microsoft ActiveX Data Objects 2.X Library:
Form1 Code:
Option Explicit
''Add the following items to your form and name them as indicated:
''Four(4) text boxes - Named: tbIDNumber, tbName, tbAddress, and tbContactName.
''One(1) Command button - Named Command1
Private Sub Command1_Click()
Dim rs As ADODB.Recordset
Dim DB As cDatabase
Dim l As Long
Set rs = New ADODB.Recordset
Set DB = New cDatabase
With DB
.DBCursorType = adOpenForwardOnly
.DBLockType = adLockReadOnly
.DBOptions = adCmdText
.DSNName = "Your_DSN_Name"
.SQLUserID = "Your_SQL_Login_Name"
.SQLPassword = "Your_SQL_Login_Password"
Set rs = .GetRS("Select Name, Address, ContactNumber FROM YourTableName WHERE IDNumber = '" & tbIDNumber.Text & "'")
End With
If rs.RecordCount > 0 Then
tbName.Text = rs(0).Value & ""
tbAddress.Text = rs(1).Value & ""
tbContactName.Text = rs(2).Value & ""
End If
Exit_Sub:
rs.Close
Set rs = Nothing
Set DB = Nothing
End Sub
Add a Class Module Object to your project and name it cDatabase. Then copy the following Code into it:
Option Explicit
Private m_eDBCursorType As ADODB.CursorTypeEnum 'Cursor (Dynamic, Forward Only, Keyset, Static)
Private m_eDBLockType As ADODB.LockTypeEnum 'Locks (BatchOptimistic,Optimistic,Pessimistic, Read Only)
Private m_eDBOptions As ADODB.CommandTypeEnum 'DB Options
Private m_sDSNName As String
Private m_sSQLUserID As String
Private m_sSQLPassword As String
Private cn As ADODB.Connection
Private Sub Class_Initialize()
m_eDBCursorType = adOpenForwardOnly
m_eDBLockType = adLockReadOnly
m_eDBOptions = adCmdText
End Sub
Private Function ConnectionString() As String
ConnectionString = "DSN=" & m_sDSNName & "" & _
";UID=" & m_sSQLUserID & _
";PWD=" & m_sSQLPassword & ";"
''If you are using MS Access as your back end you will need to change the connection string to the following:
''ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
''If you are using a DNS-Less connection to SQL Server, then you will need to change the connection string to the following:
''ConnectionString = "Data Source=myServerAddress;Initial Catalog=myDataBase;User Id=" & m_sSQLUserID & ";Password=" & m_sSQLPassword & ";"
''You can find more Connection Strings at http://connectionstrings.com/
End Function
Private Sub GetCN()
On Error GoTo GetCN_Error
If cn.State = 0 Then
StartCN:
Set cn = New ADODB.Connection
cn.Open ConnectionString
With cn
.CommandTimeout = 0
.CursorLocation = adUseClient
End With
End If
On Error GoTo 0
Exit Sub
GetCN_Error:
If Err.Number = 91 Then
Resume StartCN
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetCN of Module modDatabaseConnections"
End If
End Sub
Public Function GetRS(sSQL As String) As ADODB.Recordset
Dim eRS As ADODB.Recordset
On Error GoTo GetRS_Error
TryAgain:
If Len(Trim(sSQL)) > 0 Then
Call GetCN
Set eRS = New ADODB.Recordset 'Creates record set
eRS.Open sSQL, cn, m_eDBCursorType, m_eDBLockType, m_eDBOptions
Set GetRS = eRS
Else
MsgBox "You have to submit a SQL String"
End If
On Error GoTo 0
Exit Function
GetRS_Error:
If Err.Number = 91 Then
Call GetCN
GoTo TryAgain
ElseIf Err.Number = -2147217900 Then
Exit Function
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetRS of Module" & vbCrLf & vbCrLf & "SQL - " & sSQL
End If
End Function
Public Property Get DBOptions() As ADODB.CommandTypeEnum
DBOptions = m_eDBOptions
End Property
Public Property Let DBOptions(ByVal eDBOptions As ADODB.CommandTypeEnum)
m_eDBOptions = eDBOptions
End Property
Public Property Get DBCursorType() As ADODB.CursorTypeEnum
DBCursorType = m_eDBCursorType
End Property
Public Property Let DBCursorType(ByVal eDBCursorType As ADODB.CursorTypeEnum)
m_eDBCursorType = eDBCursorType
End Property
Public Property Get DBLockType() As ADODB.LockTypeEnum
DBLockType = m_eDBLockType
End Property
Public Property Let DBLockType(ByVal eDBLockType As ADODB.LockTypeEnum)
m_eDBLockType = eDBLockType
End Property
Public Property Get DSNName() As String
DSNName = m_sDSNName
End Property
Public Property Let DSNName(ByVal sDSNName As String)
m_sDSNName = sDSNName
End Property
Public Property Get SQLUserID() As String
SQLUserID = m_sSQLUserID
End Property
Public Property Let SQLUserID(ByVal sSQLUserID As String)
m_sSQLUserID = sSQLUserID
End Property
Public Property Get SQLPassword() As String
SQLPassword = m_sSQLPassword
End Property
Public Property Let SQLPassword(ByVal sSQLPassword As String)
m_sSQLPassword = sSQLPassword
End Property
This should do the trick.

Extracting data from an email message (or several thousand emails) [Exchange based]

My marketing department, bless them, has decided to make a sweepstakes where people enter over a webpage. That is great but the information isn't stored to a DB of any sort but is sent to an exchange mail box as an email. Great.
My challenge is to extract the entry (and marketing info) from these emails and store them someplace more useful, say a flat file or CSV. The only saving grace is that the emails have a highly consistant format.
I am sure I could spend the time saving all the emails to files and then write an app to munge through them all but was hoping for a much more elegant solution. Can I programmatically access an exchange mailbox, read all the emails and then save that data?
Here is the code I used....
Private Sub btnGo_Click()
If ComboBox1.SelText <> "" Then
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objMail As mailItem
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
For Each objFolder In objInbox.Folders
If (objFolder.Name = ComboBox1.SelText) Then
Set objInbox = objFolder
End If
Next objFolder
//Loop through the items in the Inbox
Dim count As Integer
count = 1
For Each objMail In objInbox.Items
lblStatus.Caption = "Count: " + CStr(count)
If (CheckBox1.Value = False Or objMail.UnRead = True) Then
ProcessMailItem (objMail.Body)
count = count + 1
objMail.UnRead = False
End If
Next objMail
End If
End Sub
Private Sub ProcessMailItem(strBody As String)
Open "C:\file.txt" For Append As 1
Dim strTmp As String
strTmp = Replace(strBody, vbNewLine, " ")
strTmp = Replace(strTmp, vbCrLf, " ")
strTmp = Replace(strTmp, Chr(13) & Chr(10), " ")
strTmp = Replace(strTmp, ",", "_")
//Extra Processing went here (Deleted for brevity)
Print #1, strTmp
Close #1
End Sub
Private Function Strip(strStart As String, strEnd As String, strBody As String) As String
Dim iStart As Integer
Dim iEnd As Integer
iStart = InStr(strBody, strStart) + Len(strStart)
If (strEnd = "xxx") Then
iEnd = Len(strBody)
Else
iEnd = InStr(strBody, strEnd) - 1
End If
Strip = LTrim(RTrim(Mid(strBody, iStart, iEnd - iStart)))
End Function
Private Sub UserForm_Initialize()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objFolder As MAPIFolder
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
//Loop through the folders under the Inbox
For Each objFolder In objInbox.Folders
ComboBox1.AddItem objFolder.Name
Next objFolder
End Sub
There's lots of different ways to get at the messages in an exchange mailbox, but since it seems this is something you're only going to want to run once to extract the data I'd suggest writing a VBA macro to run inside Outlook itself (having opened the exchange mailbox in question within Outlook). It's pretty easy to iterate through the mail items in a specific mailbox and read the body text from them. You can then write a text file with just the stuff you want.

Resources