diff --git a/vba/outlookReportExport.bas b/vba/outlookReportExport.bas new file mode 100644 index 0000000..1f80dc0 --- /dev/null +++ b/vba/outlookReportExport.bas @@ -0,0 +1,292 @@ +Option Explicit + +' ---------- SETTINGS ---------- +' False = email must match ANY of the entered categories (OR) +' True = email must match ALL of the entered categories (AND) +Const USE_AND_LOGIC As Boolean = False + +' Use a fixed, hardcoded default for the Categories input box +Const USE_SMART_DEFAULTS As Boolean = False ' keep for future; not used here +Const DEFAULT_CATEGORIES As String = "Finance, Clients, HR, Legal, Billing" ' <-- edit to your needs + +' ------------------- CLEAN CSV FUNCTION ------------------- +Function CleanCSV(s As Variant) As String + If IsError(s) Or IsNull(s) Or Trim(s) = "" Then + CleanCSV = "" + Else + Dim tmp As String + tmp = Trim(CStr(s)) + tmp = Replace(tmp, """", """""") ' escape internal quotes for proper CSV + tmp = Replace(tmp, vbCrLf, " ") ' remove new lines + tmp = Replace(tmp, vbLf, " ") + tmp = Replace(tmp, vbCr, " ") + CleanCSV = tmp + End If +End Function + +' ------------------- UNIQUE FILE PATH HELPER ------------------- +Function GetUniqueFilePath(basePath As String) As String + Dim counter As Long + Dim newPath As String + Dim dotPos As Long + + ' If no conflict, use basePath as-is + If Dir(basePath) = "" Then + GetUniqueFilePath = basePath + Exit Function + End If + + dotPos = InStrRev(basePath, ".") + If dotPos = 0 Then dotPos = Len(basePath) + 1 + + counter = 2 + Do + newPath = Left(basePath, dotPos - 1) & "_v" & counter & Mid(basePath, dotPos) + If Dir(newPath) = "" Then + GetUniqueFilePath = newPath + Exit Function + End If + counter = counter + 1 + Loop +End Function + +' ------------------- RECURSIVE EXPORT FUNCTION ------------------- +Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, endDate As Date, _ + allowedCats() As String, includeNoCategory As Boolean) + Dim itm As Object + Dim mail As Outlook.MailItem + Dim line As String + Dim followUpText As String + Dim cats As String + Dim matchFound As Boolean + Dim subF As Outlook.Folder + Dim mailCats() As String + Dim mc As Variant, ac As Variant + Dim foundThis As Boolean + Dim acTrim As String + + For Each itm In folder.Items + If TypeOf itm Is Outlook.MailItem Then + Set mail = itm + + ' --- Date filter --- + If mail.ReceivedTime < startDate Or mail.ReceivedTime > endDate Then GoTo SkipItem + + ' --- Category filter with "include uncategorized" option --- + cats = Trim(mail.Categories) + + If cats = "" Then + ' No categories on this mail + matchFound = includeNoCategory + Else + ' Has categories -> apply normal logic (case-insensitive) + Dim catsLower As String + catsLower = LCase(cats) + matchFound = False + + If allowedCats(0) = "" Then + matchFound = True ' no filter list -> include all categorized emails + Else + mailCats = Split(catsLower, ",") + + If USE_AND_LOGIC Then + ' ---------- AND LOGIC ---------- + matchFound = True + For Each ac In allowedCats + acTrim = LCase(Trim(ac)) + If acTrim <> "" Then + foundThis = False + For Each mc In mailCats + If Trim(mc) = acTrim Then + foundThis = True + Exit For + End If + Next mc + If Not foundThis Then + matchFound = False + Exit For + End If + End If + Next ac + Else + ' ---------- OR LOGIC ---------- + For Each mc In mailCats + mc = Trim(mc) + For Each ac In allowedCats + acTrim = LCase(Trim(ac)) + If acTrim <> "" And mc = acTrim Then + matchFound = True + Exit For + End If + Next ac + If matchFound Then Exit For + Next mc + End If + End If + End If + + If Not matchFound Then GoTo SkipItem + + ' --- Follow-up status --- + Select Case mail.FlagStatus + Case olNoFlag: followUpText = "No Flag" + Case olFlagComplete: followUpText = "Complete" + Case olFlagMarked: followUpText = "Marked" + Case Else: followUpText = "Other" + End Select + + ' --- Build CSV line (folder name only) --- + line = """" & CleanCSV(mail.Subject) & """,""" & _ + CleanCSV(mail.SenderName) & """,""" & _ + Format(mail.ReceivedTime, "yyyy-mm-dd hh:nn") & """,""" & _ + CleanCSV(folder.Name) & """,""" & _ + CleanCSV(mail.Categories) & """,""" & _ + followUpText & """,""" & _ + CleanCSV(mail.ConversationTopic) & """" + + Print #fileNum, line + End If +SkipItem: + Next itm + + ' --- Recurse subfolders --- + For Each subF In folder.Folders + ExportFolder subF, fileNum, startDate, endDate, allowedCats, includeNoCategory + Next subF +End Sub + +' ------------------- MAIN MACRO ------------------- +Sub ExportEmailsToCSV() + Dim selectedFolder As Outlook.Folder + Dim fileNum As Long + Dim filePath As String + Dim startDateStr As String, endDateStr As String + Dim startDate As Date, endDate As Date + Dim categoriesInput As String + Dim allowedCats() As String + Dim catSuffix As String + Dim fileDatePrefix As String + Dim dateRangePart As String + Dim basePath As String + Dim includeNoCategory As Boolean + Dim resp As VbMsgBoxResult + Dim i As Long + Dim defaultCats As String + + ' --- Pick folder --- + Set selectedFolder = Application.Session.PickFolder + If selectedFolder Is Nothing Then Exit Sub + + ' --- Date range input --- + startDateStr = InputBox("Enter START date (YYYY-MM-DD) or leave blank for no limit:", _ + "Start Date", Format(Date - 1, "yyyy-mm-dd")) + If Trim(startDateStr) <> "" Then + If IsDate(startDateStr) Then + startDate = CDate(startDateStr) + Else + startDate = DateSerial(1900, 1, 1) + End If + Else + startDate = DateSerial(1900, 1, 1) + End If + + endDateStr = InputBox("Enter END date (YYYY-MM-DD) or leave blank for today:", _ + "End Date", Format(Date, "yyyy-mm-dd")) + If Trim(endDateStr) <> "" Then + If IsDate(endDateStr) Then + endDate = CDate(endDateStr) + Else + endDate = Now + End If + Else + endDate = Now + End If + + ' Make endDate inclusive if only a date was given + If endDate = Int(endDate) Then + endDate = endDate + TimeSerial(23, 59, 59) + End If + + ' --- Pre-populated categories (hardcoded) --- + defaultCats = DEFAULT_CATEGORIES + + ' --- Categories input --- + categoriesInput = InputBox( _ + "Enter category names separated by commas (e.g., Cat1,CatX)." & vbCrLf & _ + "Leave blank for no filter.", _ + "Categories Filter", defaultCats) + + ' Parse categories (trim each) + If Trim(categoriesInput) <> "" Then + allowedCats = Split(categoriesInput, ",") + For i = LBound(allowedCats) To UBound(allowedCats) + allowedCats(i) = Trim(allowedCats(i)) + Next i + Else + allowedCats = Split("", ",") ' no filter + End If + + ' --- Include emails with NO category? (Yes/No) --- + resp = MsgBox("Include emails with NO category?", vbQuestion + vbYesNo, "Include Uncategorized") + includeNoCategory = (resp = vbYes) + + ' --- File name components --- + fileDatePrefix = Format(Date, "yyyymmdd") + + ' Category suffix for filename (sanitized) + If Trim(categoriesInput) <> "" Then + catSuffix = Replace(categoriesInput, " ", "") + catSuffix = Replace(catSuffix, ",", "_") + catSuffix = Replace(catSuffix, "/", "-") + catSuffix = Replace(catSuffix, "\", "-") + catSuffix = Replace(catSuffix, ":", "-") + catSuffix = Replace(catSuffix, "*", "-") + catSuffix = Replace(catSuffix, "?", "") + catSuffix = Replace(catSuffix, """", "") + catSuffix = Replace(catSuffix, "<", "") + catSuffix = Replace(catSuffix, ">", "") + catSuffix = Replace(catSuffix, "|", "") + If Len(catSuffix) > 50 Then catSuffix = Left(catSuffix, 50) + catSuffix = "_" & catSuffix + Else + catSuffix = "" + End If + + ' Add marker if including uncategorized (optional but handy) + If includeNoCategory Then + If catSuffix = "" Then + catSuffix = "_Uncategorized" + Else + catSuffix = catSuffix & "_Uncategorized" + End If + End If + + ' Date range segment (use date-only for end) + dateRangePart = "_" & Format(startDate, "yyyy-mm-dd") & "-" & Format(Int(endDate), "yyyy-mm-dd") + + ' Base path according to your pattern: + ' CurrentDate_Emails_folderName_dateRange_categories.csv + basePath = Environ("USERPROFILE") & "\Desktop\" & _ + fileDatePrefix & "_Emails_" & Replace(selectedFolder.Name, " ", "_") & _ + dateRangePart & catSuffix & ".csv" + + ' Always get a safe/unique path (no overwrite) + filePath = GetUniqueFilePath(basePath) + + ' --- Open file & header --- + fileNum = FreeFile + Open filePath For Output As #fileNum + Print #fileNum, "Subject,Sender,ReceivedTime,Folder,Categories,FollowUpStatus,ConversationTopic" + + ' --- Export --- + ExportFolder selectedFolder, fileNum, startDate, endDate, allowedCats, includeNoCategory + + Close #fileNum + + ' --- Notify user --- + MsgBox "Export complete!" & vbCrLf & _ + "File saved as: " & filePath & vbCrLf & vbCrLf & _ + "Category logic: " & IIf(USE_AND_LOGIC, "AND (all categories must match)", "OR (any category may match)") & vbCrLf & _ + "Included uncategorized: " & IIf(includeNoCategory, "Yes", "No"), _ + vbInformation, "Export Complete" +End Sub \ No newline at end of file diff --git a/vba/readme.md b/vba/readme.md new file mode 100644 index 0000000..ccbc59d --- /dev/null +++ b/vba/readme.md @@ -0,0 +1 @@ +generated by chatGPT \ No newline at end of file