'--##2021-10-28 - Boso - FullFilePath // utf-8
Option Explicit
Dim fs As Scripting.FileSystemObject
Dim txt
Private Sub ACapo()
txt.WriteText vbCrLf
End Sub
Public Function parseString(s) As String
Dim res As String
If IsNull(s) Then
res = ""
Else
res = ""
res = res & Chr(34)
res = res & Replace(s, Chr(34), Chr(34) & Chr(34))
res = res & Chr(34)
End If
parseString = res
End Function
Private Sub ScriviRiga(taskFolder As Outlook.Folder)
Dim olnameSpace As Outlook.NameSpace
Dim tasks As Outlook.Items
Dim x As Long
Dim tsk As Outlook.TaskItem
Dim s As String
Dim wDataCrea As String
Dim wDataScad As String
Set tasks = taskFolder.Items
Set tasks = taskFolder.Items
For x = 1 To tasks.Count
Set tsk = tasks.Item(x)
If Not tsk.Complete Then
Debug.Print Space(4) & Left(tsk.Subject, 50)
With tsk
wDataScad = ""
If .DueDate <> DateSerial(4501, 1, 1) Then
wDataScad = .DueDate
End If
wDataCrea = ""
If .CreationTime <> DateSerial(4501, 1, 1) Then
wDataCrea = .CreationTime
End If
s = taskFolder.Name & "|" & wDataCrea & "|" & wDataScad & "|" & parseString(.Subject) & "|" & parseString(.Body)
txt.WriteText s
ACapo
' If LCase(.Subject) Like LCase("*Port of Earth*") Then Stop
End With
End If
Next x
Set olnameSpace = Nothing
Set tasks = Nothing
Set tsk = Nothing
End Sub
Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder)
Dim folders As Outlook.folders
Dim Folder As Outlook.Folder
Dim foldercount As Integer
On Error Resume Next
Set folders = oFolder.folders
foldercount = folders.Count
'Check if there are any folders below oFolder
If foldercount Then
For Each Folder In folders
If LCase(Folder.FolderPath) Like "*task*" Then
Debug.Print Folder.Name
ScriviRiga Folder
EnumerateFolders Folder
End If
Next
End If
Set folders = Nothing
Set Folder = Nothing
End Sub
Private Sub InitTXT(FullFilePath As String)
Dim s As String
Set txt = CreateObject("ADODB.Stream")
With txt
.Type = 2 ' Specify stream type - we want To save text/string data.
.Charset = "utf-8" ' Specify charset For the source text data.
.Open ' Open the stream And write binary data To the object
End With
s = "FolderName|CreationTime|DueDate|Subject|Body"
txt.WriteText s
ACapo
End Sub
Sub Main()
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oRoot As Outlook.Folder
Dim FullFilePath As String
Set fs = New Scripting.FileSystemObject
FullFilePath = "C:\Users\Boso\Downloads\BakToDo\Tasks.csv"
InitTXT FullFilePath
On Error Resume Next
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oRoot = oStore.GetRootFolder
Debug.Print (oRoot.FolderPath)
EnumerateFolders oRoot
Next
txt.SaveToFile FullFilePath, 2 'Save binary data To disk
txt.Close
Set txt = Nothing
Set fs = Nothing
Set colStores = Nothing
Set oStore = Nothing
Set oRoot = Nothing
Debug.Print
Debug.Print "** FINE"
Debug.Print
Debug.Print "File creato: " & FullFilePath
End Sub
