frmmain.frm

可直接打开编辑网络数据库

         Caption         =   "级别"
         Enabled         =   0   'False
      End
      Begin VB.Menu QX 
         Caption         =   "权限"
         Enabled         =   0   'False
      End
      Begin VB.Menu PZ 
         Caption         =   "品种"
         Enabled         =   0   'False
         Visible         =   0   'False
         WindowList      =   -1  'True
      End
      Begin VB.Menu QW 
         Caption         =   "区域"
         Enabled         =   0   'False
      End
      Begin VB.Menu GS 
         Caption         =   "格式"
         Enabled         =   0   'False
      End
      Begin VB.Menu JM 
         Caption         =   "加密"
         Enabled         =   0   'False
      End
      Begin VB.Menu Q 
         Caption         =   "-"
      End
   End
   Begin VB.Menu FX 
      Caption         =   "统计分析"
      Begin VB.Menu DW 
         Caption         =   "按同一单位"
         Enabled         =   0   'False
      End
      Begin VB.Menu CP 
         Caption         =   "按同一产品"
         Enabled         =   0   'False
      End
      Begin VB.Menu DA 
         Caption         =   "按同一日期"
         Enabled         =   0   'False
      End
      Begin VB.Menu LB 
         Caption         =   "按同一类别"
         Enabled         =   0   'False
      End
      Begin VB.Menu TB 
         Caption         =   "图表分析"
         Checked         =   -1  'True
         Enabled         =   0   'False
      End
      Begin VB.Menu E 
         Caption         =   "-"
      End
   End
   Begin VB.Menu ST 
      Caption         =   "视图"
      Begin VB.Menu DSP 
         Caption         =   "多表水平显示"
         Enabled         =   0   'False
      End
      Begin VB.Menu DSZ 
         Caption         =   "多表垂直显示"
         Enabled         =   0   'False
      End
      Begin VB.Menu DP 
         Caption         =   "单表全屏显示"
         Checked         =   -1  'True
         Enabled         =   0   'False
      End
      Begin VB.Menu Y 
         Caption         =   "-"
      End
   End
   Begin VB.Menu mnuhelp 
      Caption         =   "帮助"
      Begin VB.Menu jszc 
         Caption         =   "技术支持..."
         Enabled         =   0   'False
      End
      Begin VB.Menu HPE 
         Caption         =   "如何使用?"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnu关于 
         Caption         =   "关于"
         Shortcut        =   ^H
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim SortOrder As Boolean
Dim LockTextBox As Boolean
Dim LastColumnSort As Integer
Public Surrpath As String

Public Sub cmdExecute_Click()

    If Trim(txtSqlStatement) = "" Then Exit Sub
    On Error GoTo e_Trap
    imgLoading.Visible = True
    Me.Refresh
    SortOrder = True
    adoData.RecordSource = txtSqlStatement
    adoData.Refresh
    Set gridData.DataSource = adoData.Recordset
    lblStatus.caption = "记录数: " & adoData.Recordset.RecordCount
    imgLoading.Visible = False
    Exit Sub
e_Trap:
    lblStatus.caption = "错误: " & Err.Description & " (" & Err.Number & ")"
    imgLoading.Visible = False
End Sub


