frmstructure.frm

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

Private Sub cmdclose_Click()
Unload Me
End Sub

Private Sub cmddelete_Click()
  main_Frame.ZOrder
  lblhead1.Caption = "Delete From"
  lblhead2.Caption = "Where"
  lblhead3.Caption = ""
  lstfields.Height = 2600
  Tags = "delete"
  RefreshSelect
  cmdinsert.BackColor = &H8000000F
  cmdupdate.BackColor = &H8000000F
  cmddelete.BackColor = &HC0C000
End Sub

Private Sub cmdforvb_Click()

If cbotable.Text = "" Then
  MsgBox "Select Table Name", vbExclamation
  Exit Sub
End If

tablefound = False

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

If tablefound = False Then
  MsgBox "No A Valid Table", vbExclamation
  cbotable.Text = ""
  lstfields.Clear
  lstwherelist.Clear
  Exit Sub
End If
 
Selected = False
 
For i = 0 To lstfields.ListCount - 1

    If lstfields.Selected(i) = True Then
       
       Selected = True
       
    End If

Next
 
If Selected = False Then
  
  MsgBox "Select At Least One Field From The Field List", vbExclamation
  Exit Sub

End If
 
 txtformatstring.Text = ""
 txtformatstring.Text = FormatSQL
 
End Sub

Function FormatSQL() As String

    WhereList = ""
    WhereLists = ""
    ValuesList = ""
    Lists = ""
    Counter = 1
   
   For i = 0 To lstfields.ListCount - 1
   
     If lstfields.Selected(i) = True Then
        
       If Tags = "insert" Then
          
          ValuesList = ValuesList & lstfields.List(i) & ","
          
          If Counter < lstfields.SelCount Then
            Lists = Lists & """'""& " & lstfields.List(i) & " &""',""" & " & _" & vbCrLf
          Else
            Lists = Lists & """'""& " & lstfields.List(i) & " &""'""" & " & _" & vbCrLf
          End If
          
          Counter = Counter + 1
          
       ElseIf Tags = "update" Then
       
          If ValuesList = "" Then ValuesList = """"
          ValuesList = ValuesList & lstfields.List(i) & "='""" & " & " & lstfields.List(i) & " & " & """'"" & _ " & vbCrLf & ""","
          
       ElseIf Tags = "delete" Then
          
          If WhereLists = "" Then
            WhereLists = WhereLists & """" & lstfields.List(i) & "='""" & " & " & lstfields.List(i) & " & " & """'"" & _ " & vbCrLf & """and "
          Else
            WhereLists = WhereLists & lstfields.List(i) & "='""" & " & " & lstfields.List(i) & " & " & """'"" & _ " & vbCrLf & """and "
          End If
       
       End If
       
     End If
   
   Next
   
   'where for update only
   
   For i = 0 To lstwherelist.ListCount - 1
   
     If lstwherelist.Selected(i) = True Then

         WhereList = WhereList & lstwherelist.List(i) & "='""" & " & " & lstwherelist.List(i) & " & " & """'"" & _ " & vbCrLf & """and "
        
     End If
     
   Next
   
   Select Case Tags
   Case "insert"
       
         FormatSQL = """Insert into " & cbotable & "(" & Mid(ValuesList, 1, Len(ValuesList) - 1) & ") values(""" & " & _ " & vbCrLf & Lists & """)"""
       
   Case "update"
   
        If ValuesList <> "" And WhereList = "" Then
       
         FormatSQL = """Update " & cbotable & " Set " & """ & _" & vbCrLf & Mid(ValuesList, 1, Len(ValuesList) - 8)
         
        Else
        
         FormatSQL = """Update " & cbotable & " Set " & """ & _" & vbCrLf & Mid(ValuesList, 1, Len(ValuesList) - 1) & "Where " & Mid(WhereList, 1, Len(WhereList) - 11)
         
        End If
        
   Case "delete"
   
        FormatSQL = """Delete from " & cbotable & " Where " & """ & _" & vbCrLf & Mid(WhereLists, 1, Len(WhereLists) - 11)
   
   
   End Select

End Function

