Update vba/outlookReportExport.bas

Correcred file extension

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

vba/readme.md

@@ -0,0 +1 @@
+generated by chatGPT