Private Sub Form_Load()
Dim commandLine As String
Dim serverType As Integer
Dim serverName As String
Dim databaseName As String
Dim Password As String
Dim UserName As String
Dim defaultTable As String
Dim registryString As String
    
    Call Hook(Me.hwnd, 7000, 3500)
    
    Set dbObj = New ADODB.Connection
        
    mnuEdit.Enabled = False
    lblDatabaseName.caption = ""
    
    Me.Width = GetSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Width", WorkAreaWidth, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    Me.Height = GetSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Height", WorkAreaHeight / 2, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    
    Me.Top = GetSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Top", WorkAreaBottom - Me.Height, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    If Me.Top < WorkAreaTop Then
        Me.Top = WorkAreaTop
    ElseIf Me.Top > WorkAreaBottom - Me.Height Then
        Me.Top = WorkAreaBottom - Me.Height
    End If
    If Me.Height > WorkAreaHeight Then
        Me.Height = WorkAreaHeight
    End If
    
    Me.Left = GetSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Left", WorkAreaLeft, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    If Me.Left < WorkAreaLeft Then
        Me.Left = WorkAreaLeft
    ElseIf Me.Left > WorkAreaRight - Me.Width Then
        Me.Left = WorkAreaRight - Me.Width
    End If
    If Me.Width > WorkAreaWidth Then
        Me.Width = WorkAreaWidth
    End If
    
    Me.WindowState = GetSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "WindowState", vbNormal, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    
    mnuShowSQL.Checked = GetSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Show SQL", True, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    Call Form_Resize
    
    On Error Resume Next
    Call AssociateFileType("mdb", False, "TC网络数据库系统")

    LastOpenedType = GetSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Last Opened Type", 0, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")

    commandLine = Command
    If commandLine <> "" Then
        If Dir(commandLine) <> "" Then
            dbPath = commandLine
            dbConnectionString = BuildConnectString(e_databaseTypes_MicrosoftAccess2KFile, dbPath)
            dbType = e_databaseTypes_AccessFile
            defaultTable = ""
            If LastOpenedType = e_LastOpened_Access Then
                If dbPath = GetSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS & "\Access", "Database Path", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database") Then
                    defaultTable = GetSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS & "\Access", "Default Table", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
                End If
            End If
            LastOpenedType = e_LastOpened_Access
            Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS & "\Access", "Database Path", dbPath, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
            Call SetupDatabase(defaultTable, True)
        End If
    Else
        If LastOpenedType = e_LastOpened_Access Then
            dbType = e_databaseTypes_AccessFile
            dbPath = GetSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS & "\Access", "Database Path", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
            If dbPath <> "" Then
                If Dir(dbPath) <> "" Then
                    dbConnectionString = BuildConnectString(e_databaseTypes_MicrosoftAccess2KFile, dbPath)
                    defaultTable = GetSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS & "\Access", "Default Table", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
                    Call SetupDatabase(defaultTable, True)
                End If
            End If
        ElseIf LastOpenedType = e_LastOpened_Network Then
            serverType = GetSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS, "", 0, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
            
            If serverType = e_databaseTypes_OracleMSDA Then
                registryString = DEF_REGISTRY_CONNECTIONS & "\" & DEF_ORACLE_CLIENT
            ElseIf serverType = e_databaseTypes_OracleODBC Then
                registryString = DEF_REGISTRY_CONNECTIONS & "\" & DEF_ORACLE_ODBC
            ElseIf serverType = e_databaseTypes_SQLserver Then
                registryString = DEF_REGISTRY_CONNECTIONS & "\" & DEF_SQL_SERVER
            ElseIf serverType = e_databaseTypes_DSNFile Then
                registryString = DEF_REGISTRY_CONNECTIONS & "\" & DEF_DSN_FILE
            End If
            
            serverName = GetSetting("TC网络数据库系统", registryString, "服务器名", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
            databaseName = GetSetting("TC网络数据库系统", registryString, "数据库名", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
            UserName = GetSetting("TC网络数据库系统", registryString, "用户名", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
            Password = GetSetting("TC网络数据库系统", registryString, "密码", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
            defaultTable = GetSetting("TC网络数据库系统", registryString, "自定义 ", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
             
            
            dbType = serverType
            dbPath = UCase(Mid(serverName, 1, 1)) & LCase(Mid(serverName, 2))
            If Trim(databaseName) <> "" Then
                dbPath = dbPath & " : " & databaseName
            End If
            
            dbConnectionString = BuildConnectString(serverType, serverName, databaseName, UserName, Password)
            Call SetupDatabase(defaultTable, True)
        End If
    End If
    
    
End Sub
Public Sub SetupDatabase(Optional defaultTable As String, Optional centerScreen As Boolean = False)
    If dbType = e_databaseTypes_AccessFile Or dbType = e_databaseTypes_MicrosoftAccess2KFile Or dbType = e_databaseTypes_MicrosoftAccess97File Then
        frmMain.mnuCompact.Visible = True
    Else
        frmMain.mnuCompact.Visible = False
    End If
    
    lblDatabaseName.caption = BuildDatabaseName(dbType, dbPath, LastOpenedType)
    Call frmConnecting.ShowConnecting("连接到 " & dbPath & lblDatabaseName.caption, IIf(centerScreen = False, Me, Nothing))
    Me.caption = "TC网络数据库系统" & " (" & lblDatabaseName.caption & ")"
    Call GetTableList(defaultTable, centerScreen)
    frmConnecting.Hide
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim frmObj As Object
    If Me.WindowState <> vbMinimized Then
        Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "WindowState", Me.WindowState, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    End If
    If Me.WindowState = vbNormal Then
        Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Top", Me.Top, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
        Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Left", Me.Left, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
        Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Width", Me.Width, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
        Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Form Height", Me.Height, HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    End If
    Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Last Opened Type", CStr(LastOpenedType), HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_SETTINGS, "Show SQL", CStr(mnuShowSQL.Checked), HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    
    Call SaveDefaultTable
    
    For Each frmObj In Forms
        Unload frmObj
    Next
    
    Set dbObj = Nothing
    Call Unhook
End Sub

Private Sub Form_Resize()

    If mnuShowSQL.Checked = True Then
        fraSqlStatement.Visible = True
    Else
        fraSqlStatement.Visible = False
    End If
    
    If Me.WindowState = vbMinimized Then Exit Sub
    
    'Height
    If mnuShowSQL.Checked = True Then
        gridData.Height = Me.Height - gridData.Top - 2300  ' 原值2000
    Else
        gridData.Height = Me.Height - gridData.Top - 1350  '原值1050
    End If
    
    'Width
    gridData.Width = Me.Width - 360 '原值360
    fraSqlStatement.Width = gridData.Width
    txtSqlStatement.Width = fraSqlStatement.Width - txtSqlStatement.Left - cmdExecute.Width - 200
    
    'Top
    imgLoading.Top = Me.Height - 1150 '原值950
    lblStatus.Top = Me.Height - 1150 '原值950
    fraSqlStatement.Top = gridData.Top + gridData.Height + 100 '原值100
    
    'Left
    imgLoading.Left = gridData.Left + gridData.Width - imgLoading.Width
    chkEditMode.Left = gridData.Left + gridData.Width - chkEditMode.Width
    cmdExecute.Left = txtSqlStatement.Left + txtSqlStatement.Width + 100
    
End Sub

Private Sub GetTableList(Optional ByVal defaultTable As String, Optional ByVal centerScreen As Boolean = False)
Dim rsSchema As ADODB.Recordset
Dim nCount As Integer
Dim newTableName As String
Dim Password As String

    On Error Resume Next
    LockTextBox = True
    frmMain.cmbTables.Clear
    frmPurgeDate.cmbTables.Clear
    frmRenameTable.cmbTables.Clear
    If dbObj.State = adStateOpen Then
        Set dbObj = New ADODB.Connection
    End If
    dbObj.Open dbConnectionString
    If dbObj.State <> adStateOpen And (dbType = e_databaseTypes_AccessFile Or e_databaseTypes_MicrosoftAccess2KFile Or e_databaseTypes_MicrosoftAccess97File) Then
        If centerScreen = True Then
            Password = GetSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS & "\" & DEF_ACCESS, "数据库密码", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
        End If
        If Password = "" Then
            frmPassword.caption = DetermineFilename(dbPath) & " Password"
            frmPassword.Show vbModal, IIf(centerScreen = False, Me, Nothing)
            If frmPassword.bWasCancelled = True Then
                Exit Sub
            End If
        End If
        dbConnectionString = dbConnectionString & "PWD=" & frmPassword.txtPassword & ";"
        dbObj.Open dbConnectionString
        Unload frmPassword
        mnuClearPassword.Visible = True
    Else
        mnuClearPassword.Visible = False
        Call SaveSetting("TC网络数据库系统", DEF_REGISTRY_CONNECTIONS & "\" & DEF_ACCESS, "数据库密码", "", HKEY_LOCAL_MACHINE, "SOFTWARE\Database")
    End If
    If dbObj.State = adStateOpen Then
        Set rsSchema = dbObj.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))
        If Not rsSchema Is Nothing Then
            Do While Not rsSchema.EOF
                If UCase(Left(rsSchema!Table_name, 4)) <> "MSYS" Then
                    If UCase(Left(rsSchema!Table_name, 11)) <> "SWITCHBOARD" Then
                        newTableName = rsSchema!Table_name
                        cmbTables.AddItem newTableName
                        frmPurgeDate.cmbTables.AddItem newTableName
                        frmRenameTable.cmbTables.AddItem newTableName
                    End If
                End If
                rsSchema.MoveNext
            Loop
            cmbTables.AddItem DEF_CUSTOM_SQL
        End If
    End If
    rsSchema.Close
    If cmbTables.ListCount > 0 Then
        If defaultTable = "" Then
            cmbTables.ListIndex = 0
            frmPurgeDate.cmbTables.ListIndex = 0
            frmRenameTable.cmbTables.ListIndex = 0
        Else
            For nCount = 0 To cmbTables.ListCount - 1
                If cmbTables.List(nCount) = defaultTable Then
                    cmbTables.ListIndex = nCount
                    frmPurgeDate.cmbTables.ListIndex = nCount
                    frmRenameTable.cmbTables.ListIndex = nCount
                    Exit For
                End If
            Next nCount
            If cmbTables.ListIndex = -1 Then
                cmbTables.ListIndex = 0
                frmPurgeDate.cmbTables.ListIndex = 0
                frmRenameTable.cmbTables.ListIndex = 0
            End If
        End If
    End If
    
    Set gridData.DataSource = adoData

    Set rsSchema = Nothing
    LockTextBox = False
End Sub

Private Sub chkEditMode_Click() '编辑状态设置
    mnuEditMode.Checked = IIf(chkEditMode.Value = vbChecked, True, False)
    If chkEditMode.Value = vbChecked Then
        gridData.AllowAddNew = True
        gridData.AllowDelete = True
        gridData.AllowUpdate = True
         
       'adoData.Recordset.RecordCount = 1
        
        gridData.ForeColor = &HFF0000
    Else
        gridData.AllowAddNew = False
        gridData.AllowDelete = False
        gridData.AllowUpdate = False
        gridData.ForeColor = &H80000008
    End If
    If chkEditMode.Value = vbChecked And cmbTables.Text <> DEF_CUSTOM_SQL Then
        mnuEdit.Enabled = True
        chkEditMode.ForeColor = &HFF0000
    Else
        mnuEdit.Enabled = False
        chkEditMode.ForeColor = &HFF00FF
    End If
    
End Sub

Private Sub cmbTables_Change()
    Call cmbTables_Click
End Sub