local.frm

一个不错的数据库连接程序

           txterrors.Text = "命令执行完毕."
           
           Temp = cbotables.Text
           FillCombo
           cbotables.Text = Temp
           FillGrid
         
        End If
        
      End If
      
        
       txtquery.Height = 3255
   Exit Sub
Jump:
  
     txterrors.ZOrder
     txterrors.Text = Err.Description
     txtquery.Height = 3255
     txtquery.SetFocus
     RunQuery.CancelUpdate
     lbltotalfields.Caption = "0"
     lbltotalrecords.Caption = "0"
     Exit Sub
   
End Sub

Private Sub cmdstructure_Click()

    Unload frmstructure
    frmstructure.FillCombo
    frmstructure.lstfields.Height = 2600
    frmstructure.lblhead3.Caption = ""
    frmstructure.lstfields.Clear
    frmstructure.lstwherelist.Clear
    frmstructure.txtformatstring.Text = ""
    frmstructure.cmdinsert.BackColor = &HC0C000
    frmstructure.cmddelete.BackColor = -2147483633
    frmstructure.cmdupdate.BackColor = -2147483633
    frmstructure.Tags = "insert"
    Load frmstructure
    frmstructure.Show vbModal

End Sub

Private Sub cmdzoom_Click()
    txtquery.Height = 5535
    Me.txterrors.Visible = False
    Me.lstresult.Visible = False
    Me.txtquery.SetFocus
End Sub

Private Sub Command1_Click()
On Error Resume Next

    If Current_Table <> "" Then
        If cbotables.ListCount = 0 Then Current_Table = ""
        Me.cbotables.Text = Current_Table
        FillGrid
    End If

End Sub

Private Sub Command5_Click()
txtquery.Height = txtquery.Height - 100
MsgBox txtquery.Height
End Sub

Private Sub Form_Load()
On Error GoTo Jump

         If Trim(GetDsn) <> "" Then
         
            Set cn = New ADODB.Connection
            
            DSNDatabase
         
            If DatabaseType = SQL_Server_DSN Then
                  
                  GetAuthentication_Information
                   
                   Connect Trim(GetDsn), Trim(SQL_Authentication(0).UID), Trim(SQL_Authentication(1).Pass)
                   
            Else
                   Connect Trim(GetDsn)
            End If
            
            If Raiserror = False Then
                
                FillCombo
                lstfields.ListItems.Clear
                frmmain.lbltables.Caption = "[ " & Trim(GetDsn) & " : "
                frmmain.lbltables.Caption = frmmain.lbltables.Caption & IIf(Tablecount = 1, Tablecount & " 表", Tablecount & " 表") & " ]"
                
                Caption = "本地数据库 " & Space(2) & "[ 数据库 : " & Trim(GetDsnDatabase) & Space(3) & " DSN : " & Trim(GetDsn) & " ]"
                
            End If
             
         Else
         
             Caption = "本地数据库 "
         
         End If
         
          If Trim(GetLocalDatabasePath) <> "" Then
             
             mnusep2.Visible = True
             mnuruntime.Visible = True
             mnuruntime.Caption = Trim(GetLocalDatabasePath)
             
          Else
             
              mnusep2.Visible = False
              mnuruntime.Visible = False
              mnuruntime.Caption = ""
          
          End If
         
          txtquery.Text = ""
          SSTab1.Tab = 0
          txtquery.SelColor = vbBlue
          StatusBar1.Panels(2).Text = "总计记录 : 0"
          StatusBar1.Panels(3).Text = "总计字段 : 0"
          j = 0
          num = 0
          
Exit Sub
Jump:
  MsgBox Err.Description, vbCritical
End Sub

Public Function cType(ByVal Value As ADOX.DataTypeEnum) As String
  Select Case Value
    Case adTinyInt: cType = "TinyInt"
    Case adSmallInt: cType = "SmallInt"
    Case adInteger: cType = "Number"
    Case adBigInt: cType = "BigInt"
    Case adUnsignedTinyInt: cType = "UnsignedTinyInt"
    Case adUnsignedSmallInt: cType = "UnsignedSmallInt"
    Case adUnsignedInt: cType = "UnsignedInt"
    Case adUnsignedBigInt: cType = "UnsignedBigInt"
    Case adSingle: cType = "Single"
    Case adDouble: cType = "Double"
    Case adCurrency: cType = "Currency"
    Case adDecimal: cType = "Decimal"
    Case adNumeric: cType = "Numeric"
    Case adBoolean: cType = "Boolean"
    Case adUserDefined: cType = "UserDefined"
    Case adVariant: cType = "Variant"
    Case adGUID: cType = "GUID"
    Case adDate: cType = "Date/Time"
    Case adDBDate: cType = "Date/Time"
    Case adDBTime: cType = "Date/Time"
    Case adDBTimeStamp: cType = "Date/Time"
    Case adBSTR: cType = "BSTR"
    Case adChar: cType = "Text"
    Case adVarChar: cType = "Text"
    Case adLongVarChar: cType = "Text"
    Case adWChar: cType = "Text"
    Case adVarWChar: cType = "Text"
    Case adLongVarWChar: cType = "Memo"
    Case adBinary: cType = "adBinary"
    Case adVarBinary: cType = "adVarBinary"
    Case adLongVarBinary: cType = "OLE Object"
    Case Else: cType = Value
  End Select
End Function

Public Sub FillCombo()
On Error GoTo Jump

 cbotables.Clear
 cbotables.Text = ""
 Tablecount = 0
 
    For Each Table In mCat.Tables
    
     If Table.Type = "TABLE" Then
     
       cbotables.AddItem Table.Name
       Tablecount = Tablecount + 1
     
     End If
    
    Next
 
