Option Explicit

' Toggle category logic:
' 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

' How many top categories to suggest by default
Const TOP_CATEGORIES_SUGGESTION As Long = 5

' ------------------- 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 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

' ------------------- CATEGORY STATS (for default suggestions) -------------------
Private Sub AccumulateCategoryCounts(folder As Outlook.Folder, _
                                     ByVal startDate As Date, ByVal endDate As Date, _
                                     ByRef dict As Object)
    Dim itm As Object
    Dim mail As Outlook.MailItem
    Dim cats As String, parts() As String
    Dim i As Long
    Dim subF As Outlook.Folder

    For Each itm In folder.Items
        If TypeOf itm Is Outlook.MailItem Then
            Set mail = itm
            If mail.ReceivedTime >= startDate And mail.ReceivedTime <= endDate Then
                cats = Trim(mail.Categories)
                If cats <> "" Then
                    parts = Split(cats, ",")
                    For i = LBound(parts) To UBound(parts)
                        Dim key As String
                        key = LCase(Trim(parts(i)))
                        If key <> "" Then
                            If Not dict.Exists(key) Then
                                dict.Add key, 1
                            Else
                                dict(key) = CLng(dict(key)) + 1
                            End If
                        End If
                    Next i
                End If
            End If
        End If
    Next itm

    ' Recurse subfolders
    For Each subF In folder.Folders
        AccumulateCategoryCounts subF, startDate, endDate, dict
    Next subF
End Sub

Private Function GetTopCategoriesCSV(folder As Outlook.Folder, _
                                     ByVal startDate As Date, ByVal endDate As Date, _
                                     ByVal topN As Long) As String
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' late-bound
    Dim keys() As Variant, counts() As Long
    Dim i As Long, j As Long
    Dim tmpKey As Variant, tmpCount As Long
    Dim result As String, shown As Long

    AccumulateCategoryCounts folder, startDate, endDate, dict

    If dict.Count = 0 Then
        GetTopCategoriesCSV = ""
        Exit Function
    End If

    ' Copy to arrays for sorting
    ReDim keys(0 To dict.Count - 1)
    ReDim counts(0 To dict.Count - 1)
    i = 0
    Dim k As Variant
    For Each k In dict.Keys
        keys(i) = k
        counts(i) = CLng(dict(k))
        i = i + 1
    Next k

    ' Simple bubble sort by count DESC (dict is usually small)
    For i = LBound(counts) To UBound(counts)
        For j = i + 1 To UBound(counts)
            If counts(j) > counts(i) Then
                tmpCount = counts(i): counts(i) = counts(j): counts(j) = tmpCount
                tmpKey = keys(i): keys(i) = keys(j): keys(j) = tmpKey
            End If
        Next j
    Next i

    ' Build comma-separated list (restore original case by using keys as-is; they are lowercased)
    result = ""
    shown = 0
    For i = LBound(keys) To UBound(keys)
        If shown >= topN Then Exit For
        If result <> "" Then result = result & ","
        ' Capitalize first letter (optional cosmetic)
        result = result & UCase(Left(CStr(keys(i)), 1)) & Mid(CStr(keys(i)), 2)
        shown = shown + 1
    Next i

    GetTopCategoriesCSV = result
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
                If includeNoCategory Then
                    matchFound = True
                Else
                    matchFound = False
                End If
            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 defaultCats As String
    Dim i As Long

    ' --- 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)

    ' --- Build default categories suggestion from most-used within date range ---
    defaultCats = GetTopCategoriesCSV(selectedFolder, startDate, endDate, TOP_CATEGORIES_SUGGESTION)

    ' --- Categories input (pre-populated with defaults if any) ---
    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 ---
    Dim fileDatePrefixDate As Date
    fileDatePrefixDate = Date

    fileDatePrefix = Format(fileDatePrefixDate, "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: 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