Outlook amend project list export for mailItem
For Thisoutlooksession:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arrEntryIDs() As String ''Ids of incomingbatch of emails
Dim i As Integer ''generic counter
Dim otlObjItem As Object ''Outlook.MailItem
Dim mailItem As Outlook.mailItem ''Friendly Mailitem reference
Dim strout As String ''message collection
' Split the EntryIDCollection into an array
arrEntryIDs = Split(EntryIDCollection, ",")
' Loop through each entry ID and process the mail item
For i = LBound(arrEntryIDs) To UBound(arrEntryIDs)
' Get the mail item using the entry ID
Set otlObjItem = Application.Session.GetItemFromID(arrEntryIDs(i))
If otlObjItem.Class = olMail Then ''Is MailItem
Set mailItem = otlObjItem
''to keep ThisOutlookSession Lean there is a Rules_ function that does the processing.
''RULES_ coul dbe one module but is in each module for testing currently.
''otlSave.Mailitem_SaveAttachments otlObjItem, Messages:=False ''CheckRules on Saving Attachments
If mailItem.Subject Like "Project List Export Report" Then ''Trigger list export
otlProjectListAmend.ProjectListExport mailItem ''
End If
otlMove.RULES_MoveMail mailItem ''Run rules formove on mailitem
End If
Next i
End Sub
The module:
Attribute VB_Name = "otlProjectListAmend"
Option Explicit
Option Compare Text
#If VBA7 Then
Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) As Long
Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
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
#End If
Const cDateTime = "Date_Time"
Const cYMDHMS = "yyyy-MM-ddTHHNN" ''date time format
Const xlWSName = "Sheet1"
Const excelFileName = "0000-Project-List-Export.xlsx" ' Constant file name
Private Sub ProjectListExport_Selected()
Dim olApp As Outlook.Application
Dim selectedItems As Outlook.Selection
Dim selectedMail As Outlook.mailItem
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
' Initialize Outlook application
Set olApp = New Outlook.Application
' Initialize Excel application if not already set
If xlApp Is Nothing Then Set xlApp = New Excel.Application
' Get the currently selected items
Set selectedItems = olApp.ActiveExplorer.Selection
' Check if any items are selected
If selectedItems.Count > 0 Then
' Iterate through each selected item
For Each selectedMail In selectedItems
' Call the main processing subroutine with the selected mail item
ProjectListExport selectedMail, xlApp, xlWB
Next selectedMail
Else
MsgBox "No mail items are selected.", vbExclamation, "Selection Error"
End If
' Clean up Excel application after all exports
If Not xlApp Is Nothing Then ExcelEnd xlApp
' Clean up Outlook objects
Set selectedItems = Nothing
Set olApp = Nothing
End Sub
Sub ProjectListExport(mailItem As Outlook.mailItem, Optional ByRef xlApp As Excel.Application, Optional ByRef xlWB As Excel.Workbook)
Dim olNS As Outlook.Namespace
Dim attachment As Outlook.attachment
Dim csvFileName As String
Dim csvFilePath As String
Dim excelFilePath As String
Dim headers As Variant
''Dim xlWB As Excel.Workbook
Dim InitInternal As Boolean ''determine if passed excel apps or created here in direct call for iterative emails
' Initialize Outlook objects
Set olNS = Application.GetNamespace("MAPI")
' Define headers from CSV
headers = Array(cDateTime, "detail_Project", "detail_Phase", "detail_Task", _
"detail_Task_Name", "detail_Organization_Name", "detail_Project_Manager_Name", _
"detail_UDCol_CustProjectManagerArchitect", "detail_UDCol_CustProjectManagerLand", _
"detail_UDCol_CustSrProjectManager", "detail_project_Type", "detail_UDCol_CustDisciplines", _
"detail_Address1", "detail_Address2", "detail_City", "detail_State", _
"detail_UDCol_CustPRBIMRequestSubmitter", "detail_UDCol_CustPRBIMRequestDate")
' Set Excel file path
excelFilePath = "C:\_REVIT\Project-List-Export\" & excelFileName
' Check if the mail item has attachments
If mailItem.Attachments.Count > 0 Then
' Check if Excel application is already initialized
If xlApp Is Nothing Then
Set xlApp = New Excel.Application
End If
For Each attachment In mailItem.Attachments
' Check if attachment is "Project List Export.csv"
If InStr(1, attachment.FileName, "Project List Export.csv", vbTextCompare) > 0 Then
If xlApp Is Nothing Then
InitInternal = True ''was initialized HERE....
Set xlApp = New Excel.Application
End If
' Save attachment to local folder with timestamp suffix
csvFileName = "Project_List_Export_" & Format(mailItem.SentOn, cYMDHMS) & ".csv"
csvFilePath = "C:\_REVIT\Project-List-Export\" & csvFileName
attachment.SaveAsFile csvFilePath
' Call subroutine to handle Excel operations
HandleExcelOperations xlApp, xlWB, excelFilePath, headers, xlWSName, csvFilePath, mailItem
''Exit For ' Exit loop after processing the required attachment
End If
Next attachment
End If
' Clean up Outlook objects
Set olNS = Nothing
If InitInternal Then ''this sub initialized excel and needs to force close
xlWB.Save ''save excel
xlApp.Quit ''Clean up Excel application after all exports
If Not xlApp Is Nothing Then ExcelEnd xlApp
Set xlWB = Nothing
Set xlApp = Nothing
End If
End Sub
Private Sub HandleExcelOperations(ByRef xlApp As Excel.Application, ByRef xlWB As Excel.Workbook, ByVal excelFilePath As String, headers As Variant, ByVal xlWSName As String, ByVal csvFilePath As String, ByVal mailItem As Outlook.mailItem)
Dim xlWS As Worksheet
Dim colIndex As Integer
Dim csvFile As Object
Dim csvData As String
Dim csvCol As Variant
Dim rowIndex As Long
Dim dateTimeExists As Boolean
Dim irow As Long
Dim csvRow As Long
Dim headerMatch As Boolean
' Check if workbook needs to be opened or created
If Dir(excelFilePath) = "" Then
' Create new Excel file and add headers
Set xlWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets(1)
xlWS.name = xlWSName ' Rename the default sheet
' Add headers to the first row of the worksheet
For colIndex = LBound(headers) To UBound(headers)
xlWS.Cells(1, colIndex + 1).Value = headers(colIndex)
Next colIndex
' Save the workbook
xlWB.SaveAs excelFilePath
Else
' Open existing Excel file
Set xlWB = xlApp.Workbooks.Open(excelFilePath)
Set xlWS = xlWB.Worksheets(xlWSName)
' Check if headers match the expected headers
headerMatch = True
For colIndex = LBound(headers) To UBound(headers)
If xlWS.Cells(1, colIndex + 1).Value <> headers(colIndex) Then
headerMatch = False
Exit For
End If
Next colIndex
If Not headerMatch Then
MsgBox "The headers in the CSV file do not match the headers in the existing Excel file. Please update the CSV file or create a new sheet.", vbExclamation, "Header Mismatch"
xlWB.Close False ' Close workbook without saving changes
Exit Sub
End If
End If
' Open CSV file and read data line by line
Set csvFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(csvFilePath, 1)
csvRow = 0
' Read Headers
csvData = csvFile.ReadLine
CleanLine csvData ' Clean up non-essential characters
csvRow = csvRow + 1
csvData = cDateTime & "," & csvData ''prefix added date-time column
headers = Split(csvData, ",")
'''''''''''''''''''''''''''''''''''''''''''
' Check if headers match of the files to see if the expected headers are in the file
headerMatch = True
For colIndex = LBound(headers) To UBound(headers)
If xlWS.Cells(1, colIndex + 1).Value <> headers(colIndex) Then
headerMatch = False
Exit For
End If
Next colIndex
If Not headerMatch Then
If MsgBox("Header mismatch, OK to create new sheet, CANCEL to skip import.", vbOKCancel + vbCritical, "Error") = vbOK Then
Set xlWS = Nothing
On Error Resume Next
Set xlWS = xlWB.Worksheets(Format(mailItem.SentOn, cYMDHMS)) ''use sent on as name of WS
On Error GoTo 0
If Not xlWS Is Nothing Then
Exit Sub ''already imported
Else
Set xlWS = xlWB.Worksheets.Add
xlWS.name = Format(mailItem.SentOn, cYMDHMS)
End If
Else
Exit Sub
End If
End If
' Process each line of the CSV file
' Check if the date-time already exists in Excel
dateTimeExists = False
For irow = 2 To xlWS.Cells(xlWS.Rows.Count, 1).End(xlUp).Row
If xlWS.Cells(irow, 1).Value = mailItem.SentOn Then
dateTimeExists = True
Exit For
End If
Next irow
' If the date-time does not exist, add the data to Excel
If Not dateTimeExists Then
Do Until csvFile.AtEndOfStream
csvData = csvFile.ReadLine
CleanLine csvData ' Clean up non-essential characters
rowIndex = xlWS.Cells(xlWS.Rows.Count, 1).End(xlUp).Row + 1
xlWS.Cells(rowIndex, 1).Value = mailItem.SentOn ' Date_Time column
csvCol = ""
csvCol = Split(csvData, ",")
For colIndex = LBound(csvCol) To UBound(csvCol)
xlWS.Cells(rowIndex, colIndex + 2).Value = csvCol(colIndex)
Next colIndex
Loop
End If
csvRow = csvRow + 1
' Close CSV file
csvFile.Close
Set csvFile = Nothing
''Save Excel workbook (not closing here)
xlWB.Save
End Sub
Sub CleanLine(ByRef StrLine As String)
If Len(StrLine) > 0 Then
Do While (Asc(Left(StrLine, 1)) < 10 Or Asc(Left(StrLine, 1)) > 127)
StrLine = Right(StrLine, Len(StrLine) - 1)
Loop
End If
End Sub
Private Sub ExcelEnd(ByRef xlApp As Excel.Application)
xlApp.Quit
''xlapp.Wait (Now + TimeValue("0:00:02"))
Dim ProcID As Long
On Error Resume Next
ProcID = GetExcelProcessID(xlApp)
If ProcID <> 0 Then
Call Shell("taskkill /f /pid " & ProcID, vbHide)
End If
Set xlApp = Nothing
End Sub
Sub CheckAndCloseExcelInstances()
Dim xlApp As Object
Dim xlProcID As Long
' Attempt to get existing Excel instances
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo 0
' Loop through all Excel instances
Do While Not xlApp Is Nothing
' Get the process ID of the Excel instance
xlProcID = GetExcelProcessID(xlApp)
' Check if there are any open workbooks
If xlApp.Workbooks.Count = 0 Then
' No open workbooks, close the Excel instance
xlApp.Quit
' Terminate Excel process using the obtained process ID
If xlProcID <> 0 Then
Call Shell("taskkill /f /pid " & xlProcID, vbHide)
End If
Else
' Iterate through each open workbook
Dim wb As Object
For Each wb In xlApp.Workbooks
' Optionally, perform actions on each open workbook
Debug.Print "Workbook Name: " & wb.name
Next wb
End If
' Release object reference
Set xlApp = Nothing
' Attempt to get the next Excel instance
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo 0
Loop
' Clean up
Set xlApp = Nothing
End Sub
Function GetExcelProcessID(xlApp As Object) As Long
Dim xlHwnd As Long
Dim xlProcID As Long
' Get the window handle (hWnd) of the Excel application
xlHwnd = xlApp.hWnd
' Get the process ID (PID) of the Excel application using the window handle
If xlHwnd <> 0 Then
Call GetWindowThreadProcessId(xlHwnd, xlProcID)
End If
' Return the process ID
GetExcelProcessID = xlProcID
End Function
Comments
Post a Comment