Upload files to "vba"
V0.1
This commit is contained in:
hyperaktiveSloth
parent
d3b97041eb
commit
f405eeb248
1 changed files with 191 additions and 59 deletions
|
|
@ -5,6 +5,9 @@ Option Explicit
|
|||
' 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
|
||||
|
|
@ -26,16 +29,13 @@ Function GetUniqueFilePath(basePath As String) As String
|
|||
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
|
||||
End If
|
||||
If dotPos = 0 Then dotPos = Len(basePath) + 1
|
||||
|
||||
counter = 2
|
||||
Do
|
||||
|
|
@ -48,8 +48,99 @@ Function GetUniqueFilePath(basePath As String) As String
|
|||
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)
|
||||
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
|
||||
|
|
@ -65,56 +156,69 @@ Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, e
|
|||
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 ---
|
||||
cats = LCase(Trim(mail.Categories))
|
||||
matchFound = False
|
||||
|
||||
If allowedCats(0) = "" Then
|
||||
matchFound = True ' no filter
|
||||
ElseIf cats <> "" Then
|
||||
mailCats = Split(cats, ",")
|
||||
|
||||
If USE_AND_LOGIC Then
|
||||
' ---------- AND LOGIC ----------
|
||||
|
||||
' --- Category filter with "include uncategorized" option ---
|
||||
cats = Trim(mail.Categories)
|
||||
|
||||
If cats = "" Then
|
||||
' No categories on this mail
|
||||
If includeNoCategory Then
|
||||
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)
|
||||
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 <> "" And mc = acTrim Then
|
||||
matchFound = True
|
||||
Exit For
|
||||
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
|
||||
If matchFound Then Exit For
|
||||
Next mc
|
||||
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"
|
||||
|
|
@ -122,7 +226,7 @@ Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, e
|
|||
Case olFlagMarked: followUpText = "Marked"
|
||||
Case Else: followUpText = "Other"
|
||||
End Select
|
||||
|
||||
|
||||
' --- Build CSV line (folder name only) ---
|
||||
line = """" & CleanCSV(mail.Subject) & """,""" & _
|
||||
CleanCSV(mail.SenderName) & """,""" & _
|
||||
|
|
@ -131,15 +235,15 @@ Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, e
|
|||
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
|
||||
ExportFolder subF, fileNum, startDate, endDate, allowedCats, includeNoCategory
|
||||
Next subF
|
||||
End Sub
|
||||
|
||||
|
|
@ -156,6 +260,10 @@ Sub ExportEmailsToCSV()
|
|||
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
|
||||
|
|
@ -187,21 +295,36 @@ Sub ExportEmailsToCSV()
|
|||
End If
|
||||
|
||||
' Make endDate inclusive if only a date was given
|
||||
If endDate = Int(endDate) Then
|
||||
endDate = endDate + TimeSerial(23, 59, 59)
|
||||
End If
|
||||
If endDate = Int(endDate) Then endDate = endDate + TimeSerial(23, 59, 59)
|
||||
|
||||
' --- Categories input ---
|
||||
categoriesInput = InputBox("Enter category names separated by commas (e.g., Cat1,CatX):", _
|
||||
"Categories Filter", "")
|
||||
' --- 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 ---
|
||||
fileDatePrefix = Format(Date, "yyyymmdd")
|
||||
Dim fileDatePrefixDate As Date
|
||||
fileDatePrefixDate = Date
|
||||
|
||||
fileDatePrefix = Format(fileDatePrefixDate, "yyyymmdd")
|
||||
|
||||
' Category suffix for filename (sanitized)
|
||||
If Trim(categoriesInput) <> "" Then
|
||||
|
|
@ -222,11 +345,19 @@ Sub ExportEmailsToCSV()
|
|||
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
|
||||
' Base path: CurrentDate_Emails_folderName_dateRange_categories.csv
|
||||
basePath = Environ("USERPROFILE") & "\Desktop\" & _
|
||||
fileDatePrefix & "_Emails_" & Replace(selectedFolder.Name, " ", "_") & _
|
||||
dateRangePart & catSuffix & ".csv"
|
||||
|
|
@ -240,13 +371,14 @@ Sub ExportEmailsToCSV()
|
|||
Print #fileNum, "Subject,Sender,ReceivedTime,Folder,Categories,FollowUpStatus,ConversationTopic"
|
||||
|
||||
' --- Export ---
|
||||
ExportFolder selectedFolder, fileNum, startDate, endDate, allowedCats
|
||||
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)"), _
|
||||
"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
|
||||
Loading…
Add table
Add a link
Reference in a new issue