用递归,一层层的,很简单的
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这是一个例子,你看一看
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这是一个例子,你看一看
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货