Private Function Format() As String
    
    WhereList = ""
    WhereLists = ""
    ValuesList = ""
    Lists = ""
    Temp = ""
 
 With lstfields
  
    SQL = ""
  
    For i = 0 To .ListCount - 1
     
      If .Selected(i) = True Then
            
         FieldList = FieldList & .List(i) & IIf(Tags = "insert", ",", "='' , ")
         Temp = Temp & "'',"
         WhereList = WhereList & .List(i) & "='' And "
         
      End If
      
    Next
   
    For i = 0 To lstwherelist.ListCount - 1
    
      If lstwherelist.Selected(i) = True Then
         WhereLists = WhereLists & lstwherelist.List(i) & "='' And "
      End If
      
    Next
     
    If FieldList <> "" Then FieldList = Mid(FieldList, 1, Len(FieldList) - 1)
    If Temp <> "" Then Temp = Mid(Temp, 1, Len(Temp) - 1)
    If WhereLists <> "" Then WhereLists = Mid(WhereLists, 1, Len(WhereLists) - 4)
    If WhereList <> "" Then WhereList = Mid(WhereList, 1, Len(WhereList) - 4)
   
    Select Case Tags
    
    Case "insert"
  
         Format = "Insert into " & cbotable.Text & "(" & FieldList & ") values(" & Temp & ")"
  
    Case "update"
    
         If FieldList <> "" And WhereLists = "" Then
            Format = "Update " & cbotable.Text & " Set " & Mid(FieldList, 1, Len(FieldList) - 1)
         Else
            Format = "Update " & cbotable.Text & " Set " & Mid(FieldList, 1, Len(FieldList) - 1) & " Where " & WhereLists
         End If
     
    Case "delete"
    
         If WhereList <> "" Then
            Format = "Delete From " & cbotable.Text & " Where " & WhereList
         Else
            Format = "Delete From " & cbotable.Text
         End If
  
    End Select
   
 End With
 
End Function

Private Sub cmdinsert_Click()
main_Frame.ZOrder
lblhead1.Caption = "Insert Into"
lblhead2.Caption = "Fields"
lblhead3.Caption = ""
lstfields.Height = 2600
Tags = "insert"
RefreshSelect
cmdinsert.BackColor = &HC0C000
cmdupdate.BackColor = &H8000000F
cmddelete.BackColor = &H8000000F
End Sub

Public Sub RefreshSelect()
For i = 0 To lstfields.ListCount - 1
  
  lstfields.Selected(i) = False
Next

For i = 0 To lstwherelist.ListCount - 1
  
  lstwherelist.Selected(i) = False

Next
End Sub

Private Sub cmdnormal_Click()


If cbotable.Text = "" Then
  MsgBox "Select Table Name", vbExclamation
  Exit Sub
End If

tablefound = False

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

If tablefound = False Then
  MsgBox "No A Valid Table", vbExclamation
  cbotable.Text = ""
  lstfields.Clear
  lstwherelist.Clear
  Exit Sub
End If

Selected = False
 
For i = 0 To lstfields.ListCount - 1

    If lstfields.Selected(i) = True Then
       
       Selected = True
       
    End If

Next
 
If Selected = False Then
  
  MsgBox "Select At Least One Field From The Field List", vbExclamation
  Exit Sub

End If


  txtformatstring.Text = ""
  txtformatstring.Text = Format
    
End Sub

Private Sub cmdShow_Click()
FillList lstfields
FillList lstwherelist
End Sub

Private Sub cmdupdate_Click()
main_Frame.ZOrder
lblhead1.Caption = "Update Table"
lblhead2.Caption = "Set (Fields)"
lblhead3.Caption = "Where"
lstfields.Height = 1300
Tags = "update"
RefreshSelect
cmdinsert.BackColor = &H8000000F
cmdupdate.BackColor = &HC0C000
cmddelete.BackColor = &H8000000F
End Sub

Public Sub FillCombo()
On Error GoTo Jump

 cbotable.Clear
 cbotable.Text = ""
 
    For Each Table In mCat.Tables
    
     If Table.Type = "TABLE" Then
     
       cbotable.AddItem Table.Name
     
     End If
    
    Next
 
Exit Sub
Jump:
   MsgBox Err.Description, vbCritical
End Sub

Public Sub FillList(lst As ListBox)
On Error GoTo Jump

 If cbotable.Text <> "" Then

     lst.Clear
     If Field.State = 1 Then Field.Close
     Field.Open "select * from " & Trim(cbotable.Text), cn, adOpenDynamic, adLockOptimistic
      
  Screen.MousePointer = vbHourglass
      
     For i = 0 To Field.Fields.Count - 1
    
        lst.AddItem Field.Fields(i).Name
    
     Next
     
   Screen.MousePointer = vbNormal
 
 End If
 
Exit Sub
Jump:

     MsgBox Err.Description, vbCritical

End Sub

Private Sub Command2_Click()
    txtformatstring.SelStart = 0
    txtformatstring.SelLength = Len(txtformatstring)
    txtformatstring.SetFocus
End Sub