The following code allows me to import .msg files into excel.
I was wondering if it is possible to create a macro in outlook that sends messages into an excel file rather than importing them.
The code I used for importing .msg files is as follows:
Sub IMPORTMSG()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
' Dim Msg As MailItem
Dim ws As Worksheet
' Dim myOlApp As Outlook.Application
' Dim MyItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Worksheets("A")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 4
Do While thisFile <> ""
Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
If MyItem.Subject = "testheader" Then
ws.Cells(i, 1) = MyItem.Body
i = i + 1
End If
thisFile = Dir()
Loop
Set MyItem = Nothing
Set myOlApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
You can create a COM addin for Outlook and have it run the code above. Or you can use Application.ActiveExplorer.Selection collection in Outlook to loop through the selected messages in Outlook instead of processing standalone MSG files.
You can develop an Outlook VBA macro where you can automate Excel and set Excel cell values. See How to automate Microsoft Excel from Visual Basic for more information.
Also you may find the Getting Started with VBA in Outlook 2010 article helpful.
Related
I'm trying to use Application.DisplayAlerts = wdAlertsNone or Application.DisplayAlerts = False to avoid a Word popup message just before saving a Word document.
The document being saved contains track changes Continue with save?
Private Sub CreateReportButton_Click()
Dim objDocA As Word.Document
Dim objDocB As Word.Document
Dim objDocC As Word.Document
Dim objFSO As Scripting.FileSystemObject
Dim objFolderA As Scripting.Folder
Dim objFolderB As Scripting.Folder
Dim objFolderC As Scripting.Folder
Dim colFilesA As Scripting.Files
Dim objFileA As Scripting.File
Dim i As Integer
Dim j As Integer
Set objFSO = New FileSystemObject
Set objFolderA = objFSO.GetFolder(ChooseFolder("Choose the folder with the original documents", ThisDocument.Path))
Set objFolderB = objFSO.GetFolder(ChooseFolder("Choose the folder with revised documents", ThisDocument.Path))
Set objFolderC = objFSO.GetFolder(ChooseFolder("Choose the folder for the comparisons documents", ThisDocument.Path))
Set colFilesA = objFolderA.Files
For Each objFileA In colFilesA
If objFileA.Name Like "*.docx" Then
Set objDocA = Documents.Open(objFolderA.Path & "\" & objFileA.Name)
Set objDocB = Documents.Open(objFolderB.Path & "\" & objFileA.Name)
Set objDocC = Application.CompareDocuments( _
OriginalDocument:=objDocA, _
RevisedDocument:=objDocB, _
Destination:=wdCompareDestinationNew)
objDocA.Close
objDocB.Close
On Error Resume Next
Kill objFolderC.Path & "\" & objFileA.Name
On Error GoTo 0
'Turn off DisplayAlerts
Application.DisplayAlerts = wdAlertsNone
objDocC.SaveAs FileName:=objFolderC.Path & "\" & objFileA.Name
objDocC.Close SaveChanges:=False
End If
Next objFileA
End Sub
Apparently it depends on the version of office, In 2013 it's necessary to go to the Trust Center area of the application (File > Options > Trust Center > Trust Center Settings > Privacy Options) and uncheck the option "Warm before printing, saving or sending a file that contains tracked changes or comments". After doing that files are saved with any message of Word
If you need to retain those settings, then for the purposes of your code you could use something along the lines of:
Options.WarnBeforeSavingPrintingSendingMarkup = False
ActiveDocument.Save
Options.WarnBeforeSavingPrintingSendingMarkup = True
or, for more flexibility with systems that may not be using that setting:
Dim bWarn as Boolean
bWarn = Options.WarnBeforeSavingPrintingSendingMarkup
Options.WarnBeforeSavingPrintingSendingMarkup = False
ActiveDocument.Save
Options.WarnBeforeSavingPrintingSendingMarkup = bWarn
I have a workbook that I am trying to email with macros. This way the recipient will also be able to use the macros that are included with the workbook. This will make office life easier for my company. I have tried setting the saved file name to .xlsm, but that causes an error.
This is my code (which is adapted from sources online)
Sub MailGo()
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to
'a temporary file
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = "Text.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\Users\Public\Documents" & FileName
'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = "wesley.x.sherow#us.tel.com"
.Cc = ""
.Bcc = ""
.Subject = "LotInput"
.Body = "LotInput"
.Attachments.Add WB.FullName
.Display
.send
End With
'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
you need to also include this argument in your .SaveAs line.
FileFormat:=xlOpenXMLWorkbookMacroEnabled
My ultimate goal is to open an eml file in Excel vba and end up with the body of the message in a string that I can then use to search for different parameters. I've found a solution using MailItem and an Outlook application, however the machine I'm working on errors out when running this code:
Set MyOutlook = New Outlook.Application
Set x = MyOutlook.GetNamespace("MAPI")
Outlook 2013 opens, but then gives me an error message saying OLMAPI32.dll and then crashes. Eventually, I receive error 429 "ActiveX component can't create object."
I would like either a solution to this error or a workaround way to get the body of an eml file into a string. I've been successful at getting the subject of the email by using this code:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Pattern = "^Subject:"
Do Until objFile.AtEndOfStream
strSearchString = objFile.ReadLine
Set colMatches = objRegEx.Execute(strSearchString)
If colMatches.Count > 0 Then
Cells(i, n) = strSearchString
i = i + 1
Exit Do
End If
Loop
However, from examining a few random eml files, it doesn't appear like there is a way to flag the body of the text like I can with the subject.
Disregard the i and n, its not really relevant for this question. I'm just placing the subject in a cell determined elsewhere.
Any help is appreciated. Thanks!
Have you tried using the .Body function? This article may help.
Note that this code is performed inside of Outlook, not Excel.
Sub ExportToExcel(MyMail As MailItem) Dim strID As String, olNS As Outlook.Namespace Dim olMail As Outlook.MailItem Dim strFileName As String
'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
'~~> Show Excel
oXLApp.Visible = True
'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("C:\Sample.xls")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("Sheet1")
lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1
'~~> Write to outlook
With oXLws
'
'~~> Code here to output data from email to Excel File
'~~> For example
'
.Range("A" & lRow).Value = olMail.Subject
.Range("B" & lRow).Value = olMail.SenderName
.Range("C" & lRow).Value = olMail.Body
'.Range("C" & lRow).Value = olMail.HTMLBody
'
End With
'~~> Close and Clean up Excel
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub
I'm trying to import multiple .msg files into an Excel Sheet (msg body per row)but so far the only reference found was this here, so my code so far let you:
Select the folder path (where the .msg are located)
Loop through all the .msg files
But I'm unable to figure out how to achieve my objective. Thanks in advance for the response.
Code:
Sub importMsg()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim msg As MailItem
Dim OlApp As Object
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Main")
Set OlApp = CreateObject("Outlook.Application")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
i = 1
thisFile = Dir(inPath & "*.msg")
Do While thisFile <> ""
i = i + 1
Dim MyItem As Outlook.MailItem
Set MyItem = Application.CreateItemFromTemplate(thisFile)
'Set MyItem = Application.OpenSharedItem(thisFile)
ws.Cells(i, 1).Value = MyItem.Body
'MyItem.Body
'MyItem.Subject
'MyItem.Display
thisFile = Dir
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I found the error in the Do While Loop the variable thisFile wasn't maintaining the full path reference so I added the concatenation again and worked, code below:
Sub importMsg()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim Msg As MailItem
Dim ws As Worksheet
Dim myOlApp As Outlook.Application
Dim MyItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Worksheets("Main")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 4
Do While thisFile <> ""
Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
ws.Cells(i, 1) = MyItem.Body
i = i + 1
thisFile = Dir()
Loop
Set MyItem = Nothing
Set myOlApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I am attempting to construct code to remotely loop through a folder with .xls files and delete the macros contained within. So far I have the individual components working, but am having difficulties activating the various workbooks and then programmatically ensuring "Microsoft Visual Basic for Application Extensibility 5.3" is referenced within each file.
Thanks!
Sub LoopFiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
strPath = ' enter path here
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strPath)
For Each objfile In objFolder.Files
If objFso.GetExtensionName(objfile.Path) = "xls" Then
Set Objworkbook = objExcel.Workbooks.Open(objfile.Path)
' Include your code to work with the Excel object here
Objworkbook.Activate
AddReference (objfile)
Objworkbook.Close True 'Save changes
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Sub AddReference(FileRequired)
FileRequired.Activate
'MsgBox "Sheet: " & ActiveWorkbook.Name
ActiveWorkbook.VBProject.References.AddFromGuid _
GUID:="{0002E157-0000-0000-C000-000000000046}", _
Major:=5, Minor:=3
End Sub
Sub DeleteAllVBACode()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
End Sub
Like I mentioned in my comments, you do not need to add a reference to Microsoft Visual Basic for Application Extensibility 5.3 to delete the code from the files. Consider this small exercise.
1). Create an Excel file
2). Paste this code in a module
Sub Sample1()
MsgBox "A"
End Sub
3). Save the above file as C:\Sample.xls
4). Close the file
5). Open a new excel file and paste this code in a module
Option Explicit
'~~> Trust Access To Visual Basics Project must be enabled.
Sub Sample2()
Dim wb As Workbook
Dim i As Long
'~~> Replace this with the relevant file
'~~> We can open the files in a loop as well
Set wb = Workbooks.Open("C:\Sample.xls")
On Error Resume Next
With wb.VBProject
'~~> Remove the components
For i = .VBComponents.Count To 1 Step -1
.VBComponents.Remove .VBComponents(i)
Next i
'~~> Remove the code lines
For i = .VBComponents.Count To 1 Step -1
.VBComponents(i).CodeModule.DeleteLines _
1, .VBComponents(i).CodeModule.CountOfLines
Next i
End With
On Error GoTo 0
End Sub
6) Ensure that "Trust Access To Visual Basics Project" is enabled
7) Run the Sample2()
You will see that the code in Sample.xls is deleted and we haven't even set the reference to Microsoft Visual Basic for Application Extensibility 5.3.