frmserver.ebf

Windows CE 应用程序设计随书源码

End Sub
'开始复制操作
Private Sub startReplication()
    '显示等待鼠标
    ShowWaitCursor
    Dim Str As String
    Dim strPath As String
    Dim pchange As Long
    Dim pconflict As Long
    strPath = App.Path
    If strPath = "\" Then
        strPath = ""
    End If
    '订阅
    On Error Resume Next
    ProcInfo.PMsgInfo.Caption = "正在订阅..."
    ProcInfo.Show
    ProcInfo.SetFocus
    If FileSystem1.Dir(strPath & "\ProjectInfo.sdf") <> "" Then
    '存在数据库文件
    'CEMerge.AddSubscription EXISTING_DATABASE
    Else
        CEMerge.AddSubscription CREATE_DATABASE
        If CEMerge.ErrorRecords.Count > 0 Then
        ShowErrors CEMerge.ErrorRecords, "添加订阅失败"
        Else
            'MsgBox "订阅添加成功！", vbOKOnly, "添加订阅"
            ProcInfo.PMsgInfo.Caption = "恭喜，订阅成功！"
        End If
    End If
    '同步数据
    On Error Resume Next
    '初始化同步
    CEMerge.Initialize
    If CEMerge.ErrorRecords.Count > 0 Then
        ShowErrors CEMerge.ErrorRecords, "初始化失败,请查看复制设置！"
        frmReplAddSubscription.Show
    Else
        On Error Resume Next
        ProcInfo.PMsgInfo.Caption = "正在同步处理..."
        CEMerge.Run
        If CEMerge.ErrorRecords.Count > 0 Then
            ShowErrors CEMerge.ErrorRecords, "同步失败"
        Else
            ProcInfo.PMsgInfo.Caption = "同步完成."
            'Str = "同步完成" & vbCrLf
            FrmsyncMsg.Label2.Caption = "发布改变:" & CEMerge.PublisherChanges & "个"
            FrmsyncMsg.Label3.Caption = "发布冲突:" & CEMerge.PublisherConflicts & "个"
            FrmsyncMsg.Label4.Caption = "订阅改变:" & CEMerge.SubscriberChanges & "个"
            pchange = CEMerge.PublisherChanges
            pconflict = CEMerge.PublisherConflicts
            FrmsyncMsg.Show
        End If
        CEMerge.Terminate
        ProcInfo.PMsgInfo.Caption = "同步终止."
        ProcInfo.SetFocus
    End If
    If pchange > 0 Or pconflict > 0 Then
        ProcInfo.PMsgInfo.Caption = "正在初始化项目列表..."
        frmMain.initList
        ProcInfo.PMsgInfo.Caption = "初始化项目列表完成."
        ProcInfo.PMsgInfo.Caption = "正在初始化树列表..."
        frmMain.initTree
        ProcInfo.PMsgInfo.Caption = "初始化树列表完成."
    End If
    ProcInfo.Hide
    HideWaitCursor
End Sub
'初始化项目信息列头
Private Sub initListColu()
MsgInfoList.ColumnHeaders.Add 1, "mID", "序号", 550
MsgInfoList.ColumnHeaders.Add 2, "mName", "项目名称", 1200
MsgInfoList.ColumnHeaders.Add 3, "mAuthor", "负责人", 800
MsgInfoList.ColumnHeaders.Add 4, "mDate", "日期", 1400
MsgInfoList.ColumnHeaders.Add 5, "mDetail", "描述", 2400
End Sub
'初始化信息列表
Public Sub initList()
On Error Resume Next
ShowWaitCursor
Dim mitem As ListItem
MsgInfoList.ListItems.Clear
Dim sql As String
Dim conn As ADOCE.Connection
Set conn = CreateObject("ADOCE.connection.3.1")
conn.ConnectionString = dbConnStr
conn.Open
sql = "select * from MsgInfo"
Dim myRec As ADOCE.Recordset
Set myRec = CreateObject("ADOCE.recordset.3.1")
myRec.Open sql, conn, adOpenStatic
Do While Not myRec.EOF
 
 Set mitem = MsgInfoList.ListItems.Add(, "t" & myRec("msgID"), myRec("msgID"))
    mitem.SubItems(1) = Trim(myRec("MsgName"))
    mitem.SubItems(2) = Trim(myRec("MsgAuthor"))
    mitem.SubItems(3) = Trim(myRec("MsgDate"))
    mitem.SubItems(4) = Trim(myRec("MsgDetail"))
