用递归,一层层的,很简单的
Private Sub CmdSysnch_Click()
    Dim TempTree As String
    Me.MousePointer = 11
'On Error GoTo CHkerrorSysnch:
    sTemp = PISServerComm.BeginDataTransfer(AllNumber)        '通知服务器开始数据传输
    If Left(sTemp, 1) = Chr(0) Then
        For i = 1 To FindOutlookConnt.Count
            If TViewOutlook.Nodes(i).Checked = True Then
                TempTree = TempTree & CStr(i)
                If FindOutlookConnt(i).ParentIndex = -1 Then
                    '一级文件夹
                    '在服务器数据库创建文件夹
                    sTemp = PISServerComm.CreateRootFolder(AllNumber, FindOutlookConnt(i))
                Else
                    '子文件夹
                    '在服务器数据库创建文件夹
                    sTemp = PISServerComm.CreateSubFolder(AllNumber, FindOutlookConnt(i), _
                                    FindOutlookConnt(FindOutlookConnt(i).ParentIndex))
                End If
                If Left(sTemp, 1) = Chr(0) Then
                    Select Case FindOutlookConnt.Item(i).FolderType
                        Case itContact
                            '联系人文件夹
                            Dim Items1 As New MsFoderDll.ContactItems
                            '从OUTLOOK读取本文件夹下的资料
                            ModTemp.RetriveContactFolder FindOutlookConnt(i), Items1
                            For j = 1 To Items1.Count
                                '将一笔资料上传到服务器
                                sTemp = PISServerComm.UploadContact(AllNumber, _
                                            FindOutlookConnt(i), Items1(j))
                                If Left(sTemp, 1) <> Chr(0) Then
                                    MsgBox sTemp, vbInformation + vbOKOnly, "信息"
                                    Me.MousePointer = 0
                                    Exit Sub
                                End If
                            Next
                        Case itTask
                            '任务文件夹
                            Dim Items2 As New MsFoderDll.TaskItems
                            '从OUTLOOK读取本文件夹下的资料
                            ModTemp.RetriveTaskFolder FindOutlookConnt(i), Items2
                            For j = 1 To Items2.Count
                                '将一笔资料上传到服务器
                                sTemp = PISServerComm.UploadTask(AllNumber, _
                                            FindOutlookConnt(i), Items2(j))
                                If Left(sTemp, 1) <> Chr(0) Then
                                    MsgBox sTemp, vbInformation + vbOKOnly, "信息"
                                    Me.MousePointer = 0
                                    Exit Sub
                                End If
                            Next
                        Case itAppointment
                            '日程安排文件夹
                            Dim Items3 As New MsFoderDll.AppointmentItems
                            '从OUTLOOK读取本文件夹下的资料
                            ModTemp.RetriveAppointmentFolder FindOutlookConnt(i), _
                                        Items3
                            For j = 1 To Items3.Count
                                '将一笔资料上传到服务器
                                sTemp = PISServerComm.UploadAppointment(AllNumber, _
                                            FindOutlookConnt(i), Items3(j))
                                If Left(sTemp, 1) <> Chr(0) Then
                                    MsgBox sTemp, vbInformation + vbOKOnly, "信息"
                                    Me.MousePointer = 0
                                    Exit Sub
                                End If
                            Next
                        Case itNote
                            '便笺文件夹
                            Dim Items4 As New MsFoderDll.NoteItems
                            '从OUTLOOK读取本文件夹下的资料
                            ModTemp.RetriveNoteFolder FindOutlookConnt(i), Items4
                            For j = 1 To Items4.Count
                                '将一笔资料上传到服务器
                                sTemp = PISServerComm.UploadNote(AllNumber, _
                                            FindOutlookConnt(i), Items4(j))
                            If Left(sTemp, 1) <> Chr(0) Then
                                    MsgBox sTemp, vbInformation + vbOKOnly, "信息"
                                    Me.MousePointer = 0
                                    Exit Sub
                                End If
                            Next
                        Case itJournal
                            '日记文件夹
                            Dim Items5 As New MsFoderDll.JournalItems
                            '从OUTLOOK读取本文件夹下的资料
                            ModTemp.RetriveJournalFolder FindOutlookConnt(i), Items5
                            For j = 1 To Items5.Count
                                '将一笔资料上传到服务器
                                sTemp = PISServerComm.UploadJournal(AllNumber, _
                                            FindOutlookConnt(i), Items5(j))
                                If Left(sTemp, 1) <> Chr(0) Then
                                    MsgBox sTemp, vbInformation + vbOKOnly, "信息"
                                    Me.MousePointer = 0
                                    Exit Sub
                                End If
                            Next
                    End Select
                Else
                    MsgBox sTemp
                    GoTo CHkerrorSysnch
                End If
            End If
        Next
                
       sTemp = PISServerComm.FinishDataTransfer(AllNumber)  '通知服务器完成数据传输
        If Left(sTemp, 1) = Chr(0) Then
            SetKeyValue HKEY_CURRENT_USER, "Software\DataSynchronIzation", "SetTree", TempTree, REG_SZ
            MsgBox "传输完成"
        Else
            MsgBox sTemp    '传输错误
            GoTo CHkerrorSysnch
        End If
    Else
        MsgBox sTemp        '传输错误
        GoTo CHkerrorSysnch
    End If
    Me.MousePointer = 0
Exit Sub
CHkerrorSysnch:
        MsgBox Err.Description
        MsgBox Err.Number
        Me.MousePointer = 0
End SubPublic Sub AddTreeView(FindView As Object)
    '添加到目录树中
    Dim NAdd As Node
    '判断是不是根节点
    If FindView.ParentIndex = -1 Then
        Set NAdd = TViewOutlook.Nodes.Add(, , FindView.LocalID, FindView.FolderName)
    Else
        Set NAdd = TViewOutlook.Nodes.Add(FindOutlookConnt(FindView.ParentIndex).LocalID, _
                tvwChild, FindView.LocalID, FindView.FolderName)
    End If
    '展开当前的节点,使其打开
    NAdd.Expanded = True
    Set NAdd = Nothing
End Sub这是一个例子,你看一看