Generador de Consultas
Saludos estoy realizando un sistema de generador de consultas, este consta de tres list box,en un list cargo la tabla, en el otro los campos, y el ultimo list muestra los campos seleccinados por el usuario con los botones >, >>, <, <<, si el usuario selecciona tres campos los traspasa sin ningun problema al ultimo list en el momento de dar click en un check para que muestre los campos en un grilla me presenta repetidamente el primer campo, no toma en cuenta los otros dos te anexo el codigo completo a ver si me puedes ayudar.
Option Explicit
Dim rsRecordset As ADODB.Recordset
Dim connConnection As ADODB.Connection
Dim mstrDatabasePath As String
Dim mstrConnectionString As String
Dim mstrProvider As String
Dim mstrTableName As String
Dim mstrSQL As String
Dim recCount As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''
Dim mstrRecordSetObject As String
Dim tmpDBstring As String
Dim mstrDataGrid As Boolean
Const mstrAccessProvider351 As String = "Provider= Microsoft.Jet.OLEDB.3.51;"
Const mstrAccessProvider40 As String = "Provider=Microsoft.Jet.OLEDB.4.0;"
Private Sub chkNoWhere_Click()
chkWhere.Enabled = False
'lstFields.Enabled = True 'False
'cmdClear.Visible = True
'cmdExit1.Visible = False
Call MakeSQLStmt
'cmdShowGrid_Click
'cmdMakeSQLStmt.Enabled = True
'cmdShowGrid.Enabled = False
txtSQL.Enabled = False
End Sub
Private Sub chkWhere_Click()
chkNoWhere.Enabled = False
Call MakeSQLStmt
' txtSQL = txtSQL & " Where"
'tv.Enabled = True
lstFields.Enabled = False
cmdMakeSQLStmt.Enabled = False
lblSQLOper.Visible = True
lstSQLMath.Visible = True
cmdShowCode.Enabled = False
txtSQL.SetFocus
'SetButtonForeColor cmdShowCode, &H808080
End Sub
Private Sub cmdClear_Click()
Unload Me
Me.Show
'Me.Top = 200
'cmdClear.BackColor = &H8000000F
' SetButtonForeColor cmdClear, &HC00000
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub LoadGrid()
On Error GoTo HandleErrors:
dbGrid.Visible = True
Set rsRecordset = New ADODB.Recordset
rsRecordset.CursorType = adUseClient
rsRecordset.LockType = adLockPessimistic
rsRecordset.Source = txtSQL.Text 'mstrSQL
rsRecordset.ActiveConnection = connConnection
rsRecordset.Open
'Open the recordset that was generated.
Set dbGrid.DataSource = rsRecordset
' dbGrid.Visible = True
'View the generated data
Exit Sub
HandleErrors:
MsgBox "An invalid attempt has been made to open a database." & _
" This action has been cancelled. Please check your SQL" & _
" statement", vbOKOnly, "Error"
'Call cmdClear_Click
Exit Sub
End Sub
Private Sub cmdShowGrid_Click()
'txtCodeWindow.Visible = False
Call LoadGrid
End Sub
Private Sub Form_Load()
'*** Code added by HelpWriter ***
'***********************************
' Me.Height = 3585
'Locate Form on the Screen
'Me.Top = 200
'Me.Move (Screen.Width - Me.Width) / 2
mstrProvider = mstrAccessProvider40
'Fill the SQL Math List Box
With lstSQLMath
.AddItem "WHERE"
.AddItem "AS "
.AddItem "BETWEEN "
.AddItem "AND "
.AddItem "OR"
.AddItem "GROUP BY "
.AddItem "ORDER BY "
.AddItem "IN "
.AddItem "LIKE"
.AddItem "COUNT"
.AddItem "SUM"
.AddItem "< "
.AddItem "> "
.AddItem "= "
.AddItem "<= "
.AddItem ">= "
End With
End Sub
Private Sub cmdOpenDB_Click()
Dim strCheckForDatabase As String
On Error GoTo HandleErrors
dlgCommon.DialogTitle = "Pick A Database"
'Give the file selection window a title.
dlgCommon.InitDir = App.Path
'The file selection window will start in the
'applications directory.
'Allow the user to view only Access files.
dlgCommon.Filter = "Access Databases (*.mdb)|*.mdb|"
dlgCommon.ShowOpen
'Open the file selection window.
strCheckForDatabase = Right(dlgCommon.FileName, 4)
'Select the last four letters of the file selected.
Select Case strCheckForDatabase
Case vbNullString
'Do not allow empty strings.
Exit Sub
Case ".mdb"
'Assign the chosen file to the path string.
mstrDatabasePath = dlgCommon.FileName
'Do not allow the user to select another DB until
'clear is clicked.
cmdOpenDB.Enabled = False
End Select
'Make the connection string with the source and selected file.
mstrConnectionString = mstrProvider & "Data Source=" & _
mstrDatabasePath
'Open the connection with the selected db.
Set connConnection = New ADODB.Connection
connConnection.CursorLocation = adUseClient
connConnection.Open mstrConnectionString
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rsRecordset = connConnection.OpenSchema(adSchemaTables)
recCount = 0
Do Until rsRecordset.EOF
If UCase(Left(rsRecordset!Table_Name, 4)) <> "MSYS" Then
lstTables.AddItem rsRecordset!Table_Name
recCount = recCount + 1
End If
rsRecordset.MoveNext
Loop
lblTableCount.Visible = True
lblTableCount = "(" & recCount & ")" & " - Tablas"
txtGetDB = mstrDatabasePath
tmpDBstring = txtGetDB
lblOpeningTables.Visible = False
Exit Sub
HandleErrors:
MsgBox "Error Al abrir la Base de Datos. Please try again. Remember to select" & _
" the appropriate provider", vbOKCancel, "Error"
cmdOpenDB.Enabled = True
End Sub
Private Sub lstTables_Click()
Dim intLoop, intLen As Integer
Dim strHoldTableName As String
Dim strTemp As String
Dim strtest As String
lstAllFields.Clear 'Clear the list.
cmdOpenDB.Enabled = False
'Get the name of the table selected.
mstrTableName = "[" & lstTables.List(lstTables.ListIndex) & "]"
'Add the wildcard character.
Set rsRecordset = New ADODB.Recordset
Set rsRecordset = _
connConnection.Execute("Select * From [" & lstTables.List(lstTables.ListIndex) & "]", 1, 1)
If rsRecordset.RecordCount <> 0 Then
lstAllFields.AddItem "*"
End If
'Get the names...
Option Explicit
Dim rsRecordset As ADODB.Recordset
Dim connConnection As ADODB.Connection
Dim mstrDatabasePath As String
Dim mstrConnectionString As String
Dim mstrProvider As String
Dim mstrTableName As String
Dim mstrSQL As String
Dim recCount As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''
Dim mstrRecordSetObject As String
Dim tmpDBstring As String
Dim mstrDataGrid As Boolean
Const mstrAccessProvider351 As String = "Provider= Microsoft.Jet.OLEDB.3.51;"
Const mstrAccessProvider40 As String = "Provider=Microsoft.Jet.OLEDB.4.0;"
Private Sub chkNoWhere_Click()
chkWhere.Enabled = False
'lstFields.Enabled = True 'False
'cmdClear.Visible = True
'cmdExit1.Visible = False
Call MakeSQLStmt
'cmdShowGrid_Click
'cmdMakeSQLStmt.Enabled = True
'cmdShowGrid.Enabled = False
txtSQL.Enabled = False
End Sub
Private Sub chkWhere_Click()
chkNoWhere.Enabled = False
Call MakeSQLStmt
' txtSQL = txtSQL & " Where"
'tv.Enabled = True
lstFields.Enabled = False
cmdMakeSQLStmt.Enabled = False
lblSQLOper.Visible = True
lstSQLMath.Visible = True
cmdShowCode.Enabled = False
txtSQL.SetFocus
'SetButtonForeColor cmdShowCode, &H808080
End Sub
Private Sub cmdClear_Click()
Unload Me
Me.Show
'Me.Top = 200
'cmdClear.BackColor = &H8000000F
' SetButtonForeColor cmdClear, &HC00000
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub LoadGrid()
On Error GoTo HandleErrors:
dbGrid.Visible = True
Set rsRecordset = New ADODB.Recordset
rsRecordset.CursorType = adUseClient
rsRecordset.LockType = adLockPessimistic
rsRecordset.Source = txtSQL.Text 'mstrSQL
rsRecordset.ActiveConnection = connConnection
rsRecordset.Open
'Open the recordset that was generated.
Set dbGrid.DataSource = rsRecordset
' dbGrid.Visible = True
'View the generated data
Exit Sub
HandleErrors:
MsgBox "An invalid attempt has been made to open a database." & _
" This action has been cancelled. Please check your SQL" & _
" statement", vbOKOnly, "Error"
'Call cmdClear_Click
Exit Sub
End Sub
Private Sub cmdShowGrid_Click()
'txtCodeWindow.Visible = False
Call LoadGrid
End Sub
Private Sub Form_Load()
'*** Code added by HelpWriter ***
'***********************************
' Me.Height = 3585
'Locate Form on the Screen
'Me.Top = 200
'Me.Move (Screen.Width - Me.Width) / 2
mstrProvider = mstrAccessProvider40
'Fill the SQL Math List Box
With lstSQLMath
.AddItem "WHERE"
.AddItem "AS "
.AddItem "BETWEEN "
.AddItem "AND "
.AddItem "OR"
.AddItem "GROUP BY "
.AddItem "ORDER BY "
.AddItem "IN "
.AddItem "LIKE"
.AddItem "COUNT"
.AddItem "SUM"
.AddItem "< "
.AddItem "> "
.AddItem "= "
.AddItem "<= "
.AddItem ">= "
End With
End Sub
Private Sub cmdOpenDB_Click()
Dim strCheckForDatabase As String
On Error GoTo HandleErrors
dlgCommon.DialogTitle = "Pick A Database"
'Give the file selection window a title.
dlgCommon.InitDir = App.Path
'The file selection window will start in the
'applications directory.
'Allow the user to view only Access files.
dlgCommon.Filter = "Access Databases (*.mdb)|*.mdb|"
dlgCommon.ShowOpen
'Open the file selection window.
strCheckForDatabase = Right(dlgCommon.FileName, 4)
'Select the last four letters of the file selected.
Select Case strCheckForDatabase
Case vbNullString
'Do not allow empty strings.
Exit Sub
Case ".mdb"
'Assign the chosen file to the path string.
mstrDatabasePath = dlgCommon.FileName
'Do not allow the user to select another DB until
'clear is clicked.
cmdOpenDB.Enabled = False
End Select
'Make the connection string with the source and selected file.
mstrConnectionString = mstrProvider & "Data Source=" & _
mstrDatabasePath
'Open the connection with the selected db.
Set connConnection = New ADODB.Connection
connConnection.CursorLocation = adUseClient
connConnection.Open mstrConnectionString
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rsRecordset = connConnection.OpenSchema(adSchemaTables)
recCount = 0
Do Until rsRecordset.EOF
If UCase(Left(rsRecordset!Table_Name, 4)) <> "MSYS" Then
lstTables.AddItem rsRecordset!Table_Name
recCount = recCount + 1
End If
rsRecordset.MoveNext
Loop
lblTableCount.Visible = True
lblTableCount = "(" & recCount & ")" & " - Tablas"
txtGetDB = mstrDatabasePath
tmpDBstring = txtGetDB
lblOpeningTables.Visible = False
Exit Sub
HandleErrors:
MsgBox "Error Al abrir la Base de Datos. Please try again. Remember to select" & _
" the appropriate provider", vbOKCancel, "Error"
cmdOpenDB.Enabled = True
End Sub
Private Sub lstTables_Click()
Dim intLoop, intLen As Integer
Dim strHoldTableName As String
Dim strTemp As String
Dim strtest As String
lstAllFields.Clear 'Clear the list.
cmdOpenDB.Enabled = False
'Get the name of the table selected.
mstrTableName = "[" & lstTables.List(lstTables.ListIndex) & "]"
'Add the wildcard character.
Set rsRecordset = New ADODB.Recordset
Set rsRecordset = _
connConnection.Execute("Select * From [" & lstTables.List(lstTables.ListIndex) & "]", 1, 1)
If rsRecordset.RecordCount <> 0 Then
lstAllFields.AddItem "*"
End If
'Get the names...
1 Respuesta
Respuesta de denciso
1