myRec.MoveNext
Loop
myRec.Close
Set myRec = Nothing
conn.Close
Set conn = Nothing
MsgInfoList.SortKey = 0
MsgInfoList.Sorted = True
HideWaitCursor
End Sub
'初始化项目信息树
Public Sub initTree()
On Error Resume Next
ShowWaitCursor
Dim treeNode As Node
DBTreeView.Nodes.Clear
Dim cn As ADOCE.Connection
Dim myRec As ADOCE.Recordset
Set cn = CreateObject("ADOCE.Connection.3.1")
cn.ConnectionString = dbConnStr
cn.Open
Dim sql As String
sql = "select * from MsgInfo order by msgID asc"
Set myRec = CreateObject("ADOCE.recordset.3.1")
myRec.Open sql, cn, adOpenDynamic, adLockOptimistic
Set treeNode = DBTreeView.Nodes.Add(, , "Root", "我的项目" & "(" & myRec.RecordCount & ")", 1)
Do While Not myRec.EOF
Set treeNode = DBTreeView.Nodes.Add("Root", 4, "child" & myRec("MsgID"), myRec("MsgName"), 2)
myRec.MoveNext
Loop
DBTreeView.Nodes(1).Expanded = True
myRec.Close
Set myRec = Nothing
cn.Close
Set cn = Nothing
HideWaitCursor
End Sub
Private Sub Form_OKClick()
    App.End
End Sub
'创建数据
Function createDB() As Boolean
    ProcInfo.PMsgInfo.Caption = "正在创建数据库..."
    ProcInfo.Show
    Dim strPath As String
    strPath = App.Path
    If strPath = "\" Then
        strPath = ""
    End If
    Dim cat As ADOXCE.Catalog
    Dim rslt As VbMsgBoxResult
    Set cat = CreateObject("ADOXCE.Catalog.3.1")
    'Set cat = CreateObject("ADOCE.Catalog.3.1")
    createDB = False
    If FileSystem1.Dir(strPath & "\ProjectInfo.sdf") <> "" Then
        rslt = MsgBox("覆盖数据库ProjectInfo.sdf?", vbYesNoCancel, "覆盖")
        
        If rslt = vbYes Then
            'close_connection
            FileSystem1.Kill strPath & "\ProjectInfo.sdf"
        Else
            Exit Function
        End If
    End If
     
    On Error Resume Next
    
    cat.Create dbConnStr
    
    If Err.Number <> 0 Then
        MsgBox "Error: error creating database. ", vbCritical, "创建数据库失败"
        createDB = False
    Else
        createDB = True
    End If
    Set cat = Nothing
    '创建表
  If createDB Then
       Dim sql As String
Dim conn As ADOCE.Connection
Set conn = CreateObject("ADOCE.connection.3.1")
conn.ConnectionString = dbConnStr
conn.Open
       sql = "CREATE TABLE MsgInfo (MsgID int IDENTITY (1,1),"
       sql = sql & "MsgName nvarchar (50),"
       sql = sql & "MsgAuthor nvarchar (20),"
       sql = sql & "MsgDate nvarchar (20),"
       sql = sql & "MsgDetail nvarchar (50))"
   
    conn.Execute sql
    conn.Close
    Set conn = Nothing
