frmrda.ebf

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

         BackColor       =   12632256
         Caption         =   "Close"
         Enabled         =   -1  'True
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Style           =   0
      End
      Begin VBCE.CommandButton cmdLocalDatabaseNameHelp 
         Height          =   255
         Left            =   3120
         TabIndex        =   1
         Top             =   1560
         Width           =   255
         _cx             =   450
         _cy             =   450
         BackColor       =   12632256
         Caption         =   "?"
         Enabled         =   -1  'True
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Style           =   0
      End
   End
   Begin CETabStripCtl.TabStrip tabMain 
      Height          =   3975
      Left            =   0
      TabIndex        =   56
      Top             =   0
      Width           =   3615
      _cx             =   6376
      _cy             =   7011
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      FontName        =   "宋体"
      FontSize        =   9
      MultiRow        =   0   'False
      Style           =   0
      TabFixedHeight  =   0
      TabFixedWidth   =   0
      TabWidthStyle   =   0
      TabsPersist     =   $"frmRDA.frx":0050
      Enabled         =   -1  'True
   End
End
Attribute VB_Name = "frmRDA"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'定义RDA配置
Const strInternetURLDflt = "http://202.204.96.168:8080/sscesa10.dll"
Const strServerNameDflt = "davidqin"
Const strServerDatabaseNameDflt = "ProjectInfo"
Const strDatabaseUserIdDflt = "sa"
Const strServerAgentDLL = "/sscesa10.dll"
Const strSQLProvider = "provider=sqloledb"
Const strSQLEProvider = "Provider=Microsoft.SQLSERVER.OLEDB.CE.1.0; data source="
Const strTitleBar = "RDA提示"
Const tstValue = -255
Const strPullTable = "pull_source"
Const strSchemaTables = "SELECT TABLE_NAME FROM INFORMATION_SCHEMA.TABLES"
Const strServerTables = "SELECT TABLE_NAME FROM pull_source"
Const strDropPullSource = "DROP TABLE pull_source"
Dim cat As ADOXCE.Catalog
Dim rda As SSCE.RemoteDataAccess
Dim cn As ADOCE.Connection
Dim strRemoteConn As Stringa
Dim bRDAPropsApplied As Boolean

Sub Form_Load()
    Set cn = Nothing
    Set cat = Nothing
    Set rda = Nothing
    frmLocal.Left = 0
    frmLocal.Top = 0
    frmProperties.Left = 0
    frmProperties.Top = 0
    frmSync.Left = 0
    frmSync.Top = 0
    frmQuery.Left = 0
    frmQuery.Top = 0
    If FileSystem1.Dir(strPath & "\ProjectInfo.sdf") = "" Then
       create_db
    End If
    txtLocalDatabase.Text = strPath & "\ProjectInfo.sdf"
    tabMain_Click
    strRemoteConn = ""
    txtInternetURL.Text = strInternetURLDflt
    txtServerName.Text = strServerNameDflt
    txtServerDatabase.Text = strServerDatabaseNameDflt
    txtDBUserId.Text = strDatabaseUserIdDflt
End Sub

Private Sub cmdPull_Click()
    '在Pull之前必须关闭连接
    close_connection
    ShowWaitCursor
    If chk_rda_props = False Then
        MsgBox "Error: Missing one or more required RDA parameters.", vbCritical, strTitleBar
        Exit Sub
    End If
    If txtLocalTableName.Text = "" Then
        MsgBox "Error: Local table name required for Pull operations.", vbCritical, strTitleBar
        Exit Sub
    End If
    On Error Resume Next
    ProcInfo.PMsgInfo.Caption = "正在从服务器上下载数据..."
    ProcInfo.Show
    '是否跟踪
    If optTracked.Value = True Then
        rda.Pull txtLocalTableName.Text, txtSyncCommand.Text, strRemoteConn, TRACKINGON, txtErrorTableName.Text
    Else
        rda.Pull txtLocalTableName.Text, txtSyncCommand.Text, strRemoteConn, TRACKINGOFF, txtErrorTableName.Text
    End If
    
    '如果有错误发生显示错误
    If Err.Number <> 0 Then
        Call show_rda_errs
        close_connection
        Exit Sub
    End If
    On Error GoTo 0
    
    ' reset the command text on the query tab so that we can
    ' test the pull
    txtCommand.Text = "Select * From " & txtLocalTableName.Text
    
    ' close the database so that other operations can continue
    '
    close_connection
    ProcInfo.PMsgInfo.Caption = "下载数据完成."
    ProcInfo.Hide
    HideWaitCursor
    cmdPull.Enabled = False
    'MsgBox "Operation complete", vbInformation, strTitleBar
End Sub

