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
页:
[1]