ProcInfo.PMsgInfo.Caption = "数据库创建成功."
ProcInfo.Hide
End If
End Function
'修改数据库
Private Sub updProject()
If MsgInfoList.ListItems.Count > 0 Then
   frmAdd.actionID.Caption = MsgInfoList.SelectedItem.Text
   frmAdd.MsgName.Text = MsgInfoList.SelectedItem.SubItems(1)
   frmAdd.MsgAuthor.Text = MsgInfoList.SelectedItem.SubItems(2)
   frmAdd.MsgDate.Text = MsgInfoList.SelectedItem.SubItems(3)
   frmAdd.msgDetail.Text = MsgInfoList.SelectedItem.SubItems(4)
   Call frmAdd.Show
End If
End Sub
'排序
Private Sub MsgInfoList_ColumnClick(ByVal Index As Long)
MsgInfoList.SortKey = Index - 1
MsgInfoList.Sorted = True
End Sub

Private Sub MsgInfoList_GotFocus()
 Dim mnuEdit As MenuBarLib.MenuBarMenu
 Set mnuEdit = mnuMenu.Controls.Item(1)
     mnuEdit.Items(3).Enabled = True
    mnuEdit.Items(2).Enabled = True
End Sub
Private Sub MsgInfoList_ItemClick(ByVal Index As Long)
 Dim mnuEdit As MenuBarLib.MenuBarMenu
 Set mnuEdit = mnuMenu.Controls.Item(1)
     mnuEdit.Items(3).Enabled = True
    mnuEdit.Items(2).Enabled = True
End Sub

Private Sub MsgInfoList_LostFocus()
 Dim mnuEdit As MenuBarLib.MenuBarMenu
 Set mnuEdit = mnuMenu.Controls.Item(1)
     mnuEdit.Items(3).Enabled = False
    mnuEdit.Items(2).Enabled = False
End Sub
'添加记录
Public Sub appendRec(msgId As Long, MsgName As String, MsgAuthor As String, msgDetail As String, MsgDate As String)
'树增加
Dim treeNode As Node
Set treeNode = DBTreeView.Nodes.Add("Root", 4, "child" & msgId, MsgName, 2)

'记录增加
Dim mitem As ListItem
Set mitem = MsgInfoList.ListItems.Add(, "t" & msgId, msgId)
    mitem.SubItems(1) = MsgName
    mitem.SubItems(2) = MsgAuthor
    mitem.SubItems(3) = MsgDate
    mitem.SubItems(4) = msgDetail
MsgInfoList.Refresh
DBTreeView.Refresh
End Sub
'删除记录
Public Sub DeleteRec(indexID As Long)
'树操作
Dim treeNode As Node
Dim i As Long
Dim thekey As String
thekey = MsgInfoList.ListItems.Item(indexID).Key
thekey = Replace(thekey, "t", "child")
For i = 1 To DBTreeView.Nodes.Count
If DBTreeView.Nodes.Item(i).Key = thekey Then
DBTreeView.Nodes.Remove (i)
Exit For
End If
Next
'记录操作
Dim mitem As ListItem
MsgInfoList.ListItems.Remove (indexID)
MsgInfoList.Refresh
DBTreeView.Refresh
End Sub
'更新记录
Public Sub UpdateRec(MsgName As String, MsgAuthor As String, MsgDate As String, msgDetail As String)
Dim indexID As Long
indexID = MsgInfoList.SelectedItem.Index
'树操作
Dim treeNode As Node
Dim i As Long
Dim thekey As String
thekey = MsgInfoList.ListItems.Item(indexID).Key
thekey = Replace(thekey, "t", "child")
For i = 1 To DBTreeView.Nodes.Count
If DBTreeView.Nodes.Item(i).Key = thekey Then
DBTreeView.Nodes.Item(i).Text = MsgName
Exit For
End If
Next
'记录操作
MsgInfoList.ListItems.Item(indexID).SubItems(1) = MsgName
MsgInfoList.ListItems.Item(indexID).SubItems(2) = MsgAuthor
MsgInfoList.ListItems.Item(indexID).SubItems(3) = MsgDate
MsgInfoList.ListItems.Item(indexID).SubItems(4) = msgDetail
MsgInfoList.Refresh
DBTreeView.Refresh
End Sub