'-----------------------------------------------------------------------
'   Sub cmdPush_Click
'
'   Send all tracked changes to the local table to the server. if an
'   error table was specified and errors occur during push then any error
'   information will be present in the error table
'
Private Sub cmdPush_Click()

    ' make sure that we have required RDA properties set
    '
    If chk_rda_props = False Then
        MsgBox "Error: Missing one or more required RDA parameters.", vbCritical, strTitleBar
        Exit Sub
    End If

    ' Push connects natively and requires an exclusive connection to the database so
    ' we must close the current connection
    '
    close_connection
    ShowWaitCursor
    On Error Resume Next
    ProcInfo.PMsgInfo.Caption = "正在向服务器上载数据..."
    ProcInfo.Show
    ' send all tracked changes to the local table to the server
    '
    rda.Push txtLocalTableName.Text, strRemoteConn

    ' if an error occurred then display the RDA errors
    '
    If Err.Number <> 0 Then
        Call show_rda_errs
        close_connection
        Exit Sub
    End If
    On Error GoTo 0
    
    ' close the database so that other operations can continue
    '
    close_connection
    
    ProcInfo.PMsgInfo.Caption = "上载数据完成."
    '将本地表删除
    ProcInfo.PMsgInfo.Caption = "删除本地表数据."
    Dim sql As String
    open_connection
    sql = "drop table MsgInfo"
    cn.Execute sql
    close_connection
    ProcInfo.Hide
    'ProcInfo.PMsgInfo.Caption = "删除本地表数据."
    Call cmdPull_Click
    ProcInfo.Show
    ProcInfo.PMsgInfo.Caption = "数据同步完成."
    ProcInfo.Hide
    Me.Hide
        ProcInfo.PMsgInfo.Caption = "正在初始化项目列表..."
        ProcInfo.Show
        frmMain.initList
        ProcInfo.PMsgInfo.Caption = "初始化项目列表完成."
        ProcInfo.PMsgInfo.Caption = "正在初始化树列表..."
        frmMain.initTree
        ProcInfo.PMsgInfo.Caption = "初始化树列表完成."
        ProcInfo.Hide
    HideWaitCursor
End Sub


'-----------------------------------------------------------------------
'   Sub cmdSubmitSQL_Click
'
'   Passthrough any native server requests to the server. Note this is
'   not a passthrough feature and will not return a recordset object.
'
Private Sub cmdSubmitSQL_Click()
    If chk_rda_props = False Then
        MsgBox "Error: Missing one or more required RDA parameters.", vbCritical, strTitleBar
        Exit Sub
    End If
    
    ' Submit SQL connects natively and requires an exclusive connection to the database so
    ' we must close the current connection
    '
    close_connection
    
    On Error Resume Next
    
    ' pass the command to the server
    '
    rda.SubmitSQL txtSyncCommand.Text, strRemoteConn
    
    ' if an error occurred then display the RDA errors
    '
    If Err.Number <> 0 Then
        Call show_rda_errs
        close_connection
        Exit Sub
    End If
    On Error GoTo 0
    
    ' close the database so that other operations can continue
    '
    close_connection
    
    MsgBox "Operation complete", vbInformation, strTitleBar
End Sub

'-----------------------------------------------------------------------
'   Sub cmdApplyProperties_Click
'
'   Apply all the sessions properties to the associated objects necessary
'   for data connectivity. This routine will create a database with the
'   specified local database name unless the 'Existing Database' checkbox has
'   been selected. In that event the database with the local database name
'   will be opened.
'
Private Sub cmdApplyProperties_Click()
   
    ' we potentially will create a new database so close it now
    '
    close_connection

    ' initialize the remote data access object
    '
    Set rda = Nothing
    Set rda = CreateObject("SSCE.RemoteDataAccess.1.0")

    ' set properties on RDA object
    '
    rda.LocalConnectionString = strSQLEProvider + txtLocalDatabase.Text
    rda.InternetURL = txtInternetURL.Text   ' tell RDA about IIS Server. Note that if DNS is not present, then IP address can be used.
    
    ' setup IIS login properties.  this is used for BASIC and NTLM authentication.
    ' if IIS is configured to accept Anonymus authentication these properties will be ignored
    '
    rda.InternetLogin = txtLoginUid.Text
    rda.InternetPassword = txtLoginPassword.Text
    
    ' build the connectiuon string for the remote server.
    '
    strRemoteConn = strSQLProvider + _
        ";data source=" + txtServerName.Text + _
        ";Initial Catalog=" + txtServerDatabase.Text + _
        ";user id=" + txtDBUserId.Text + _
        ";password=" + txtDBPassword.Text + ";"
    
    ' reset the sync form to reflect the new properties
    '
    sync_form_reset
    
    ' indicate that the user has set RDA properties
    '
    bRDAPropsApplied = True
    
    MsgBox "Operation complete", vbInformation, strTitleBar
End Sub

'-----------------------------------------------------------------------
'   Sub cmbSourceTables_Click
'
'   Once a source table is chosen refresh the sync command text to
'   indicate that we want to pull from that table
'
Private Sub cmbSourceTables_Click()
    Dim strTableName As String
    
    strTableName = cmbSourceTables.List(cmbSourceTables.ListIndex)
    
    txtSyncCommand.Text = "Select * From " & strTableName
    txtLocalTableName.Text = strTableName
    
    ' we only have error tables for non tracked operations
    '
    If optNonTracked.Value = False Then
        txtErrorTableName.Text = strTableName & "_Err"
    End If
End Sub

'-----------------------------------------------------------------------
'   Sub cmbSourceTables_DropDown
'
'   On the first drop down populate the drop down with a list
'   of avaliable server table names for use in a Pull operation.
'
Private Sub cmbSourceTables_DropDown()
    If chk_rda_props = False Then
        cmbSourceTables.Clear
        cmbSourceTables.AddItem "RDA properties not set"
        Exit Sub
    End If
    
    If cmbSourceTables.ListCount = 0 Then
        populate_pullsource
    End If
End Sub
    
'-----------------------------------------------------------------------
'   Function populate_pullsource
'
'   Use the RDA Pull method to create an populate a local table
'   that holds the name of all the server table objects and then
'   populate a the cmbSourceTables drop down combo.
'
Private Sub populate_pullsource()
    Dim rs As ADOCE.Recordset
    
    On Erro