VB6中處理OutLook文件夾的Module

' ********************************************************************
'
' Description : 按Treeview中的節點信息,讀取/添加到OutLook文件夾

'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               26/03/2006            Class created
'   RogerWang               29/03/2006            Class Modified
' *********************************************************************

Option   Explicit


Dim  objApp  As  Outlook.Application
Dim  objNameSpace  As  Outlook.NameSpace
Dim  m_objFolders  As  Collection
Dim  Cur_Folder  As  mapiFolder

Public  vTreeview  As  TreeView
Public  objMAPIFolder  As  Outlook.mapiFolder

' ********************************************************************
' Description : 初始化與OutLook信息相關的對象
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               26/03/2006            Class created
' *********************************************************************
Public   Function InitOutLookObj() Function InitOutLookObj() As Boolean
    If objApp Is Nothing Then
       Set objApp = New Outlook.Application
    End If
    If objNameSpace Is Nothing Then
       Set objNameSpace = objApp.GetNamespace(Type:="MAPI")
    End If
    
    If objMAPIFolder Is Nothing Then
       Set objMAPIFolder = objNameSpace.GetDefaultFolder(olFolderInbox) '收件匣
       Set Cur_Folder = objMAPIFolder
    End If
    
    If m_objFolders Is Nothing Then
      Set m_objFolders = New Collection
    End If
        
End Function


' ********************************************************************
' Description : 釋放與OutLook信息相關的對象
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               26/03/2006            Class created
' *********************************************************************

Public   Function FreeOutLookObj() Function FreeOutLookObj() As Boolean
    If Not objApp Is Nothing Then
       Set objApp = Nothing
    End If

    If Not objNameSpace Is Nothing Then
       Set objNameSpace = Nothing
    End If

    If Not objMAPIFolder Is Nothing Then
       Set objMAPIFolder = Nothing
    End If
    
    If Not m_objFolders Is Nothing Then
      Set m_objFolders = Nothing
    End If
    
    If Not vTreeview Is Nothing Then
       Set vTreeview = Nothing
    End If
End Function

' ********************************************************************
' Description : 將OutLook文件夾信息裝載進vTreeView中
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               27/03/2006            Class created
' *********************************************************************
Public   Function LoadOutLookFolder() Function LoadOutLookFolder() As Boolean
   On Error GoTo ErrHandle
   
   Dim i As Integer '用來取得收件匣下面的文件夾數目
   Dim objNode As Node
   
   LoadOutLookFolder = True
      
   '清除所有Node
   vTreeview.Nodes.Clear
   
   InitOutLookObj
      
   Set objNode = vTreeview.Nodes.Add(, , objMAPIFolder.EntryID, objMAPIFolder.Name, 3, 3)
   Call m_objFolders.Add(objMAPIFolder, objMAPIFolder.EntryID)
   'objNode.ForeColor = vbBlack
   
   objNode.Expanded = True
   
   If objMAPIFolder.Folders.Count > 0 Then
      Call LoadChildNode(objMAPIFolder, objNode)
   End If
   
Exit Function
ErrHandle:
   MsgBox "裝載OutLook文件夾出錯", vbInformation
   FreeOutLookObj
End Function

' ********************************************************************
' Description : 遞歸讀取文件夾
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               27/03/2006            Class created
' *********************************************************************
Public   Function LoadChildNode() Function LoadChildNode(ByVal SourceFolder As mapiFolder, ByVal sourceNode As Node) As Boolean
    On Error GoTo ErrHandle
    
    LoadChildNode = True
    Dim i As Integer
    Dim DestFolder As mapiFolder
    Dim DestNode As Node
    
    sourceNode.Expanded = True
    For i = 1 To SourceFolder.Folders.Count
        Set DestNode = vTreeview.Nodes.Add(SourceFolder.EntryID, tvwChild, SourceFolder.Folders.Item(i).EntryID, _
           SourceFolder.Folders.Item(i).Name, 1, 2)
        Call m_objFolders.Add(SourceFolder.Folders.Item(i), SourceFolder.Folders.Item(i).EntryID)
        
        Set DestFolder = SourceFolder.Folders.Item(i)
        
        If DestFolder.Folders.Count > 0 Then
           Call LoadChildNode(DestFolder, DestNode)
        End If
    Next i
    
    If Not DestFolder Is Nothing Then
       Set DestFolder = Nothing
    End If
    
    If Not DestNode Is Nothing Then
       Set DestNode = Nothing
    End If
Exit Function
ErrHandle:
    If Not DestFolder Is Nothing Then
       Set DestFolder = Nothing
    End If
    
    If Not DestNode Is Nothing Then
       Set DestNode = Nothing
    End If
End Function

' ********************************************************************
' Description : 從應用程序目錄下同名Txt文件讀取要添加的文件夾列表
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               27/03/2006            Class created
' *********************************************************************

Public   Function LoadTxtFile() Function LoadTxtFile() As Boolean
   On Error GoTo ErrHandle
   Dim l_objFS As New FileSystemObject
   Dim l_objFile As TextStream
   
   Dim sFileName As String
   Dim sfileContents    As String
   Dim FolderList() As String
   Dim i As Integer
   
   sFileName = App.Path & "\" & App.EXEName & ".ini"
   Set l_objFile = l_objFS.OpenTextFile(sFileName, ForReading, False, TristateUseDefault)
   sfileContents = l_objFile.ReadAll()
   l_objFile.Close
   
   Set l_objFile = Nothing
   Set l_objFS = Nothing
  

   '以換行符分拆sfileContents成一個字符串數組
   FolderList = Split(sfileContents, vbCrLf)
   
   For i = LBound(FolderList) To UBound(FolderList)
      Call SplitArr(FolderList(i))
   Next i
      