Exit Sub
Jump:

     MsgBox Err.Description, vbCritical

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 End
End Sub

Private Sub lstfields_Click()

 If Me.chkmulti = 1 Then
    For i = 1 To lstfields.ListItems.Count
        If lstfields.ListItems.Item(i).Checked = True Then
            lstfields.ListItems.Item(i).Selected = True
        Else
            lstfields.ListItems.Item(i).Selected = False
        End If
    Next
 End If

End Sub

Private Sub lstfields_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

    lstfields.SortKey = ColumnHeader.Index - 1
    
    If num = 0 Then
      Me.lstfields.SortOrder = lvwAscending
      num = 1
    Else
      Me.lstfields.SortOrder = lvwDescending
      num = 0
    End If
   
End Sub

Private Sub lstresult_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
  Me.lstresult.SortKey = ColumnHeader.Index - 1
    
    If num = 0 Then
      Me.lstresult.SortOrder = lvwAscending
      num = 1
    Else
      Me.lstresult.SortOrder = lvwDescending
      num = 0
    End If
End Sub

Private Sub mnuabout_Click()
       
  MsgBox "All rights ﹔eserved to Deepak Sharma" & vbCrLf & vbCrLf _
  + Space(8) & "[e-mail]"
  
End Sub

Private Sub mnuaccess_Click()

DatabaseType = MSAccess
With cd
 .DialogTitle = "Select Database"
 .Filter = "(*.MDB)|*.mdb"
 .ShowOpen
 
 If .FileTitle <> "" Then
    DSN_Less_Connect .Filename, MSAccesss
  
  If Raiserror = False Then
  
    Database_Name = .FileTitle
    FillCombo
    lstfields.ListItems.Clear
    frmmain.lbltables.Caption = "[ " & Database_Name & " : "
    frmmain.lbltables.Caption = frmmain.lbltables.Caption & IIf(Tablecount = 1, Tablecount & " 表", Tablecount & " 表") & " ]"
    StatusBar1.Panels(2).Text = "总计记录 : 0"
    StatusBar1.Panels(3).Text = "总计字段 : 0"
    For i = 1 To frmmain.lstfields.ColumnHeaders.Count
       frmmain.lstfields.ColumnHeaders(i).Text = ""
    Next
    
    Caption = "本地数据库 " & Space(2) & "[ " & .Filename & " ]"
    mnusep2.Visible = True
    mnuruntime.Visible = True
    mnuruntime.Caption = .Filename
    SetLocalDatabasePath .Filename
    
  End If
    
 Else
  
    DSNDatabase
    
 End If
   
End With
End Sub

Private Sub mnuaccessdsn_Click()
  DatabaseType = MSAccess_DSN
  DoEvents
  frmODBCLogon.Show 1
End Sub

Private Sub mnumysql_Click()
  DatabaseType = MYSQl
  frmODBCLogon.Show 1
End Sub

Private Sub mnuoracle_Click()
  DatabaseType = Oracle
  frmODBCLogon.Show 1
End Sub

Private Sub mnuruntime_Click()
    
    If Dir(GetLocalDatabasePath, vbNormal) = "" Then
       
        MsgBox "没有找到数据库文件 " & vbCrLf & GetLocalDatabasePath, vbCritical
        Exit Sub
    
    Else
    
        DatabaseType = MSAccess
    
        DSN_Less_Connect Trim(GetLocalDatabasePath), MSAccesss
        
        If Raiserror = False Then
        
            FillCombo
            Database_Name = Mid(Trim(GetLocalDatabasePath), InStrRev(Trim(GetLocalDatabasePath), "\") + 1)
            lstfields.ListItems.Clear
            frmmain.lbltables.Caption = "[ " & Database_Name & " : "
            frmmain.lbltables.Caption = frmmain.lbltables.Caption & IIf(Tablecount = 1, Tablecount & " 表", Tablecount & " 表") & " ]"
            StatusBar1.Panels(2).Text = "总计记录 : 0"
            StatusBar1.Panels(3).Text = "总计字段 : 0"
            For i = 1 To frmmain.lstfields.ColumnHeaders.Count
               frmmain.lstfields.ColumnHeaders(i).Text = ""
            Next
            
            Caption = "本地数据库 " & Space(2) & "[ " & GetLocalDatabasePath & " ]"
          
        End If
        
    End If
End Sub

Private Sub mnuSqlserver_Click()
  DatabaseType = SQL_Server
  frmSQLSERVER.Show 1
End Sub

Private Sub mnuSqlserverdsn_Click()
  DatabaseType = SQL_Server_DSN
  frmODBCLogon.Show 1
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
  
  Select Case PreviousTab
  
  Case 0 'table tab
     
     If Me.Check1.Value = 1 Then Timer1.Enabled = False
     Me.txtquery.SetFocus
     num = 0
     
       
  Case 1 'query tab
  
     Temp = cbotables.Text
     Check1_Click
     FillCombo
     FillGrid
     cbotables.Text = Temp
     num = 0
     
  End Select
  
End Sub

Private Sub Timer1_Timer()
    
    Command1_Click
    
End Sub

Private Sub txtquery_Change()
   Me.txtquery.SelColor = vbBlue
End Sub

Private Sub txtquery_GotFocus()
   Me.txtquery.SelColor = vbBlue
End Sub

Private Sub txtquery_KeyDown(KeyCode As Integer, Shift As Integer)
   Me.txtquery.SelColor = vbBlue
   If KeyCode = vbKeyF5 Then
     cmdrun_Click
   End If
End Sub

Private Sub txtquery_KeyPress(KeyAscii As Integer)
   Me.txtquery.SelColor = vbBlue
End Sub