local.frm

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

        End If
        
        
        Fill.Open Tablename, cn, adOpenDynamic, adLockOptimistic
        Field.Open Tablename, cn, adOpenDynamic, adLockOptimistic
        
        ReDim StoreValues(Field.Fields.Count - 1)   'store the field names
   
        For i = 0 To Field.Fields.Count - 1

            With Me.lstfields
   
                .ColumnHeaders.Add , , Field.Fields(i).Name, 1800
                .HideSelection = True
                 
                 StoreValues(i).Field_Name = Field.Fields(i).Name
                 StoreValues(i).Field_Type = cType(Field.Fields(i).Type)
                 StoreValues(i).Field_Length = Field.Fields(i).DefinedSize
                 
            End With
   
        Next
        
        j = 0
        
        While Not Fill.EOF
    
            Set X = lstfields.ListItems.Add(, , Fill.Fields(0) & "")
    
            For i = 1 To Fill.Fields.Count - 1
    
                With Me.lstfields
      
                    X.SubItems(i) = Fill.Fields(i) & ""
       
                End With
                
            Next
    
            j = j + 1
            Fill.MoveNext
         Wend
         
         Screen.MousePointer = vbArrow
         Me.StatusBar1.Panels(1).Text = "完毕"
         StatusBar1.Panels(1).Picture = ImageList1.ListImages(4).Picture
         Me.StatusBar1.Panels(2).Text = "总计记录 : " & Fill.RecordCount
         Me.StatusBar1.Panels(3).Text = "总计字段 : " & Field.Fields.Count
         Me.cbotables.SetFocus
         
   End If
 
Exit Sub
Jump:

     StatusBar1.Panels(1).Text = "完毕"
     StatusBar1.Panels(1).Picture = ImageList1.ListImages(4).Picture
     Me.cmddescriptions.Enabled = False
     Screen.MousePointer = vbArrow
     MsgBox Err.Description, vbCritical
     
End Sub

Private Sub cbotables_Click()
On Error GoTo Jump

TempTable = Trim(cbotables.Text)
If Fills = True Then FillGrid
Fills = False

Exit Sub
Jump:
  
     MsgBox Err.Description, vbCritical
  
End Sub

Private Sub cbotables_DropButtonClick()
 
    Fills = True

End Sub

Private Sub cbotables_KeyDown(KeyCode As MSForms.ReturnInteger, Shift As Integer)

 If KeyCode = 13 Then FillGrid

End Sub

Private Sub Check1_Click()
    
    If Me.Check1.Value = 1 Then
        Timer1.Enabled = True
    Else
        Timer1.Enabled = False
    End If
    
End Sub

Private Sub chkmulti_Click()

If chkmulti.Value = 1 Then

   Me.lstfields.Checkboxes = True
   Me.lblctrlkeys.Visible = False
   ctrl.Visible = False
   FillGrid
   'cbotables_Click

ElseIf chkmulti.Value = 0 Then

  Me.lstfields.Checkboxes = False
  Me.lblctrlkeys.Visible = True
  ctrl.Visible = True

End If

End Sub

Private Sub cmdbatch_Click()
On Error GoTo Jump

Dim BatchQuery, TempStore As Variant
Dim Counter As Integer

If Trim(txtquery.Text) <> "" Then

  Counter = 0
  lbltotalfields.Caption = "0"
  lbltotalrecords.Caption = "0"
  txtquery.Height = 3255
  
  TempStore = ""
  TempStore = txtquery.Text
  TempStore = Replace(TempStore, vbCrLf, "|")
  BatchQuery = Split(TempStore, "|")
  
  For i = 0 To UBound(BatchQuery)
   
   If BatchQuery(i) <> "" Then
      
      TempStore = BatchQuery(i) 'store for error
      cn.Execute BatchQuery(i)
      Counter = Counter + 1
      txterrors.Visible = True
      lstresult.Visible = True
      txterrors.Text = Counter & " Row(s) Affected "

   End If
   
  Next
  
     Temp = cbotables.Text
     FillCombo
     cbotables.Text = Temp
     FillGrid
  
  Erase BatchQuery

End If

Exit Sub
Jump:
     
  If Err.Number <> 0 Then
     
     txterrors.Visible = True
     txterrors.ZOrder
     'MsgBox ExtractErrors(Err.Description)
     txterrors.Text = Counter & " Row(s) Affected " & vbCrLf & vbCrLf & "Warning :  Above Selected Query Has Some Syntax Problem Check The Error." & vbCrLf & vbCrLf & "Error :  " & Err.Description
     
     Temp = cbotables.Text
     FillCombo
     cbotables.Text = Temp
     FillGrid
     
     For i = 1 To Len(txtquery.Text)
       
       If Trim(TempStore) = Trim(Mid(txtquery.Text, i, Len(TempStore))) Then
       
        txtquery.SelStart = i - 1
        txtquery.SelLength = Len(TempStore)
        txtquery.SelColor = vbRed
        txtquery.SetFocus
        Exit For
       
       End If
       
     Next
     
     txtquery.Height = 3255
     Me.txtquery.SetFocus
     lbltotalfields.Caption = "0"
     lbltotalrecords.Caption = "0"
     
  
    Exit Sub
   End If
   
End Sub

Private Sub cmdbrowse_Click()
 