Exit Function
ErrHandle:
   If Not l_objFile Is Nothing Then
      Set l_objFile = Nothing
   End If
   
   If Not l_objFS Is Nothing Then
      Set l_objFS = Nothing
   End If
End Function

' ********************************************************************
' Description : 將每行字符串拆分成一個字符串數組
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               28/03/2006            Class created
' *********************************************************************

Public   Function SplitArr() Function SplitArr(ByVal vstrFolder As String) As Boolean
    Dim FolderArr() As String
    Dim i As Integer
    
    FolderArr = Split(vstrFolder, "]]-[[")
    
    '除去兩端的特殊字符串
    If (UBound(FolderArr) - LBound(FolderArr)) > 0 Then
       FolderArr(LBound(FolderArr)) = Replace(FolderArr(LBound(FolderArr)), "[[", "", 1, 1)
       FolderArr(UBound(FolderArr)) = Replace(FolderArr(UBound(FolderArr)), "]]", "", 1, 1)
    End If
   
   '根據字符串數組,檢查Treeview中是否有相應節點,如果沒有則新增,否則用顏色標出
    Call CheckTreeviewNode(FolderArr)
End Function

' ********************************************************************
' Description : 將字符串數組中每一個字符串對應到相應的vTreeView的Node中
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               28/03/2006            Class created
' *********************************************************************
Public   Function CheckTreeviewNode() Function CheckTreeviewNode(ByRef vstrFolder() As String) As Boolean
    On Error GoTo ErrHandle
    Dim i, j As Integer
    Dim Cur_Node As Node
    
    Set Cur_Node = vTreeview.Nodes.Item(1)
    
    
    For i = LBound(vstrFolder) + 1 To UBound(vstrFolder)
        If i = UBound(vstrFolder) Then
            Call CheckSubNode(Cur_Node, vstrFolder(i), True)
        Else
            Call CheckSubNode(Cur_Node, vstrFolder(i), False)
        End If
       
    Next i
            
    Set Cur_Node = Nothing
Exit Function
ErrHandle:
    Set Cur_Node = Nothing
End Function

' ********************************************************************
' Description : 將字符串數組裝載進vTreeView中
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               29/03/2006            Class created
' *********************************************************************
Public   Function CheckSubNode() Function CheckSubNode(ByRef Cur_Node As Node, ByVal NodeName As String, ByVal isEnd As Boolean) As Node
    On Error GoTo ErrHandle
    Dim Dest_Node As Node
        
    If Cur_Node.Children = 0 Then
        Set Cur_Node = vTreeview.Nodes.Add(Cur_Node.Key, tvwChild, Cur_Node.Key & NodeName, NodeName, 1, 2)
        Cur_Node.Expanded = True
        
    Else
        Set Dest_Node = Cur_Node.Child
        
        Do
        
            If UCase(Trim$(Dest_Node.Text)) = UCase(Trim$(NodeName)) Then
                Set Cur_Node = Dest_Node
                Cur_Node.Expanded = True
                If isEnd Then
                    Cur_Node.ForeColor = vbBlue
                End If
                Exit Function
            Else
                Set Dest_Node = Dest_Node.Next
            End If
        Loop Until Dest_Node Is Nothing
            
        Set Dest_Node = vTreeview.Nodes.Add(Cur_Node.Key, tvwChild, Cur_Node.Key & NodeName, NodeName, 1, 2)
        Set Cur_Node = Dest_Node

    End If
    Cur_Node.Expanded = True
    Cur_Node.ForeColor = vbRed
    
    Set Dest_Node = Nothing
        
Exit Function
ErrHandle:
    Set Dest_Node = Nothing
    Debug.Print Err.Description
End Function

' ********************************************************************
' Description : 將vTreeView目錄樹信息裝載入OutLook文件夾中
'  ================================================================
'     Name                   Date                  Description
'   ---------           ---------------        -------------------
'   RogerWang               27/03/2006            Class created
' *********************************************************************
' 遞歸從vTreeview中讀出Node,根據foreColre顏色來判斷是不是要新增
Public   Function CheckOutLookFolder() Function CheckOutLookFolder(ByRef Source_Folder As mapiFolder, ByRef Source_Node As Node) As Boolean
    On Error GoTo ErrHandle
    Dim Dest_Folder As mapiFolder
    Dim Dest_Node As Node
    
    If Source_Node.Children > 0 Then
        Set Dest_Node = Source_Node.Child
        
        Do
            '如果是紅色,則新增文件夾
            If Dest_Node.ForeColor = vbRed Then
               Set Dest_Folder = Source_Folder.Folders.Add(Dest_Node.Text)
            '否則遞歸下一個目的文件夾
            Else
               Set Dest_Folder = m_objFolders.Item(Dest_Node.Key)
            End If
            
            Call CheckOutLookFolder(Dest_Folder, Dest_Node)
            Set Dest_Node = Dest_Node.Next
        Loop Until Dest_Node Is Nothing
    End If
    
    Set Dest_Node = Nothing
    Set Dest_Folder = Nothing
Exit Function
ErrHandle:
    Set Dest_Node = Nothing
    Set Dest_Folder = Nothing
End Function

转载于:https://www.cnblogs.com/dotnetbbs/archive/2006/05/09/394750.html