On Error Resume Next
    TempStore = ""
    With cd
      .DialogTitle = "选择 SQL 文件"
      .Filter = "全部 SQL 文件|*.sql;*.txt"
      .ShowOpen
      If Me.cd.Filename <> "" Then
 
         Me.txtquery.LoadFile cd.Filename
         TempStore = Me.txtquery.Text
         Me.txtquery.Text = ""
         Me.txtquery.SelColor = vbBlue
         Me.txtquery.SelText = TempStore

      End If
  
    End With
    
End Sub

Private Function GetKey(j As Integer) As String
 
 'CHECK PRIMARY KEY
  Set Pk = cn.OpenSchema(adSchemaPrimaryKeys)
    While Not Pk.EOF
     If Trim(Me.cbotables.Text) = Pk.Fields("TABLE_NAME") Then
       If StoreValues(j).Field_Name = Pk.Fields("COLUMN_NAME") Then
          GetKey = "Primary Key"
          Fieldslist.cboprimarykeyfields.AddItem Pk.Fields("COLUMN_NAME")
       End If
     End If
  Pk.MoveNext
  Wend

  'CHECK FORIEGN KEY
   Set Fk = cn.OpenSchema(adSchemaForeignKeys)
   While Not Fk.EOF
     If Trim(Me.cbotables.Text) = Fk.Fields("FK_TABLE_NAME") Then
       If StoreValues(j).Field_Name = Fk.Fields("FK_COLUMN_NAME") Then
          GetKey = "Foreign Key" & " (" & Fk.Fields("PK_TABLE_NAME") & ")"
       End If
     End If
   Fk.MoveNext
   Wend

End Function

Private Sub cmddescriptions_Click()
On Error GoTo Jump

  tablefound = False

  For i = 0 To cbotables.ListCount - 1
    If Trim(cbotables.Text) = cbotables.List(i) Then
       tablefound = True
       Exit For
    End If
  Next

  If tablefound = False Then
    MsgBox "无法显示字段信息" & vbCrLf & "    表不存在. ", vbCritical
    Me.cbotables.SetFocus
    Exit Sub
  End If

  Fieldslist.lstdesc.ListItems.Clear
  Fieldslist.cboprimarykeyfields.Clear
  Fieldslist.lstrefrencesfields.Clear
  
  For j = 0 To UBound(StoreValues())
    
     Set X = Fieldslist.lstdesc.ListItems.Add(, , StoreValues(j).Field_Name, 1, 1)
     
     X.SubItems(1) = StoreValues(j).Field_Type
     X.SubItems(2) = StoreValues(j).Field_Length
     
     If DatabaseType = MSAccess Or DatabaseType = SQL_Server Then
        X.SubItems(3) = GetKey(j)
     End If
         
  Next
  Fieldslist.Form_Load
  Fieldslist.lbltablename.Caption = UCase(Me.cbotables.Text)
  Fieldslist.fieldscount.Caption = Fieldslist.lstdesc.ListItems.Count
  
  Fieldslist.Show vbModal
  
Exit Sub
Jump:
   
     MsgBox Err.Description, vbCritical
  
End Sub

Private Sub cmdformatvb_Click()

 frmformat.txttobeformat.Text = txtquery.SelText
 frmformat.txtwordsinline.Text = "50"
 frmformat.Show vbModal

End Sub

Private Sub cmdjoins_Click()
Load deletedrop
deletedrop.Show vbModal
End Sub

Private Sub cmdnew_Click()
 Me.txtquery.Text = ""
 Me.txterrors.Text = ""
 lbltotalfields.Caption = "0"
 lbltotalrecords.Caption = "0"
 txtquery.SetFocus
End Sub

Private Sub cmdrun_Click()

  If Me.txtquery.Text <> "" Then

       SQL = ""
       Me.txterrors.Text = ""
       Me.txterrors.Visible = True
       Me.lstresult.Visible = True
       
       If Me.txtquery.SelText = "" Then
          SQL = Trim(Me.txtquery.Text)
       Else
          SQL = Trim(Me.txtquery.SelText)
       End If
    
       SQLQUERY = IIf(LCase(Left(SQL, 6)) <> LCase("select"), False, True)
          
       On Error GoTo Jump
        
       If RunQuery.State = 1 Then RunQuery.Close
       RunQuery.Open SQL, cn, adOpenDynamic, adLockOptimistic
       
       If SQLQUERY = True Then
       
          Me.lstresult.ZOrder
          Me.lstresult.ListItems.Clear
          Me.lstresult.ColumnHeaders.Clear
        
          For i = 0 To RunQuery.Fields.Count - 1
    
             With Me.lstresult
       
               .ColumnHeaders.Add , , RunQuery.Fields(i).Name, 1800
               .HideSelection = True
       
             End With
       
          Next
      
          If RunQuery.RecordCount > 0 Then RunQuery.MoveFirst
      
          j = 0
          lbltotalfields.Caption = RunQuery.Fields.Count
         If RunQuery.RecordCount > 0 Then
         
            lbltotalfields.Caption = RunQuery.Fields.Count
            lbltotalrecords.Caption = RunQuery.RecordCount
            txtquery.Height = 3255
      
          While Not RunQuery.EOF
        
             Set X = lstresult.ListItems.Add(, , RunQuery.Fields(0) & " ")
        
             For i = 1 To RunQuery.Fields.Count - 1
        
                With Me.lstresult
          
                  X.SubItems(i) = RunQuery.Fields(i) & " "
           
                End With
        
             Next
        
             j = j + 1
             RunQuery.MoveNext
          Wend
          
        Else
          
          lbltotalrecords.Caption = "0"
        
        End If
        
        ElseIf SQLQUERY = False Then
        
           txterrors.ZOrder