|
|
Postada em 17/02/2006 09:16 hs
Olá! Alguém sabe como fazer para listar tabelas de uma base de dados para construir SQL's igual no Access?
Quero fazer aquelas janelinhas, ir clicando nos campos e ir montando a SQL.
<DIV>Klaus Lana</DIV>
|
|
|
|
|
|
|
|
Postada em 17/02/2006 10:58 hs
esse é código de um projetinho que eu fiz para mostar sql: form: Const CONFIRMA_GRAVACAO = 0 'constantes para testar confirmação do usuário
Const NAO_CONFIRMA_GRAVACAO = 1 Public vgSituacao As Integer, vgCaracteristica As Integer, _
vgTipo As Integer, vgFormID As Long 'propriedades que todos os forms têm... Dim vgExpSQL As String, vgFromAnterior As String 'dimensiona
Dim vgNaoEClick As Integer, vgModifQuery As Integer 'o que precisamos
Dim vgNomeSQL As String ' muda status do botão de gravação
Sub AtualizaBotGravacao(vgStatus As Integer)
vgModifQuery = vgStatus 'liga flag
botGrava.Enabled = vgStatus 'muda status do botão, de acordo
End Sub Private Sub botConcatena_Click()
Dim vgWh As String, x As String, vgSegOperando As String, vgTp As Integer, _
C As String, T As String, i As Integer, EmB As Integer
If opcFiltro(1).Value Then 'se for união de tabelas
vgSegOperando$ = cboValor.Text 'pega campo da 2a. tabela
Else 'se quer filtrar
i = InStr(cboCampos.Text, ".") 'vamos separar o
T$ = Left$(cboCampos.Text, i - 1) 'nome da tabela e o
C$ = Mid$(cboCampos.Text, Len(T$) + 2) 'nome do campo
T$ = Retira$(T$, "[]", UM_A_UM) 'tira os colchetes da
C$ = Retira$(C$, "[]", UM_A_UM) 'tabela e campo
EmB = (UCase$(cboValor.Text) = UCase$("")) 'vamos ver se foi capturado da combo - se sim, é campo
x$ = cboValor.Text
For i = 0 To cboValor.ListCount - 1
If cboValor.List(i) = x$ Then 'foi capturado da combo, é campo
i = -2
Exit For
End If
Next
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
If vgTp = dbBoolean Then 'qual o tipo do
vgSegOperando$ = Str$(Val(cboValor.Text) <> 0) 'campo para montar
ElseIf vgTp = dbText Or vgTp = dbMemo Then 'se for tipo texto
If cboValor.Text = "" Or EmB Then
vgSegOperando$ = "''"
Else
If i < 0 Then 'é campo da lista
vgSegOperando$ = cboValor.Text
Else
vgSegOperando$ = Chr$(39) + cboValor.Text + Chr$(39) 'expressão, poe plics
End If
End If
ElseIf vgTp = dbDate Then 'se for data
If cboValor.Text = "" Or EmB Then
vgSegOperando$ = "Null"
ElseIf UCase$(cboValor.Text) = "DATE" Or UCase$(cboValor.Text) = "DATE()" Or UCase$(cboValor.Text) = UCase$(LoadResString(146)) Then
vgSegOperando$ = "Date()"
Else
If i < 0 Then 'foi pego na combo, vamos ver o tipo
i = InStr(x$, ".") 'vamos separar o
T$ = Left$(x$, i - 1) 'nome da tabela e o
C$ = Mid$(x$, Len(T$) + 2) 'nome do campo
T$ = Retira$(T$, "[]", UM_A_UM) 'tira os colchetes da
C$ = Retira$(C$, "[]", UM_A_UM) 'tabela e campo
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
If vgTp = dbDate Then 'se for data
vgSegOperando$ = x$
Else
vgSegOperando$ = "CDate(" + x$ + ")"
End If
Else
vgSegOperando$ = "CDate('" + x$ + "')"
End If
End If
Else
vgSegOperando$ = cboValor.Text
End If
End If
vgWh$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True) 'cláusula "WHERE" existente
If Len(vgWh$) > 0 Then 'existe alguma?
If opcFiltro(1).Value Or opcAndOr(0).Value Then 'quer AND ou é união de tabelas
x$ = " AND ("
Else 'vai concatenar com OR
x$ = " OR "
If Right$(vgWh$, 1) = ")" Then 'se tem "(" tira para
vgWh$ = Left$(vgWh$, Len(vgWh$) - 1) 'concatenar expressão
Else 'se não tem "("
x$ = x$ + "(" 'vamos colocar um
End If
End If
Else 'não de "WHERE" anterior
x$ = "(" 'vamos começar com "("
End If
If Trim(UCase$(cboOperador.Text)) = "LIKE" Then
vgSegOperando$ = Substitui(vgSegOperando$, "%", "*", SO_UM)
End If
vgWh$ = vgWh$ + x$ + cboCampos.Text + " " + _
cboOperador.Text + " " + vgSegOperando$ + ")" 'agora sim, concatena...
cboCampos.ListIndex = -1 'limpa filtro/união para
cboValor.Text = "" 'um proximo...
InsereClausula EXP_WHERE, vgWh$ 'coloca dentro da exp SQL
AtualizaListaFiltro cboCampos, cboValor 'enche novamente as listas
AtualizaListaFiltro cboValor, cboCampos 'com a nova situação
End Sub Private Sub botGrava_Click()
If SalvaQuery(NAO_CONFIRMA_GRAVACAO) Then 'se gravou query
'frmSeleQueries.EncheLista cboNomeQuery 'vamos coloca-la na lst
vgNaoEClick = True 'de consulta existentes
cboNomeQuery.Text = vgNovaQuery$ 'e reseleciona-la
vgNaoEClick = False
End If
End Sub Private Sub botLimpa_Click()
Dim i As Integer 'começaremos de novo
If SalvaQuery(CONFIRMA_GRAVACAO) Then 'salvar (se quiser) consulta existente
ResetaQuery
cboNomeQuery.SetFocus 'coloca cursor no nome da query
End If
End Sub Private Sub botTiraFiltro_Click()
Beep 'quer retirar filtro (WHERE)
If MsgBox("Tirar cláusula WHERE?", vbYesNo + vbQuestion, vgAtencao$) = vbYes Then
InsereClausula EXP_WHERE, "" 'sim, substitui por nada
End If
End Sub Private Sub cboNomeQuery_Change()
If vgNaoEClick = False And vgNomeSQL$ <> cboNomeQuery.Text Then 'se o usuário que esta modificado o nome
AtualizaBotGravacao True 'da consultam então hab/desabilita
End If 'botões se necessário
vgNomeSQL$ = cboNomeQuery.Text 'nome atual da query
End Sub Private Sub cboValor_Change()
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub Private Sub cboValor_Click()
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub Private Sub Form_Load() Main
Screen.MousePointer = vbHourglass
vgCaracteristica = F_COMUM
vgFormID = 7 'identificacao do form
vgExpSQL$ = ""
vgNomeSQL$ = ""
vgNaoEClick = False
EncheNomesTabs AtualizaBotGravacao False ' labNomeQuery.Caption = LoadResString(4000)
' labCampoGrupo.Caption = LoadResString(4010)
' labTabelas.Caption = LoadResString(4020)
' labCamposMostrar.Caption = LoadResString(4030)
' fraOrdenacao.Caption = LoadResString(4040)
' opcOrdem(0).Caption = LoadResString(4050)
' opcOrdem(1).Caption = LoadResString(4060)
' fraTop.Caption = LoadResString(4070)
' OpcTop(0).Caption = LoadResString(4080)
' OpcTop(1).Caption = LoadResString(4090)
' fraFiltragem.Caption = LoadResString(4100)
' opcFiltro(0).Caption = LoadResString(4110)
' opcFiltro(1).Caption = LoadResString(4120)
' opcAndOr(0).Caption = LoadResString(4130)
' opcAndOr(1).Caption = LoadResString(4140)
' botConcatena.Caption = LoadResString(4150)
' chkPermitirATodos.Caption = LoadResString(4275)
' labNomeCampo.Caption = LoadResString(4160)
' labOperador.Caption = LoadResString(4170)
' labValor.Caption = LoadResString(4180)
' labCriterio.Caption = LoadResString(4190)
'Set botGrava.Picture = LoadResPicture(245, vbResIcon)
'Set botGrava.PictureDisabled = LoadResPicture(250, vbResIcon)
'Set botRetorna.Picture = LoadResPicture(255, vbResIcon)
'Set botLimpa.Picture = LoadResPicture(260, vbResIcon)
'Set botTiraFiltro.Picture = LoadResPicture(263, vbResIcon)
' botTiraFiltro.Tag = LoadResString(4490)
' botConcatena.Tag = LoadResString(4200)
' botRetorna.Tag = LoadResString(4210)
' botGrava.Tag = LoadResString(4220)
' botLimpa.Tag = LoadResString(4230)
' fraAndOr.Tag = LoadResString(4240)
' fraFiltragem.Tag = LoadResString(4250)
' fraOrdenacao.Tag = LoadResString(4260)
' fraTop.Tag = LoadResString(4270)
' lstCamposMostrar.Tag = LoadResString(4330)
' lstTabelas.Tag = LoadResString(4340)
' opcFiltro(0).Tag = LoadResString(4350)
' opcFiltro(1).Tag = LoadResString(4355)
' opcOrdem(0).Tag = LoadResString(4360)
' opcOrdem(1).Tag = LoadResString(4365)
' OpcTop(0).Tag = LoadResString(4370)
' OpcTop(1).Tag = LoadResString(4375)
' txtCriterio.Tag = LoadResString(4380)
' txtTop.Tag = LoadResString(4390)
EncheOperadores cboOperador, True
'frmSeleQueries.EncheLista cboNomeQuery
cboOperador.Text = "="
CentraNaTela Me
Screen.MousePointer = vbDefault
End Sub 'enche lista com nomes das tabelas
Private Sub EncheNomesTabs()
Dim i As Integer lstTabelas.Clear
'enche lista de tabelas
For i = 0 To vgdb.TableDefs.Count - 1
If (vgdb.TableDefs(i).Attributes And dbSystemObject) = 0 Then
If InStr(vgdb.TableDefs(i).Name, "~") = 0 Then 'tira tabelas de segurança e invisíveis
lstTabelas.AddItem vgdb.TableDefs(i).Name
End If
End If
Next
End Sub Private Sub lstTabelas_Click()
Dim vgCp As Field, i As Integer, vgSe As String, vgNt As String, _
x As String lstCamposMostrar.Clear
If lstTabelas.ListIndex >= 0 Then
vgNt$ = PoeColchetes$(lstTabelas.Text) + "."
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True)
vgNaoEClick = True
For Each vgCp In vgdb.TableDefs(lstTabelas.Text).Fields
If InStr(vgCp.Name, "~") = 0 And Left$(vgCp.ValidationText, 1) <> "I" Then
lstCamposMostrar.AddItem vgCp.Name
If PosiDoNome(vgSe$ + ",", vgNt$ + PoeColchetes$(vgCp.Name) + ",") > 0 Then
lstCamposMostrar.Selected(lstCamposMostrar.ListCount - 1) = True 'selecione este...
End If
End If
Next
vgNaoEClick = False
End If
End Sub
'acha posição de um nome dentro de uma string
Private Function PosiDoNome(ByVal Alvo As String, ByVal Pesq As String) As Integer
Dim i As Integer, vgAscDir As Integer, vgAscEsq As Integer
Alvo$ = " " + UCase$(Alvo$) + " " 'string alvo
Pesq$ = UCase$(Pesq$) 'campo a pesquisar
i = 0 'posição do nome na string
DeNovo:
i = InStr(i + 1, Alvo$, Pesq$) 'o nome esta dentro da string?
If i > 0 Then 'se afirnativo
vgAscDir = Asc(Mid$(Alvo$, i + Len(Pesq$))) 'testa o char mais a direita
vgAscEsq = Asc(Mid$(Alvo$, i - 1)) 'e o mais a esquerda do nome
If (vgAscDir > 46 And vgAscDir < 58) Or _
(vgAscDir > 64 And vgAscDir < 113) Then 'para ter a certeza de
GoTo DeNovo 'que o nome não é um
End If 'subconjunto de outro nome
If (vgAscEsq > 46 And vgAscEsq < 58) Or _
(vgAscEsq > 64 And vgAscEsq < 113) Then 'se o nome não é válido
GoTo DeNovo 'continua pesquisando
End If 'na sting
i = i - 1
End If 'posição onde achou o nome
PosiDoNome = i
End Function
Private Sub lstCamposMostrar_Click()
Dim T As String, vgCp As String, vgNomeCp As String, i As Integer, j As Integer
Dim vgSe As String, vgFr As String, vgGrupo As String, x As String, vgWhere As String
If vgNaoEClick Then Exit Sub
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True)
vgFr$ = ExtraiSQL$(vgExpSQL$, EXP_FROM, True)
vgGrupo$ = ExtraiSQL$(vgExpSQL$, EXP_GROUPBY, True)
T$ = PoeColchetes$(lstTabelas.Text)
vgCp$ = T$ + "." + PoeColchetes$(lstCamposMostrar.Text)
vgNomeCp$ = vgCp$
If Len(vgGrupo$) > 0 Then
i = vgdb.TableDefs(T$).Fields(lstCamposMostrar.Text).Type
j = (i >= dbByte And i <= dbDouble) 'so cp numérico tem SUM
If j Then
vgCp$ = "Sum(" + vgCp$ + ") As " + PoeColchetes$(lstCamposMostrar.Text)
End If
End If
If lstCamposMostrar.Selected(lstCamposMostrar.ListIndex) Then 'estava NAO SELECIONADO
If PosiDoNome(vgSe$ + ",", vgCp$ + ",") = 0 Then 'atualiza SQL se o campo não constar nela
If Len(vgSe$) > 0 Then vgSe$ = vgSe$ + ", "
InsereClausula EXP_SELECT, vgSe$ + vgCp$
End If
If PosiDoNome(vgFr$ + ",", T$ + ",") = 0 Then
If Len(vgFr$) > 0 Then vgFr$ = vgFr$ + ", "
InsereClausula EXP_FROM, vgFr$ + T$
End If
Else 'estava SELECIONADO
i = PosiDoNome(vgSe$ + ",", vgCp$ + ",")
If i Then
vgSe$ = Trim$(Left$(vgSe$, i - 1) + Mid$(vgSe$, i + Len(vgCp$) + 1))
If Right$(vgSe$, 1) = "," Then vgSe$ = Left$(vgSe$, Len(vgSe$) - 1)
InsereClausula EXP_SELECT, vgSe$
End If
If PosiDoNome(vgSe$, T$) = 0 Then TiraNomeDaClausula EXP_FROM, T$
TiraNomeDaClausula EXP_ORDERBY, vgNomeCp$
TiraNomeDaClausula EXP_GROUPBY, vgNomeCp$
vgWhere$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True)
If PosiDoNome(vgWhere$, vgCp$) > 0 Then 'se o campo faz parte do filtro
InsereClausula EXP_WHERE, "" 'remove todo o filtro
End If
End If
txtCriterio.Text = vgExpSQL$
End Sub
'insere cláusula especificada dentro da exrpessão SQL
Private Sub InsereClausula(vgQual As Integer, ByVal vgOQueInserir As String)
Dim vgEx As String, j As Integer, i As Integer, vgTp As Integer, _
k As String, x As String, vgCp As Field, C As String, vgCt As Control
vgEx$ = "" 'conterá toda a exp SQL
vgOQueInserir$ = Trim$(vgOQueInserir$) 'cláusula a inserir
For i = 0 To EXP_TODAS - 1 'corre todas as cláusulas
If i = vgQual Then 'se for a que quer inserir
x$ = vgOQueInserir$ 'substitui pela informada
Else 'caso contrário
x$ = ExtraiSQL$(vgExpSQL$, i, True) 'tira cláusula da própia exp SQL
End If
If Len(x$) Then 'se a cláusula existe
If i = EXP_SELECT And Val(txtTop.Text) > 0 Then 'se for a "SELECT" e tem "TOP"
x$ = "TOP " + LTrim$(txtTop.Text) + _
Left$(" PERCENT", 8 * -(OpcTop(1) = True)) + _
" " + x$ 'coloca na cláusula (incluido o "PERCENT")
End If
vgEx$ = vgEx$ + LTrim$(vgClausula$(i)) + x$ + vbCrLf 'e segue montando a nova exp SQL
End If
Next
vgExpSQL$ = Trim$(vgEx$) 'esta é a nova exp SQL
txtCriterio.Text = vgExpSQL$ 'mostra ao usuário 'se a cláusula modificada/inclusa foi a "FROM" ou remontou toda
'a expressão SQL vamos aproveitar e reatualizar todos os controles
'que depende destes arquivos selecionados
If (vgQual = EXP_FROM Or vgQual = EXP_TODAS) And _
(vgOQueInserir$ <> vgFromAnterior$ Or Len(vgOQueInserir$) = 0) Then
If vgQual = EXP_TODAS Then 'se pediu para remontar toda a SQL
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_FROM, True) 'extrai a cláusula "FROM"
End If
cboCampos.Clear 'limpa combos de campos
cboValor.Clear 'valores (filtragem)
cboCampoOrdem.Clear 'e ordem
vgFromAnterior$ = vgOQueInserir$ 'salva cláusula "FROM"
While Len(vgOQueInserir$) > 0 'vamos pegar todos os arquivo da "FROM"
x$ = Trim$(Parse$(vgOQueInserir$, ",")) 'nome do arquivo
For Each vgCp In vgdb(Retira$(x$, "[]", UM_A_UM)).Fields 'pega todos os campos do arqivo
C$ = x$ + "." + PoeColchetes$(vgCp.Name) 'prepara para inserir nas conbos...
If Left$(vgCp.ValidationText, 1) <> "I" And InStr(vgCp.Name, "~") = 0 And _
vgCp.Type <> dbLongBinary Then 'campo invisível não pode... 'se já tem um campo no primeiro operando (filtragem) vamos encher
'o segundo operador com todos os outros campos menos com os campos
'da tabela do primeiro operando (união entre tabelas)
If Len(cboValor.Text) = 0 Or _
x$ <> Left$(cboValor.Text, InStr(cboValor.Text + ".", ".") - 1) Then
cboCampos.AddItem C$
End If 'idem para encher a combo do primeiro operando...
If Len(cboCampos.Text) = 0 Or _
x$ <> Left$(cboCampos.Text, InStr(cboCampos.Text + ".", ".") - 1) Then
cboValor.AddItem C$
End If
If vgCp.Type <> dbMemo Then
cboCampoOrdem.AddItem C$ 'todos os campos valem na ordenação
End If
End If
Next
Wend
i = (InStr(vgFromAnterior$, ",") > 0) 'tem mais de uma tabela na cláusual "FROM"
opcFiltro(1).Enabled = i 'só pode unir tabela se mais de 1
If opcFiltro(1).Enabled = False And _
opcFiltro(1).Value = True Then 'se não pode unir tabelas mas este
opcFiltro(0).Value = True 'está marcado, desmarca
End If
End If 'se a cláusula modificada/inclusa foi a "WHERE" ou remontou toda
'a expressão SQL verificar se agora ja podemos deixa o usuário
'concatenar com AND e OR
If vgQual = EXP_WHERE Or vgQual = EXP_TODAS Then
If vgQual = EXP_TODAS Then 'retira exp "WHERE" se
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True) 'remontou toda s SQL
End If
i = Len(vgOQueInserir$) > 0 'pode concatenar?
If fraAndOr.Visible <> i And opcFiltro(0).Value Then 'se pode e não esta
fraAndOr.Visible = i 'unindo tabela...
End If
If botTiraFiltro.Visible <> i Then 'habilita/desabilita
botTiraFiltro.Visible = i 'botão para limpar
End If 'exp "WHERE"
End If 'se a cláusula modificada/inclusa foi a "SELECT" ou remontou toda
'a expressão SQL vamos aproveitar e habilitar/desabilitar todos os
'controles que depende do numero de campos seleciondos
If vgQual = EXP_SELECT Or vgQual = EXP_TODAS Then
If vgQual = EXP_TODAS Then 'se remontou tudo
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True) 'extrai "SELECT"
End If
i = Len(vgOQueInserir$) > 0 'habilitado ou não?
If fraFiltragem.Enabled <> i Then 'se esta diferente do anterior
cboCampoGrupo.Enabled = i 'vamos habiliar ou
cboCampoOrdem.Enabled = i 'desabilitar todos
cboCampos.Enabled = i 'os controles que
cboOperador.Enabled = i 'não pode ser
cboValor.Enabled = i 'utilizados enquanto
fraAndOr.Enabled = i 'não existir pelo
fraFiltragem.Enabled = i 'menos um campo
fraOrdenacao.Enabled = i 'selecionado
fraTop.Enabled = i
' labCampoGrupo.Enabled = i
' labCriterio.Enabled = i
' labNomeCampo.Enabled = i
' labOperador.Enabled = i
' labValor.Enabled = i
txtCriterio.Enabled = i
txtTop.Enabled = i
For j = 0 To 1
opcAndOr(j).Enabled = i
opcFiltro(j).Enabled = i
opcOrdem(j).Enabled = i
Next
End If
cboCampoGrupo.Clear 'agrupar registros...
While Len(vgOQueInserir$) > 0 'somente os campos da exp SQL
C$ = Trim$(Parse$(vgOQueInserir$, ",")) 'podem ser usados
i = InStr(UCase$(C$), "SUM(") 'se o campo tem o prefixo "SUM"
If i Then 'vamos remove-lo
j = Rat(C$, ")") 'antes de colocarmos na lista
If j > i Then
C$ = Trim$(Mid$(C$, i + 4, j - i - 4))
End If
End If
cboCampoGrupo.AddItem C$ 'lista de campos (grupos)
Wend
End If
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub
Private Sub TiraNomeDaClausula(ByVal vgQual As Integer, vgNome As String)
Dim i As Integer, j As Integer, vgEx As String
vgEx$ = ExtraiSQL$(vgExpSQL$, vgQual, True)
TiraOutro:
i = PosiDoNome(vgEx$ + ",", vgNome$ + ",")
If i > 0 And Len(vgEx$) > 0 And Len(vgNome$) > 0 Then
j = InStr(i, vgEx$ + ",", ",")
vgEx$ = Trim$(Left$(vgEx$, i - 1) + Mid$(vgEx$, j + 1))
If Right$(vgEx$, 1) = "," Then vgEx$ = Left$(vgEx$, Len(vgEx$) - 1)
InsereClausula vgQual, vgEx$
If vgQual = EXP_GROUPBY Then AjustaGroupBy vgEx$
GoTo TiraOutro
End If
End Sub 'limpa e reseta a consulta em montagem
Private Sub ResetaQuery()
vgExpSQL$ = "" 'limpa exp SQL existente
cboNomeQuery.Text = "" 'nome da consulta
vgNaoEClick = True 'evitaremos recursividade
InsereClausula EXP_TODAS, "" 'prepara todos os controles
vgNaoEClick = False
lstTabelas.ListIndex = -1 'deseleciona tabela
AtualizaBotGravacao False 'troca figuras/hab/desabilita botÔes
End Sub 'coloca cláusula "GROUP BY" e prefixo "SUM" nos campos do "SELECT"
Private Sub AjustaGroupBy(vgGrupo As String)
Dim x As String, vgSe As String, T As String, vgCp As String, vgENum As Integer, _
vgTp As Integer, vgNumTit As Integer
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True) 'campos selecionados
x$ = ""
While Len(vgSe$) > 0 'vamos tirar o SUM
vgCp$ = Trim$(Parse$(vgSe$, ",")) 'dos campos selecionados
If UCase$(Left$(vgCp$, 4)) = "SUM(" Then 'caso exista
vgCp$ = Mid$(vgCp$, 5, Rat(vgCp$, ")") - 5)
End If
If Len(x$) > 0 Then x$ = x$ + ", " 'x sera a relação de cps
x$ = x$ + vgCp$ 'selecionados
Wend
If Len(vgGrupo$) > 0 Then 'existe GROUP BY
vgSe$ = x$ 'campos do SELEC sem SUM
x$ = ""
vgNumTit = 0
On Error Resume Next 'prepara para um erro
While Len(vgSe$) > 0 'corre todos os campos
vgCp$ = Trim$(Parse$(vgSe$, ",")) 'do SELECT e coloca
If PosiDoNome(vgGrupo$ + ",", vgCp$ + ",") = 0 Then 'o SUM se necessário
T$ = Parse$(vgCp$, ".")
vgTp = vgdb.TableDefs(T$).Fields(vgCp$).Type 'tipo do campo
If Err = 0 Then 'Beleza! conseguimos pegar o tipo
vgENum = (vgTp >= dbByte And vgTp <= dbDouble) 'so cp numérico tem SUM
If vgENum Then 'esse é..
vgCp$ = "Sum(" + T$ + "." + vgCp$ + ") As " + vgCp$ 'título da coluna = título do campo
Else 'não é numérico
vgCp$ = T$ + "." + vgCp$ 'vai do jeito que foi selecionado
End If
Else 'este campo não esta em nenhuma tabela
vgNumTit = vgNumTit + 1 'assumi numério e inventa um título
vgCp$ = "Sum(" + T$ + "." + vgCp$ + LoadResString(4480) + Str$(vgNumTit) + "]"
End If
End If
If Len(x$) > 0 Then x$ = x$ + ", " 'coloca "," se precisar
x$ = x$ + vgCp$ 'segue montando a nova "SELECT"
Wend
End If
InsereClausula EXP_SELECT, x$ 'troca a SELECT da exp SQL
End Sub 'escolheu um campo para sumarizar
Private Sub cboCampoGrupo_Click()
Dim vgGrupo As String, i As Integer, vgItemAtual As Integer
If vgNaoEClick = False Then 'o usuário que clicou?
vgItemAtual = cboCampoGrupo.ListIndex 'cp escolhido
vgGrupo$ = ExtraiSQL$(vgExpSQL$, EXP_GROUPBY, True) 'GROUP BY atual
i = PosiDoNome(vgGrupo$ + ",", cboCampoGrupo.Text + ",") 'cp já existe no exp
If i > 0 Then 'se sim,
TiraNomeDaClausula EXP_GROUPBY, cboCampoGrupo.Text 'vamos retirá-lo
Else 'aninda não,
If Len(vgGrupo$) > 0 Then vgGrupo$ = vgGrupo$ + ", " 'vamos concatena-lo
vgGrupo$ = vgGrupo$ + cboCampoGrupo.Text 'a exp já existente
InsereClausula EXP_GROUPBY, vgGrupo$ 'troca cláusula na exp SQL
AjustaGroupBy vgGrupo$ 'ajustes cps (SUM)
End If
vgNaoEClick = True 'evita recursividade
cboCampoGrupo.ListIndex = vgItemAtual 'releciona cp escolhido
vgNaoEClick = False
End If
End Sub 'ordem do consulta
Private Sub cboCampoOrdem_Click()
Dim vgOrdem As String, x As String, i As Integer, j As Integer
vgOrdem$ = ExtraiSQL$(vgExpSQL$, EXP_ORDERBY, True) 'expressão de ordenacao (ORDER)
i = PosiDoNome(vgOrdem$ + ",", cboCampoOrdem.Text + ",") 'cp ja está na ordenação
If i > 0 Then 'sim,
TiraNomeDaClausula EXP_ORDERBY, cboCampoOrdem.Text 'então retira
Else 'não,
If Len(vgOrdem$) > 0 Then vgOrdem$ = vgOrdem$ + ", " 'então vamos
vgOrdem$ = vgOrdem$ + cboCampoOrdem.Text 'coloca-lo
If opcOrdem(1).Value Then 'é descendente
vgOrdem$ = vgOrdem$ + " DESC" 'concatena sufixo
End If
InsereClausula EXP_ORDERBY, vgOrdem$ 'troca ordenação na exp SQL
End If
End Sub Private Sub cboCampos_Click()
Dim T As String, C As String, m As String, vgTp As Integer 'dimensiona
If vgNaoEClick = False Then 'evita recursividade
AtualizaListaFiltro cboValor, cboCampos 'atualiza lista de filtros
C$ = Retira$(cboCampos.Text, "[]", UM_A_UM) 'tira os colchetes
vgTp = InStr(C$, ".") 'procura um ponto
If vgTp > 0 Then 'se tem o ponto (sempre!)
T$ = Left$(C$, vgTp - 1) 'nome da tabela
C$ = Mid$(C$, vgTp + 1) 'nome do campo
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
End If
EncheOperadores cboOperador, (vgTp = dbText Or vgTp = dbMemo) 'enche lista de operadores
End If
End Sub 'enche lst com os campos apropriados
Private Sub AtualizaListaFiltro(vgCt1 As Control, vgCt2 As Control)
Dim i As Integer, T As String, vgTextoAnt As String, vgIndexAnt As Integer, _
Cp As String, vgTp As Integer T$ = Left$(vgCt2.Text, InStr(vgCt2.Text + ".", ".") - 1) 'tabela escolhida
vgTp = -1 'tipo do campo
If vgCt2.ListIndex >= 0 And Len(T$) > 0 Then 'se tem campo selecionado
Cp$ = Retira$(vgCt2.Text, "[]", UM_A_UM) 'vamos retirar todos []
If InStr(Cp$, ".") Then 'se tem nome tab antes do cp
Cp$ = Mid$(Cp$, InStr(Cp$, ".") + 1) 'separa do campo
End If
vgTp = vgdb.TableDefs(Retira$(T$, "[]", UM_A_UM)).Fields(Cp$).Type 'tipo do campo
End If
vgTextoAnt = vgCt1.Text 'texto digitado anteriormente
vgIndexAnt = -1
vgCt1.Clear 'limpa lst
If opcFiltro(0).Value Then
If vgTp = dbDate Then 'se for data
vgCt1.AddItem LoadResString(145) 'em branca
vgCt1.AddItem LoadResString(146) 'data do sistema
ElseIf vgTp = dbText Or vgTp = dbMemo Then 'se for tipo texto
vgCt1.AddItem "" 'em branca
End If
End If
With cboCampoOrdem 'vamos encher
For i = 0 To .ListCount - 1 'com todos os cps
If T$ <> Left$(.List(i), InStr(.List(i), ".") - 1) Or _
opcFiltro(0).Value Then 'possíveis menos os cps
vgCt1.AddItem .List(i) 'da tab já selecionada
End If
Next
End With
For i = 0 To vgCt1.ListCount - 1 'vamos ver qual o campo
If vgCt1.List(i) = vgTextoAnt Then 'estava selecionado
vgIndexAnt = i
Exit For 'achou... cai fora
End If
Next
vgNaoEClick = True 'evita recursividade
vgCt1.ListIndex = vgIndexAnt 'reseleciona cps esclohido
vgNaoEClick = False
End Sub
Private Sub opcFiltro_Click(Index As Integer)
cboOperador.Enabled = (Index = 0)
'labOperador.Enabled = (Index = 0)
|
|
|
|
Martini
|
PAROBÉ
RS - BRASIL
|
|
ENUNCIADA !
|
|
|
Postada em 17/02/2006 10:58 hs
esse é código de um projetinho que eu fiz para mostar sql: form: Const CONFIRMA_GRAVACAO = 0 'constantes para testar confirmação do usuário
Const NAO_CONFIRMA_GRAVACAO = 1 Public vgSituacao As Integer, vgCaracteristica As Integer, _
vgTipo As Integer, vgFormID As Long 'propriedades que todos os forms têm... Dim vgExpSQL As String, vgFromAnterior As String 'dimensiona
Dim vgNaoEClick As Integer, vgModifQuery As Integer 'o que precisamos
Dim vgNomeSQL As String ' muda status do botão de gravação
Sub AtualizaBotGravacao(vgStatus As Integer)
vgModifQuery = vgStatus 'liga flag
botGrava.Enabled = vgStatus 'muda status do botão, de acordo
End Sub Private Sub botConcatena_Click()
Dim vgWh As String, x As String, vgSegOperando As String, vgTp As Integer, _
C As String, T As String, i As Integer, EmB As Integer
If opcFiltro(1).Value Then 'se for união de tabelas
vgSegOperando$ = cboValor.Text 'pega campo da 2a. tabela
Else 'se quer filtrar
i = InStr(cboCampos.Text, ".") 'vamos separar o
T$ = Left$(cboCampos.Text, i - 1) 'nome da tabela e o
C$ = Mid$(cboCampos.Text, Len(T$) + 2) 'nome do campo
T$ = Retira$(T$, "[]", UM_A_UM) 'tira os colchetes da
C$ = Retira$(C$, "[]", UM_A_UM) 'tabela e campo
EmB = (UCase$(cboValor.Text) = UCase$("")) 'vamos ver se foi capturado da combo - se sim, é campo
x$ = cboValor.Text
For i = 0 To cboValor.ListCount - 1
If cboValor.List(i) = x$ Then 'foi capturado da combo, é campo
i = -2
Exit For
End If
Next
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
If vgTp = dbBoolean Then 'qual o tipo do
vgSegOperando$ = Str$(Val(cboValor.Text) <> 0) 'campo para montar
ElseIf vgTp = dbText Or vgTp = dbMemo Then 'se for tipo texto
If cboValor.Text = "" Or EmB Then
vgSegOperando$ = "''"
Else
If i < 0 Then 'é campo da lista
vgSegOperando$ = cboValor.Text
Else
vgSegOperando$ = Chr$(39) + cboValor.Text + Chr$(39) 'expressão, poe plics
End If
End If
ElseIf vgTp = dbDate Then 'se for data
If cboValor.Text = "" Or EmB Then
vgSegOperando$ = "Null"
ElseIf UCase$(cboValor.Text) = "DATE" Or UCase$(cboValor.Text) = "DATE()" Or UCase$(cboValor.Text) = UCase$(LoadResString(146)) Then
vgSegOperando$ = "Date()"
Else
If i < 0 Then 'foi pego na combo, vamos ver o tipo
i = InStr(x$, ".") 'vamos separar o
T$ = Left$(x$, i - 1) 'nome da tabela e o
C$ = Mid$(x$, Len(T$) + 2) 'nome do campo
T$ = Retira$(T$, "[]", UM_A_UM) 'tira os colchetes da
C$ = Retira$(C$, "[]", UM_A_UM) 'tabela e campo
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
If vgTp = dbDate Then 'se for data
vgSegOperando$ = x$
Else
vgSegOperando$ = "CDate(" + x$ + ")"
End If
Else
vgSegOperando$ = "CDate('" + x$ + "')"
End If
End If
Else
vgSegOperando$ = cboValor.Text
End If
End If
vgWh$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True) 'cláusula "WHERE" existente
If Len(vgWh$) > 0 Then 'existe alguma?
If opcFiltro(1).Value Or opcAndOr(0).Value Then 'quer AND ou é união de tabelas
x$ = " AND ("
Else 'vai concatenar com OR
x$ = " OR "
If Right$(vgWh$, 1) = ")" Then 'se tem "(" tira para
vgWh$ = Left$(vgWh$, Len(vgWh$) - 1) 'concatenar expressão
Else 'se não tem "("
x$ = x$ + "(" 'vamos colocar um
End If
End If
Else 'não de "WHERE" anterior
x$ = "(" 'vamos começar com "("
End If
If Trim(UCase$(cboOperador.Text)) = "LIKE" Then
vgSegOperando$ = Substitui(vgSegOperando$, "%", "*", SO_UM)
End If
vgWh$ = vgWh$ + x$ + cboCampos.Text + " " + _
cboOperador.Text + " " + vgSegOperando$ + ")" 'agora sim, concatena...
cboCampos.ListIndex = -1 'limpa filtro/união para
cboValor.Text = "" 'um proximo...
InsereClausula EXP_WHERE, vgWh$ 'coloca dentro da exp SQL
AtualizaListaFiltro cboCampos, cboValor 'enche novamente as listas
AtualizaListaFiltro cboValor, cboCampos 'com a nova situação
End Sub Private Sub botGrava_Click()
If SalvaQuery(NAO_CONFIRMA_GRAVACAO) Then 'se gravou query
'frmSeleQueries.EncheLista cboNomeQuery 'vamos coloca-la na lst
vgNaoEClick = True 'de consulta existentes
cboNomeQuery.Text = vgNovaQuery$ 'e reseleciona-la
vgNaoEClick = False
End If
End Sub Private Sub botLimpa_Click()
Dim i As Integer 'começaremos de novo
If SalvaQuery(CONFIRMA_GRAVACAO) Then 'salvar (se quiser) consulta existente
ResetaQuery
cboNomeQuery.SetFocus 'coloca cursor no nome da query
End If
End Sub Private Sub botTiraFiltro_Click()
Beep 'quer retirar filtro (WHERE)
If MsgBox("Tirar cláusula WHERE?", vbYesNo + vbQuestion, vgAtencao$) = vbYes Then
InsereClausula EXP_WHERE, "" 'sim, substitui por nada
End If
End Sub Private Sub cboNomeQuery_Change()
If vgNaoEClick = False And vgNomeSQL$ <> cboNomeQuery.Text Then 'se o usuário que esta modificado o nome
AtualizaBotGravacao True 'da consultam então hab/desabilita
End If 'botões se necessário
vgNomeSQL$ = cboNomeQuery.Text 'nome atual da query
End Sub Private Sub cboValor_Change()
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub Private Sub cboValor_Click()
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub Private Sub Form_Load() Main
Screen.MousePointer = vbHourglass
vgCaracteristica = F_COMUM
vgFormID = 7 'identificacao do form
vgExpSQL$ = ""
vgNomeSQL$ = ""
vgNaoEClick = False
EncheNomesTabs AtualizaBotGravacao False ' labNomeQuery.Caption = LoadResString(4000)
' labCampoGrupo.Caption = LoadResString(4010)
' labTabelas.Caption = LoadResString(4020)
' labCamposMostrar.Caption = LoadResString(4030)
' fraOrdenacao.Caption = LoadResString(4040)
' opcOrdem(0).Caption = LoadResString(4050)
' opcOrdem(1).Caption = LoadResString(4060)
' fraTop.Caption = LoadResString(4070)
' OpcTop(0).Caption = LoadResString(4080)
' OpcTop(1).Caption = LoadResString(4090)
' fraFiltragem.Caption = LoadResString(4100)
' opcFiltro(0).Caption = LoadResString(4110)
' opcFiltro(1).Caption = LoadResString(4120)
' opcAndOr(0).Caption = LoadResString(4130)
' opcAndOr(1).Caption = LoadResString(4140)
' botConcatena.Caption = LoadResString(4150)
' chkPermitirATodos.Caption = LoadResString(4275)
' labNomeCampo.Caption = LoadResString(4160)
' labOperador.Caption = LoadResString(4170)
' labValor.Caption = LoadResString(4180)
' labCriterio.Caption = LoadResString(4190)
'Set botGrava.Picture = LoadResPicture(245, vbResIcon)
'Set botGrava.PictureDisabled = LoadResPicture(250, vbResIcon)
'Set botRetorna.Picture = LoadResPicture(255, vbResIcon)
'Set botLimpa.Picture = LoadResPicture(260, vbResIcon)
'Set botTiraFiltro.Picture = LoadResPicture(263, vbResIcon)
' botTiraFiltro.Tag = LoadResString(4490)
' botConcatena.Tag = LoadResString(4200)
' botRetorna.Tag = LoadResString(4210)
' botGrava.Tag = LoadResString(4220)
' botLimpa.Tag = LoadResString(4230)
' fraAndOr.Tag = LoadResString(4240)
' fraFiltragem.Tag = LoadResString(4250)
' fraOrdenacao.Tag = LoadResString(4260)
' fraTop.Tag = LoadResString(4270)
' lstCamposMostrar.Tag = LoadResString(4330)
' lstTabelas.Tag = LoadResString(4340)
' opcFiltro(0).Tag = LoadResString(4350)
' opcFiltro(1).Tag = LoadResString(4355)
' opcOrdem(0).Tag = LoadResString(4360)
' opcOrdem(1).Tag = LoadResString(4365)
' OpcTop(0).Tag = LoadResString(4370)
' OpcTop(1).Tag = LoadResString(4375)
' txtCriterio.Tag = LoadResString(4380)
' txtTop.Tag = LoadResString(4390)
EncheOperadores cboOperador, True
'frmSeleQueries.EncheLista cboNomeQuery
cboOperador.Text = "="
CentraNaTela Me
Screen.MousePointer = vbDefault
End Sub 'enche lista com nomes das tabelas
Private Sub EncheNomesTabs()
Dim i As Integer lstTabelas.Clear
'enche lista de tabelas
For i = 0 To vgdb.TableDefs.Count - 1
If (vgdb.TableDefs(i).Attributes And dbSystemObject) = 0 Then
If InStr(vgdb.TableDefs(i).Name, "~") = 0 Then 'tira tabelas de segurança e invisíveis
lstTabelas.AddItem vgdb.TableDefs(i).Name
End If
End If
Next
End Sub Private Sub lstTabelas_Click()
Dim vgCp As Field, i As Integer, vgSe As String, vgNt As String, _
x As String lstCamposMostrar.Clear
If lstTabelas.ListIndex >= 0 Then
vgNt$ = PoeColchetes$(lstTabelas.Text) + "."
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True)
vgNaoEClick = True
For Each vgCp In vgdb.TableDefs(lstTabelas.Text).Fields
If InStr(vgCp.Name, "~") = 0 And Left$(vgCp.ValidationText, 1) <> "I" Then
lstCamposMostrar.AddItem vgCp.Name
If PosiDoNome(vgSe$ + ",", vgNt$ + PoeColchetes$(vgCp.Name) + ",") > 0 Then
lstCamposMostrar.Selected(lstCamposMostrar.ListCount - 1) = True 'selecione este...
End If
End If
Next
vgNaoEClick = False
End If
End Sub
'acha posição de um nome dentro de uma string
Private Function PosiDoNome(ByVal Alvo As String, ByVal Pesq As String) As Integer
Dim i As Integer, vgAscDir As Integer, vgAscEsq As Integer
Alvo$ = " " + UCase$(Alvo$) + " " 'string alvo
Pesq$ = UCase$(Pesq$) 'campo a pesquisar
i = 0 'posição do nome na string
DeNovo:
i = InStr(i + 1, Alvo$, Pesq$) 'o nome esta dentro da string?
If i > 0 Then 'se afirnativo
vgAscDir = Asc(Mid$(Alvo$, i + Len(Pesq$))) 'testa o char mais a direita
vgAscEsq = Asc(Mid$(Alvo$, i - 1)) 'e o mais a esquerda do nome
If (vgAscDir > 46 And vgAscDir < 58) Or _
(vgAscDir > 64 And vgAscDir < 113) Then 'para ter a certeza de
GoTo DeNovo 'que o nome não é um
End If 'subconjunto de outro nome
If (vgAscEsq > 46 And vgAscEsq < 58) Or _
(vgAscEsq > 64 And vgAscEsq < 113) Then 'se o nome não é válido
GoTo DeNovo 'continua pesquisando
End If 'na sting
i = i - 1
End If 'posição onde achou o nome
PosiDoNome = i
End Function
Private Sub lstCamposMostrar_Click()
Dim T As String, vgCp As String, vgNomeCp As String, i As Integer, j As Integer
Dim vgSe As String, vgFr As String, vgGrupo As String, x As String, vgWhere As String
If vgNaoEClick Then Exit Sub
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True)
vgFr$ = ExtraiSQL$(vgExpSQL$, EXP_FROM, True)
vgGrupo$ = ExtraiSQL$(vgExpSQL$, EXP_GROUPBY, True)
T$ = PoeColchetes$(lstTabelas.Text)
vgCp$ = T$ + "." + PoeColchetes$(lstCamposMostrar.Text)
vgNomeCp$ = vgCp$
If Len(vgGrupo$) > 0 Then
i = vgdb.TableDefs(T$).Fields(lstCamposMostrar.Text).Type
j = (i >= dbByte And i <= dbDouble) 'so cp numérico tem SUM
If j Then
vgCp$ = "Sum(" + vgCp$ + ") As " + PoeColchetes$(lstCamposMostrar.Text)
End If
End If
If lstCamposMostrar.Selected(lstCamposMostrar.ListIndex) Then 'estava NAO SELECIONADO
If PosiDoNome(vgSe$ + ",", vgCp$ + ",") = 0 Then 'atualiza SQL se o campo não constar nela
If Len(vgSe$) > 0 Then vgSe$ = vgSe$ + ", "
InsereClausula EXP_SELECT, vgSe$ + vgCp$
End If
If PosiDoNome(vgFr$ + ",", T$ + ",") = 0 Then
If Len(vgFr$) > 0 Then vgFr$ = vgFr$ + ", "
InsereClausula EXP_FROM, vgFr$ + T$
End If
Else 'estava SELECIONADO
i = PosiDoNome(vgSe$ + ",", vgCp$ + ",")
If i Then
vgSe$ = Trim$(Left$(vgSe$, i - 1) + Mid$(vgSe$, i + Len(vgCp$) + 1))
If Right$(vgSe$, 1) = "," Then vgSe$ = Left$(vgSe$, Len(vgSe$) - 1)
InsereClausula EXP_SELECT, vgSe$
End If
If PosiDoNome(vgSe$, T$) = 0 Then TiraNomeDaClausula EXP_FROM, T$
TiraNomeDaClausula EXP_ORDERBY, vgNomeCp$
TiraNomeDaClausula EXP_GROUPBY, vgNomeCp$
vgWhere$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True)
If PosiDoNome(vgWhere$, vgCp$) > 0 Then 'se o campo faz parte do filtro
InsereClausula EXP_WHERE, "" 'remove todo o filtro
End If
End If
txtCriterio.Text = vgExpSQL$
End Sub
'insere cláusula especificada dentro da exrpessão SQL
Private Sub InsereClausula(vgQual As Integer, ByVal vgOQueInserir As String)
Dim vgEx As String, j As Integer, i As Integer, vgTp As Integer, _
k As String, x As String, vgCp As Field, C As String, vgCt As Control
vgEx$ = "" 'conterá toda a exp SQL
vgOQueInserir$ = Trim$(vgOQueInserir$) 'cláusula a inserir
For i = 0 To EXP_TODAS - 1 'corre todas as cláusulas
If i = vgQual Then 'se for a que quer inserir
x$ = vgOQueInserir$ 'substitui pela informada
Else 'caso contrário
x$ = ExtraiSQL$(vgExpSQL$, i, True) 'tira cláusula da própia exp SQL
End If
If Len(x$) Then 'se a cláusula existe
If i = EXP_SELECT And Val(txtTop.Text) > 0 Then 'se for a "SELECT" e tem "TOP"
x$ = "TOP " + LTrim$(txtTop.Text) + _
Left$(" PERCENT", 8 * -(OpcTop(1) = True)) + _
" " + x$ 'coloca na cláusula (incluido o "PERCENT")
End If
vgEx$ = vgEx$ + LTrim$(vgClausula$(i)) + x$ + vbCrLf 'e segue montando a nova exp SQL
End If
Next
vgExpSQL$ = Trim$(vgEx$) 'esta é a nova exp SQL
txtCriterio.Text = vgExpSQL$ 'mostra ao usuário 'se a cláusula modificada/inclusa foi a "FROM" ou remontou toda
'a expressão SQL vamos aproveitar e reatualizar todos os controles
'que depende destes arquivos selecionados
If (vgQual = EXP_FROM Or vgQual = EXP_TODAS) And _
(vgOQueInserir$ <> vgFromAnterior$ Or Len(vgOQueInserir$) = 0) Then
If vgQual = EXP_TODAS Then 'se pediu para remontar toda a SQL
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_FROM, True) 'extrai a cláusula "FROM"
End If
cboCampos.Clear 'limpa combos de campos
cboValor.Clear 'valores (filtragem)
cboCampoOrdem.Clear 'e ordem
vgFromAnterior$ = vgOQueInserir$ 'salva cláusula "FROM"
While Len(vgOQueInserir$) > 0 'vamos pegar todos os arquivo da "FROM"
x$ = Trim$(Parse$(vgOQueInserir$, ",")) 'nome do arquivo
For Each vgCp In vgdb(Retira$(x$, "[]", UM_A_UM)).Fields 'pega todos os campos do arqivo
C$ = x$ + "." + PoeColchetes$(vgCp.Name) 'prepara para inserir nas conbos...
If Left$(vgCp.ValidationText, 1) <> "I" And InStr(vgCp.Name, "~") = 0 And _
vgCp.Type <> dbLongBinary Then 'campo invisível não pode... 'se já tem um campo no primeiro operando (filtragem) vamos encher
'o segundo operador com todos os outros campos menos com os campos
'da tabela do primeiro operando (união entre tabelas)
If Len(cboValor.Text) = 0 Or _
x$ <> Left$(cboValor.Text, InStr(cboValor.Text + ".", ".") - 1) Then
cboCampos.AddItem C$
End If 'idem para encher a combo do primeiro operando...
If Len(cboCampos.Text) = 0 Or _
x$ <> Left$(cboCampos.Text, InStr(cboCampos.Text + ".", ".") - 1) Then
cboValor.AddItem C$
End If
If vgCp.Type <> dbMemo Then
cboCampoOrdem.AddItem C$ 'todos os campos valem na ordenação
End If
End If
Next
Wend
i = (InStr(vgFromAnterior$, ",") > 0) 'tem mais de uma tabela na cláusual "FROM"
opcFiltro(1).Enabled = i 'só pode unir tabela se mais de 1
If opcFiltro(1).Enabled = False And _
opcFiltro(1).Value = True Then 'se não pode unir tabelas mas este
opcFiltro(0).Value = True 'está marcado, desmarca
End If
End If 'se a cláusula modificada/inclusa foi a "WHERE" ou remontou toda
'a expressão SQL verificar se agora ja podemos deixa o usuário
'concatenar com AND e OR
If vgQual = EXP_WHERE Or vgQual = EXP_TODAS Then
If vgQual = EXP_TODAS Then 'retira exp "WHERE" se
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True) 'remontou toda s SQL
End If
i = Len(vgOQueInserir$) > 0 'pode concatenar?
If fraAndOr.Visible <> i And opcFiltro(0).Value Then 'se pode e não esta
fraAndOr.Visible = i 'unindo tabela...
End If
If botTiraFiltro.Visible <> i Then 'habilita/desabilita
botTiraFiltro.Visible = i 'botão para limpar
End If 'exp "WHERE"
End If 'se a cláusula modificada/inclusa foi a "SELECT" ou remontou toda
'a expressão SQL vamos aproveitar e habilitar/desabilitar todos os
'controles que depende do numero de campos seleciondos
If vgQual = EXP_SELECT Or vgQual = EXP_TODAS Then
If vgQual = EXP_TODAS Then 'se remontou tudo
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True) 'extrai "SELECT"
End If
i = Len(vgOQueInserir$) > 0 'habilitado ou não?
If fraFiltragem.Enabled <> i Then 'se esta diferente do anterior
cboCampoGrupo.Enabled = i 'vamos habiliar ou
cboCampoOrdem.Enabled = i 'desabilitar todos
cboCampos.Enabled = i 'os controles que
cboOperador.Enabled = i 'não pode ser
cboValor.Enabled = i 'utilizados enquanto
fraAndOr.Enabled = i 'não existir pelo
fraFiltragem.Enabled = i 'menos um campo
fraOrdenacao.Enabled = i 'selecionado
fraTop.Enabled = i
' labCampoGrupo.Enabled = i
' labCriterio.Enabled = i
' labNomeCampo.Enabled = i
' labOperador.Enabled = i
' labValor.Enabled = i
txtCriterio.Enabled = i
txtTop.Enabled = i
For j = 0 To 1
opcAndOr(j).Enabled = i
opcFiltro(j).Enabled = i
opcOrdem(j).Enabled = i
Next
End If
cboCampoGrupo.Clear 'agrupar registros...
While Len(vgOQueInserir$) > 0 'somente os campos da exp SQL
C$ = Trim$(Parse$(vgOQueInserir$, ",")) 'podem ser usados
i = InStr(UCase$(C$), "SUM(") 'se o campo tem o prefixo "SUM"
If i Then 'vamos remove-lo
j = Rat(C$, ")") 'antes de colocarmos na lista
If j > i Then
C$ = Trim$(Mid$(C$, i + 4, j - i - 4))
End If
End If
cboCampoGrupo.AddItem C$ 'lista de campos (grupos)
Wend
End If
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub
Private Sub TiraNomeDaClausula(ByVal vgQual As Integer, vgNome As String)
Dim i As Integer, j As Integer, vgEx As String
vgEx$ = ExtraiSQL$(vgExpSQL$, vgQual, True)
TiraOutro:
i = PosiDoNome(vgEx$ + ",", vgNome$ + ",")
If i > 0 And Len(vgEx$) > 0 And Len(vgNome$) > 0 Then
j = InStr(i, vgEx$ + ",", ",")
vgEx$ = Trim$(Left$(vgEx$, i - 1) + Mid$(vgEx$, j + 1))
If Right$(vgEx$, 1) = "," Then vgEx$ = Left$(vgEx$, Len(vgEx$) - 1)
InsereClausula vgQual, vgEx$
If vgQual = EXP_GROUPBY Then AjustaGroupBy vgEx$
GoTo TiraOutro
End If
End Sub 'limpa e reseta a consulta em montagem
Private Sub ResetaQuery()
vgExpSQL$ = "" 'limpa exp SQL existente
cboNomeQuery.Text = "" 'nome da consulta
vgNaoEClick = True 'evitaremos recursividade
InsereClausula EXP_TODAS, "" 'prepara todos os controles
vgNaoEClick = False
lstTabelas.ListIndex = -1 'deseleciona tabela
AtualizaBotGravacao False 'troca figuras/hab/desabilita botÔes
End Sub 'coloca cláusula "GROUP BY" e prefixo "SUM" nos campos do "SELECT"
Private Sub AjustaGroupBy(vgGrupo As String)
Dim x As String, vgSe As String, T As String, vgCp As String, vgENum As Integer, _
vgTp As Integer, vgNumTit As Integer
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True) 'campos selecionados
x$ = ""
While Len(vgSe$) > 0 'vamos tirar o SUM
vgCp$ = Trim$(Parse$(vgSe$, ",")) 'dos campos selecionados
If UCase$(Left$(vgCp$, 4)) = "SUM(" Then 'caso exista
vgCp$ = Mid$(vgCp$, 5, Rat(vgCp$, ")") - 5)
End If
If Len(x$) > 0 Then x$ = x$ + ", " 'x sera a relação de cps
x$ = x$ + vgCp$ 'selecionados
Wend
If Len(vgGrupo$) > 0 Then 'existe GROUP BY
vgSe$ = x$ 'campos do SELEC sem SUM
x$ = ""
vgNumTit = 0
On Error Resume Next 'prepara para um erro
While Len(vgSe$) > 0 'corre todos os campos
vgCp$ = Trim$(Parse$(vgSe$, ",")) 'do SELECT e coloca
If PosiDoNome(vgGrupo$ + ",", vgCp$ + ",") = 0 Then 'o SUM se necessário
T$ = Parse$(vgCp$, ".")
vgTp = vgdb.TableDefs(T$).Fields(vgCp$).Type 'tipo do campo
If Err = 0 Then 'Beleza! conseguimos pegar o tipo
vgENum = (vgTp >= dbByte And vgTp <= dbDouble) 'so cp numérico tem SUM
If vgENum Then 'esse é..
vgCp$ = "Sum(" + T$ + "." + vgCp$ + ") As " + vgCp$ 'título da coluna = título do campo
Else 'não é numérico
vgCp$ = T$ + "." + vgCp$ 'vai do jeito que foi selecionado
End If
Else 'este campo não esta em nenhuma tabela
vgNumTit = vgNumTit + 1 'assumi numério e inventa um título
vgCp$ = "Sum(" + T$ + "." + vgCp$ + LoadResString(4480) + Str$(vgNumTit) + "]"
End If
End If
If Len(x$) > 0 Then x$ = x$ + ", " 'coloca "," se precisar
x$ = x$ + vgCp$ 'segue montando a nova "SELECT"
Wend
End If
InsereClausula EXP_SELECT, x$ 'troca a SELECT da exp SQL
End Sub 'escolheu um campo para sumarizar
Private Sub cboCampoGrupo_Click()
Dim vgGrupo As String, i As Integer, vgItemAtual As Integer
If vgNaoEClick = False Then 'o usuário que clicou?
vgItemAtual = cboCampoGrupo.ListIndex 'cp escolhido
vgGrupo$ = ExtraiSQL$(vgExpSQL$, EXP_GROUPBY, True) 'GROUP BY atual
i = PosiDoNome(vgGrupo$ + ",", cboCampoGrupo.Text + ",") 'cp já existe no exp
If i > 0 Then 'se sim,
TiraNomeDaClausula EXP_GROUPBY, cboCampoGrupo.Text 'vamos retirá-lo
Else 'aninda não,
If Len(vgGrupo$) > 0 Then vgGrupo$ = vgGrupo$ + ", " 'vamos concatena-lo
vgGrupo$ = vgGrupo$ + cboCampoGrupo.Text 'a exp já existente
InsereClausula EXP_GROUPBY, vgGrupo$ 'troca cláusula na exp SQL
AjustaGroupBy vgGrupo$ 'ajustes cps (SUM)
End If
vgNaoEClick = True 'evita recursividade
cboCampoGrupo.ListIndex = vgItemAtual 'releciona cp escolhido
vgNaoEClick = False
End If
End Sub 'ordem do consulta
Private Sub cboCampoOrdem_Click()
Dim vgOrdem As String, x As String, i As Integer, j As Integer
vgOrdem$ = ExtraiSQL$(vgExpSQL$, EXP_ORDERBY, True) 'expressão de ordenacao (ORDER)
i = PosiDoNome(vgOrdem$ + ",", cboCampoOrdem.Text + ",") 'cp ja está na ordenação
If i > 0 Then 'sim,
TiraNomeDaClausula EXP_ORDERBY, cboCampoOrdem.Text 'então retira
Else 'não,
If Len(vgOrdem$) > 0 Then vgOrdem$ = vgOrdem$ + ", " 'então vamos
vgOrdem$ = vgOrdem$ + cboCampoOrdem.Text 'coloca-lo
If opcOrdem(1).Value Then 'é descendente
vgOrdem$ = vgOrdem$ + " DESC" 'concatena sufixo
End If
InsereClausula EXP_ORDERBY, vgOrdem$ 'troca ordenação na exp SQL
End If
End Sub Private Sub cboCampos_Click()
Dim T As String, C As String, m As String, vgTp As Integer 'dimensiona
If vgNaoEClick = False Then 'evita recursividade
AtualizaListaFiltro cboValor, cboCampos 'atualiza lista de filtros
C$ = Retira$(cboCampos.Text, "[]", UM_A_UM) 'tira os colchetes
vgTp = InStr(C$, ".") 'procura um ponto
If vgTp > 0 Then 'se tem o ponto (sempre!)
T$ = Left$(C$, vgTp - 1) 'nome da tabela
C$ = Mid$(C$, vgTp + 1) 'nome do campo
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
End If
EncheOperadores cboOperador, (vgTp = dbText Or vgTp = dbMemo) 'enche lista de operadores
End If
End Sub 'enche lst com os campos apropriados
Private Sub AtualizaListaFiltro(vgCt1 As Control, vgCt2 As Control)
Dim i As Integer, T As String, vgTextoAnt As String, vgIndexAnt As Integer, _
Cp As String, vgTp As Integer T$ = Left$(vgCt2.Text, InStr(vgCt2.Text + ".", ".") - 1) 'tabela escolhida
vgTp = -1 'tipo do campo
If vgCt2.ListIndex >= 0 And Len(T$) > 0 Then 'se tem campo selecionado
Cp$ = Retira$(vgCt2.Text, "[]", UM_A_UM) 'vamos retirar todos []
If InStr(Cp$, ".") Then 'se tem nome tab antes do cp
Cp$ = Mid$(Cp$, InStr(Cp$, ".") + 1) 'separa do campo
End If
vgTp = vgdb.TableDefs(Retira$(T$, "[]", UM_A_UM)).Fields(Cp$).Type 'tipo do campo
End If
vgTextoAnt = vgCt1.Text 'texto digitado anteriormente
vgIndexAnt = -1
vgCt1.Clear 'limpa lst
If opcFiltro(0).Value Then
If vgTp = dbDate Then 'se for data
vgCt1.AddItem LoadResString(145) 'em branca
vgCt1.AddItem LoadResString(146) 'data do sistema
ElseIf vgTp = dbText Or vgTp = dbMemo Then 'se for tipo texto
vgCt1.AddItem "" 'em branca
End If
End If
With cboCampoOrdem 'vamos encher
For i = 0 To .ListCount - 1 'com todos os cps
If T$ <> Left$(.List(i), InStr(.List(i), ".") - 1) Or _
opcFiltro(0).Value Then 'possíveis menos os cps
vgCt1.AddItem .List(i) 'da tab já selecionada
End If
Next
End With
For i = 0 To vgCt1.ListCount - 1 'vamos ver qual o campo
If vgCt1.List(i) = vgTextoAnt Then 'estava selecionado
vgIndexAnt = i
Exit For 'achou... cai fora
End If
Next
vgNaoEClick = True 'evita recursividade
vgCt1.ListIndex = vgIndexAnt 'reseleciona cps esclohido
vgNaoEClick = False
End Sub
Private Sub opcFiltro_Click(Index As Integer)
cboOperador.Enabled = (Index = 0)
'labOperador.Enabled = (Index = 0)
|
|
|
|
Martini
|
PAROBÉ
RS - BRASIL
|
|
|
ENUNCIADA !
|
|
|
Postada em 17/02/2006 10:59 hs
esse é código de um projetinho que eu fiz para mostar sql: form: Const CONFIRMA_GRAVACAO = 0 'constantes para testar confirmação do usuário
Const NAO_CONFIRMA_GRAVACAO = 1 Public vgSituacao As Integer, vgCaracteristica As Integer, _
vgTipo As Integer, vgFormID As Long 'propriedades que todos os forms têm... Dim vgExpSQL As String, vgFromAnterior As String 'dimensiona
Dim vgNaoEClick As Integer, vgModifQuery As Integer 'o que precisamos
Dim vgNomeSQL As String ' muda status do botão de gravação
Sub AtualizaBotGravacao(vgStatus As Integer)
vgModifQuery = vgStatus 'liga flag
botGrava.Enabled = vgStatus 'muda status do botão, de acordo
End Sub Private Sub botConcatena_Click()
Dim vgWh As String, x As String, vgSegOperando As String, vgTp As Integer, _
C As String, T As String, i As Integer, EmB As Integer
If opcFiltro(1).Value Then 'se for união de tabelas
vgSegOperando$ = cboValor.Text 'pega campo da 2a. tabela
Else 'se quer filtrar
i = InStr(cboCampos.Text, ".") 'vamos separar o
T$ = Left$(cboCampos.Text, i - 1) 'nome da tabela e o
C$ = Mid$(cboCampos.Text, Len(T$) + 2) 'nome do campo
T$ = Retira$(T$, "[]", UM_A_UM) 'tira os colchetes da
C$ = Retira$(C$, "[]", UM_A_UM) 'tabela e campo
EmB = (UCase$(cboValor.Text) = UCase$("")) 'vamos ver se foi capturado da combo - se sim, é campo
x$ = cboValor.Text
For i = 0 To cboValor.ListCount - 1
If cboValor.List(i) = x$ Then 'foi capturado da combo, é campo
i = -2
Exit For
End If
Next
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
If vgTp = dbBoolean Then 'qual o tipo do
vgSegOperando$ = Str$(Val(cboValor.Text) <> 0) 'campo para montar
ElseIf vgTp = dbText Or vgTp = dbMemo Then 'se for tipo texto
If cboValor.Text = "" Or EmB Then
vgSegOperando$ = "''"
Else
If i < 0 Then 'é campo da lista
vgSegOperando$ = cboValor.Text
Else
vgSegOperando$ = Chr$(39) + cboValor.Text + Chr$(39) 'expressão, poe plics
End If
End If
ElseIf vgTp = dbDate Then 'se for data
If cboValor.Text = "" Or EmB Then
vgSegOperando$ = "Null"
ElseIf UCase$(cboValor.Text) = "DATE" Or UCase$(cboValor.Text) = "DATE()" Or UCase$(cboValor.Text) = UCase$(LoadResString(146)) Then
vgSegOperando$ = "Date()"
Else
If i < 0 Then 'foi pego na combo, vamos ver o tipo
i = InStr(x$, ".") 'vamos separar o
T$ = Left$(x$, i - 1) 'nome da tabela e o
C$ = Mid$(x$, Len(T$) + 2) 'nome do campo
T$ = Retira$(T$, "[]", UM_A_UM) 'tira os colchetes da
C$ = Retira$(C$, "[]", UM_A_UM) 'tabela e campo
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
If vgTp = dbDate Then 'se for data
vgSegOperando$ = x$
Else
vgSegOperando$ = "CDate(" + x$ + ")"
End If
Else
vgSegOperando$ = "CDate('" + x$ + "')"
End If
End If
Else
vgSegOperando$ = cboValor.Text
End If
End If
vgWh$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True) 'cláusula "WHERE" existente
If Len(vgWh$) > 0 Then 'existe alguma?
If opcFiltro(1).Value Or opcAndOr(0).Value Then 'quer AND ou é união de tabelas
x$ = " AND ("
Else 'vai concatenar com OR
x$ = " OR "
If Right$(vgWh$, 1) = ")" Then 'se tem "(" tira para
vgWh$ = Left$(vgWh$, Len(vgWh$) - 1) 'concatenar expressão
Else 'se não tem "("
x$ = x$ + "(" 'vamos colocar um
End If
End If
Else 'não de "WHERE" anterior
x$ = "(" 'vamos começar com "("
End If
If Trim(UCase$(cboOperador.Text)) = "LIKE" Then
vgSegOperando$ = Substitui(vgSegOperando$, "%", "*", SO_UM)
End If
vgWh$ = vgWh$ + x$ + cboCampos.Text + " " + _
cboOperador.Text + " " + vgSegOperando$ + ")" 'agora sim, concatena...
cboCampos.ListIndex = -1 'limpa filtro/união para
cboValor.Text = "" 'um proximo...
InsereClausula EXP_WHERE, vgWh$ 'coloca dentro da exp SQL
AtualizaListaFiltro cboCampos, cboValor 'enche novamente as listas
AtualizaListaFiltro cboValor, cboCampos 'com a nova situação
End Sub Private Sub botGrava_Click()
If SalvaQuery(NAO_CONFIRMA_GRAVACAO) Then 'se gravou query
'frmSeleQueries.EncheLista cboNomeQuery 'vamos coloca-la na lst
vgNaoEClick = True 'de consulta existentes
cboNomeQuery.Text = vgNovaQuery$ 'e reseleciona-la
vgNaoEClick = False
End If
End Sub Private Sub botLimpa_Click()
Dim i As Integer 'começaremos de novo
If SalvaQuery(CONFIRMA_GRAVACAO) Then 'salvar (se quiser) consulta existente
ResetaQuery
cboNomeQuery.SetFocus 'coloca cursor no nome da query
End If
End Sub Private Sub botTiraFiltro_Click()
Beep 'quer retirar filtro (WHERE)
If MsgBox("Tirar cláusula WHERE?", vbYesNo + vbQuestion, vgAtencao$) = vbYes Then
InsereClausula EXP_WHERE, "" 'sim, substitui por nada
End If
End Sub Private Sub cboNomeQuery_Change()
If vgNaoEClick = False And vgNomeSQL$ <> cboNomeQuery.Text Then 'se o usuário que esta modificado o nome
AtualizaBotGravacao True 'da consultam então hab/desabilita
End If 'botões se necessário
vgNomeSQL$ = cboNomeQuery.Text 'nome atual da query
End Sub Private Sub cboValor_Change()
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub Private Sub cboValor_Click()
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub Private Sub Form_Load() Main
Screen.MousePointer = vbHourglass
vgCaracteristica = F_COMUM
vgFormID = 7 'identificacao do form
vgExpSQL$ = ""
vgNomeSQL$ = ""
vgNaoEClick = False
EncheNomesTabs AtualizaBotGravacao False ' labNomeQuery.Caption = LoadResString(4000)
' labCampoGrupo.Caption = LoadResString(4010)
' labTabelas.Caption = LoadResString(4020)
' labCamposMostrar.Caption = LoadResString(4030)
' fraOrdenacao.Caption = LoadResString(4040)
' opcOrdem(0).Caption = LoadResString(4050)
' opcOrdem(1).Caption = LoadResString(4060)
' fraTop.Caption = LoadResString(4070)
' OpcTop(0).Caption = LoadResString(4080)
' OpcTop(1).Caption = LoadResString(4090)
' fraFiltragem.Caption = LoadResString(4100)
' opcFiltro(0).Caption = LoadResString(4110)
' opcFiltro(1).Caption = LoadResString(4120)
' opcAndOr(0).Caption = LoadResString(4130)
' opcAndOr(1).Caption = LoadResString(4140)
' botConcatena.Caption = LoadResString(4150)
' chkPermitirATodos.Caption = LoadResString(4275)
' labNomeCampo.Caption = LoadResString(4160)
' labOperador.Caption = LoadResString(4170)
' labValor.Caption = LoadResString(4180)
' labCriterio.Caption = LoadResString(4190)
'Set botGrava.Picture = LoadResPicture(245, vbResIcon)
'Set botGrava.PictureDisabled = LoadResPicture(250, vbResIcon)
'Set botRetorna.Picture = LoadResPicture(255, vbResIcon)
'Set botLimpa.Picture = LoadResPicture(260, vbResIcon)
'Set botTiraFiltro.Picture = LoadResPicture(263, vbResIcon)
' botTiraFiltro.Tag = LoadResString(4490)
' botConcatena.Tag = LoadResString(4200)
' botRetorna.Tag = LoadResString(4210)
' botGrava.Tag = LoadResString(4220)
' botLimpa.Tag = LoadResString(4230)
' fraAndOr.Tag = LoadResString(4240)
' fraFiltragem.Tag = LoadResString(4250)
' fraOrdenacao.Tag = LoadResString(4260)
' fraTop.Tag = LoadResString(4270)
' lstCamposMostrar.Tag = LoadResString(4330)
' lstTabelas.Tag = LoadResString(4340)
' opcFiltro(0).Tag = LoadResString(4350)
' opcFiltro(1).Tag = LoadResString(4355)
' opcOrdem(0).Tag = LoadResString(4360)
' opcOrdem(1).Tag = LoadResString(4365)
' OpcTop(0).Tag = LoadResString(4370)
' OpcTop(1).Tag = LoadResString(4375)
' txtCriterio.Tag = LoadResString(4380)
' txtTop.Tag = LoadResString(4390)
EncheOperadores cboOperador, True
'frmSeleQueries.EncheLista cboNomeQuery
cboOperador.Text = "="
CentraNaTela Me
Screen.MousePointer = vbDefault
End Sub 'enche lista com nomes das tabelas
Private Sub EncheNomesTabs()
Dim i As Integer lstTabelas.Clear
'enche lista de tabelas
For i = 0 To vgdb.TableDefs.Count - 1
If (vgdb.TableDefs(i).Attributes And dbSystemObject) = 0 Then
If InStr(vgdb.TableDefs(i).Name, "~") = 0 Then 'tira tabelas de segurança e invisíveis
lstTabelas.AddItem vgdb.TableDefs(i).Name
End If
End If
Next
End Sub Private Sub lstTabelas_Click()
Dim vgCp As Field, i As Integer, vgSe As String, vgNt As String, _
x As String lstCamposMostrar.Clear
If lstTabelas.ListIndex >= 0 Then
vgNt$ = PoeColchetes$(lstTabelas.Text) + "."
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True)
vgNaoEClick = True
For Each vgCp In vgdb.TableDefs(lstTabelas.Text).Fields
If InStr(vgCp.Name, "~") = 0 And Left$(vgCp.ValidationText, 1) <> "I" Then
lstCamposMostrar.AddItem vgCp.Name
If PosiDoNome(vgSe$ + ",", vgNt$ + PoeColchetes$(vgCp.Name) + ",") > 0 Then
lstCamposMostrar.Selected(lstCamposMostrar.ListCount - 1) = True 'selecione este...
End If
End If
Next
vgNaoEClick = False
End If
End Sub
'acha posição de um nome dentro de uma string
Private Function PosiDoNome(ByVal Alvo As String, ByVal Pesq As String) As Integer
Dim i As Integer, vgAscDir As Integer, vgAscEsq As Integer
Alvo$ = " " + UCase$(Alvo$) + " " 'string alvo
Pesq$ = UCase$(Pesq$) 'campo a pesquisar
i = 0 'posição do nome na string
DeNovo:
i = InStr(i + 1, Alvo$, Pesq$) 'o nome esta dentro da string?
If i > 0 Then 'se afirnativo
vgAscDir = Asc(Mid$(Alvo$, i + Len(Pesq$))) 'testa o char mais a direita
vgAscEsq = Asc(Mid$(Alvo$, i - 1)) 'e o mais a esquerda do nome
If (vgAscDir > 46 And vgAscDir < 58) Or _
(vgAscDir > 64 And vgAscDir < 113) Then 'para ter a certeza de
GoTo DeNovo 'que o nome não é um
End If 'subconjunto de outro nome
If (vgAscEsq > 46 And vgAscEsq < 58) Or _
(vgAscEsq > 64 And vgAscEsq < 113) Then 'se o nome não é válido
GoTo DeNovo 'continua pesquisando
End If 'na sting
i = i - 1
End If 'posição onde achou o nome
PosiDoNome = i
End Function
Private Sub lstCamposMostrar_Click()
Dim T As String, vgCp As String, vgNomeCp As String, i As Integer, j As Integer
Dim vgSe As String, vgFr As String, vgGrupo As String, x As String, vgWhere As String
If vgNaoEClick Then Exit Sub
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True)
vgFr$ = ExtraiSQL$(vgExpSQL$, EXP_FROM, True)
vgGrupo$ = ExtraiSQL$(vgExpSQL$, EXP_GROUPBY, True)
T$ = PoeColchetes$(lstTabelas.Text)
vgCp$ = T$ + "." + PoeColchetes$(lstCamposMostrar.Text)
vgNomeCp$ = vgCp$
If Len(vgGrupo$) > 0 Then
i = vgdb.TableDefs(T$).Fields(lstCamposMostrar.Text).Type
j = (i >= dbByte And i <= dbDouble) 'so cp numérico tem SUM
If j Then
vgCp$ = "Sum(" + vgCp$ + ") As " + PoeColchetes$(lstCamposMostrar.Text)
End If
End If
If lstCamposMostrar.Selected(lstCamposMostrar.ListIndex) Then 'estava NAO SELECIONADO
If PosiDoNome(vgSe$ + ",", vgCp$ + ",") = 0 Then 'atualiza SQL se o campo não constar nela
If Len(vgSe$) > 0 Then vgSe$ = vgSe$ + ", "
InsereClausula EXP_SELECT, vgSe$ + vgCp$
End If
If PosiDoNome(vgFr$ + ",", T$ + ",") = 0 Then
If Len(vgFr$) > 0 Then vgFr$ = vgFr$ + ", "
InsereClausula EXP_FROM, vgFr$ + T$
End If
Else 'estava SELECIONADO
i = PosiDoNome(vgSe$ + ",", vgCp$ + ",")
If i Then
vgSe$ = Trim$(Left$(vgSe$, i - 1) + Mid$(vgSe$, i + Len(vgCp$) + 1))
If Right$(vgSe$, 1) = "," Then vgSe$ = Left$(vgSe$, Len(vgSe$) - 1)
InsereClausula EXP_SELECT, vgSe$
End If
If PosiDoNome(vgSe$, T$) = 0 Then TiraNomeDaClausula EXP_FROM, T$
TiraNomeDaClausula EXP_ORDERBY, vgNomeCp$
TiraNomeDaClausula EXP_GROUPBY, vgNomeCp$
vgWhere$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True)
If PosiDoNome(vgWhere$, vgCp$) > 0 Then 'se o campo faz parte do filtro
InsereClausula EXP_WHERE, "" 'remove todo o filtro
End If
End If
txtCriterio.Text = vgExpSQL$
End Sub
'insere cláusula especificada dentro da exrpessão SQL
Private Sub InsereClausula(vgQual As Integer, ByVal vgOQueInserir As String)
Dim vgEx As String, j As Integer, i As Integer, vgTp As Integer, _
k As String, x As String, vgCp As Field, C As String, vgCt As Control
vgEx$ = "" 'conterá toda a exp SQL
vgOQueInserir$ = Trim$(vgOQueInserir$) 'cláusula a inserir
For i = 0 To EXP_TODAS - 1 'corre todas as cláusulas
If i = vgQual Then 'se for a que quer inserir
x$ = vgOQueInserir$ 'substitui pela informada
Else 'caso contrário
x$ = ExtraiSQL$(vgExpSQL$, i, True) 'tira cláusula da própia exp SQL
End If
If Len(x$) Then 'se a cláusula existe
If i = EXP_SELECT And Val(txtTop.Text) > 0 Then 'se for a "SELECT" e tem "TOP"
x$ = "TOP " + LTrim$(txtTop.Text) + _
Left$(" PERCENT", 8 * -(OpcTop(1) = True)) + _
" " + x$ 'coloca na cláusula (incluido o "PERCENT")
End If
vgEx$ = vgEx$ + LTrim$(vgClausula$(i)) + x$ + vbCrLf 'e segue montando a nova exp SQL
End If
Next
vgExpSQL$ = Trim$(vgEx$) 'esta é a nova exp SQL
txtCriterio.Text = vgExpSQL$ 'mostra ao usuário 'se a cláusula modificada/inclusa foi a "FROM" ou remontou toda
'a expressão SQL vamos aproveitar e reatualizar todos os controles
'que depende destes arquivos selecionados
If (vgQual = EXP_FROM Or vgQual = EXP_TODAS) And _
(vgOQueInserir$ <> vgFromAnterior$ Or Len(vgOQueInserir$) = 0) Then
If vgQual = EXP_TODAS Then 'se pediu para remontar toda a SQL
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_FROM, True) 'extrai a cláusula "FROM"
End If
cboCampos.Clear 'limpa combos de campos
cboValor.Clear 'valores (filtragem)
cboCampoOrdem.Clear 'e ordem
vgFromAnterior$ = vgOQueInserir$ 'salva cláusula "FROM"
While Len(vgOQueInserir$) > 0 'vamos pegar todos os arquivo da "FROM"
x$ = Trim$(Parse$(vgOQueInserir$, ",")) 'nome do arquivo
For Each vgCp In vgdb(Retira$(x$, "[]", UM_A_UM)).Fields 'pega todos os campos do arqivo
C$ = x$ + "." + PoeColchetes$(vgCp.Name) 'prepara para inserir nas conbos...
If Left$(vgCp.ValidationText, 1) <> "I" And InStr(vgCp.Name, "~") = 0 And _
vgCp.Type <> dbLongBinary Then 'campo invisível não pode... 'se já tem um campo no primeiro operando (filtragem) vamos encher
'o segundo operador com todos os outros campos menos com os campos
'da tabela do primeiro operando (união entre tabelas)
If Len(cboValor.Text) = 0 Or _
x$ <> Left$(cboValor.Text, InStr(cboValor.Text + ".", ".") - 1) Then
cboCampos.AddItem C$
End If 'idem para encher a combo do primeiro operando...
If Len(cboCampos.Text) = 0 Or _
x$ <> Left$(cboCampos.Text, InStr(cboCampos.Text + ".", ".") - 1) Then
cboValor.AddItem C$
End If
If vgCp.Type <> dbMemo Then
cboCampoOrdem.AddItem C$ 'todos os campos valem na ordenação
End If
End If
Next
Wend
i = (InStr(vgFromAnterior$, ",") > 0) 'tem mais de uma tabela na cláusual "FROM"
opcFiltro(1).Enabled = i 'só pode unir tabela se mais de 1
If opcFiltro(1).Enabled = False And _
opcFiltro(1).Value = True Then 'se não pode unir tabelas mas este
opcFiltro(0).Value = True 'está marcado, desmarca
End If
End If 'se a cláusula modificada/inclusa foi a "WHERE" ou remontou toda
'a expressão SQL verificar se agora ja podemos deixa o usuário
'concatenar com AND e OR
If vgQual = EXP_WHERE Or vgQual = EXP_TODAS Then
If vgQual = EXP_TODAS Then 'retira exp "WHERE" se
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_WHERE, True) 'remontou toda s SQL
End If
i = Len(vgOQueInserir$) > 0 'pode concatenar?
If fraAndOr.Visible <> i And opcFiltro(0).Value Then 'se pode e não esta
fraAndOr.Visible = i 'unindo tabela...
End If
If botTiraFiltro.Visible <> i Then 'habilita/desabilita
botTiraFiltro.Visible = i 'botão para limpar
End If 'exp "WHERE"
End If 'se a cláusula modificada/inclusa foi a "SELECT" ou remontou toda
'a expressão SQL vamos aproveitar e habilitar/desabilitar todos os
'controles que depende do numero de campos seleciondos
If vgQual = EXP_SELECT Or vgQual = EXP_TODAS Then
If vgQual = EXP_TODAS Then 'se remontou tudo
vgOQueInserir$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True) 'extrai "SELECT"
End If
i = Len(vgOQueInserir$) > 0 'habilitado ou não?
If fraFiltragem.Enabled <> i Then 'se esta diferente do anterior
cboCampoGrupo.Enabled = i 'vamos habiliar ou
cboCampoOrdem.Enabled = i 'desabilitar todos
cboCampos.Enabled = i 'os controles que
cboOperador.Enabled = i 'não pode ser
cboValor.Enabled = i 'utilizados enquanto
fraAndOr.Enabled = i 'não existir pelo
fraFiltragem.Enabled = i 'menos um campo
fraOrdenacao.Enabled = i 'selecionado
fraTop.Enabled = i
' labCampoGrupo.Enabled = i
' labCriterio.Enabled = i
' labNomeCampo.Enabled = i
' labOperador.Enabled = i
' labValor.Enabled = i
txtCriterio.Enabled = i
txtTop.Enabled = i
For j = 0 To 1
opcAndOr(j).Enabled = i
opcFiltro(j).Enabled = i
opcOrdem(j).Enabled = i
Next
End If
cboCampoGrupo.Clear 'agrupar registros...
While Len(vgOQueInserir$) > 0 'somente os campos da exp SQL
C$ = Trim$(Parse$(vgOQueInserir$, ",")) 'podem ser usados
i = InStr(UCase$(C$), "SUM(") 'se o campo tem o prefixo "SUM"
If i Then 'vamos remove-lo
j = Rat(C$, ")") 'antes de colocarmos na lista
If j > i Then
C$ = Trim$(Mid$(C$, i + 4, j - i - 4))
End If
End If
cboCampoGrupo.AddItem C$ 'lista de campos (grupos)
Wend
End If
botConcatena.Enabled = (Len(cboValor.Text) > 0 And Len(cboCampos.Text) > 0)
End Sub
Private Sub TiraNomeDaClausula(ByVal vgQual As Integer, vgNome As String)
Dim i As Integer, j As Integer, vgEx As String
vgEx$ = ExtraiSQL$(vgExpSQL$, vgQual, True)
TiraOutro:
i = PosiDoNome(vgEx$ + ",", vgNome$ + ",")
If i > 0 And Len(vgEx$) > 0 And Len(vgNome$) > 0 Then
j = InStr(i, vgEx$ + ",", ",")
vgEx$ = Trim$(Left$(vgEx$, i - 1) + Mid$(vgEx$, j + 1))
If Right$(vgEx$, 1) = "," Then vgEx$ = Left$(vgEx$, Len(vgEx$) - 1)
InsereClausula vgQual, vgEx$
If vgQual = EXP_GROUPBY Then AjustaGroupBy vgEx$
GoTo TiraOutro
End If
End Sub 'limpa e reseta a consulta em montagem
Private Sub ResetaQuery()
vgExpSQL$ = "" 'limpa exp SQL existente
cboNomeQuery.Text = "" 'nome da consulta
vgNaoEClick = True 'evitaremos recursividade
InsereClausula EXP_TODAS, "" 'prepara todos os controles
vgNaoEClick = False
lstTabelas.ListIndex = -1 'deseleciona tabela
AtualizaBotGravacao False 'troca figuras/hab/desabilita botÔes
End Sub 'coloca cláusula "GROUP BY" e prefixo "SUM" nos campos do "SELECT"
Private Sub AjustaGroupBy(vgGrupo As String)
Dim x As String, vgSe As String, T As String, vgCp As String, vgENum As Integer, _
vgTp As Integer, vgNumTit As Integer
vgSe$ = ExtraiSQL$(vgExpSQL$, EXP_SELECT, True) 'campos selecionados
x$ = ""
While Len(vgSe$) > 0 'vamos tirar o SUM
vgCp$ = Trim$(Parse$(vgSe$, ",")) 'dos campos selecionados
If UCase$(Left$(vgCp$, 4)) = "SUM(" Then 'caso exista
vgCp$ = Mid$(vgCp$, 5, Rat(vgCp$, ")") - 5)
End If
If Len(x$) > 0 Then x$ = x$ + ", " 'x sera a relação de cps
x$ = x$ + vgCp$ 'selecionados
Wend
If Len(vgGrupo$) > 0 Then 'existe GROUP BY
vgSe$ = x$ 'campos do SELEC sem SUM
x$ = ""
vgNumTit = 0
On Error Resume Next 'prepara para um erro
While Len(vgSe$) > 0 'corre todos os campos
vgCp$ = Trim$(Parse$(vgSe$, ",")) 'do SELECT e coloca
If PosiDoNome(vgGrupo$ + ",", vgCp$ + ",") = 0 Then 'o SUM se necessário
T$ = Parse$(vgCp$, ".")
vgTp = vgdb.TableDefs(T$).Fields(vgCp$).Type 'tipo do campo
If Err = 0 Then 'Beleza! conseguimos pegar o tipo
vgENum = (vgTp >= dbByte And vgTp <= dbDouble) 'so cp numérico tem SUM
If vgENum Then 'esse é..
vgCp$ = "Sum(" + T$ + "." + vgCp$ + ") As " + vgCp$ 'título da coluna = título do campo
Else 'não é numérico
vgCp$ = T$ + "." + vgCp$ 'vai do jeito que foi selecionado
End If
Else 'este campo não esta em nenhuma tabela
vgNumTit = vgNumTit + 1 'assumi numério e inventa um título
vgCp$ = "Sum(" + T$ + "." + vgCp$ + LoadResString(4480) + Str$(vgNumTit) + "]"
End If
End If
If Len(x$) > 0 Then x$ = x$ + ", " 'coloca "," se precisar
x$ = x$ + vgCp$ 'segue montando a nova "SELECT"
Wend
End If
InsereClausula EXP_SELECT, x$ 'troca a SELECT da exp SQL
End Sub 'escolheu um campo para sumarizar
Private Sub cboCampoGrupo_Click()
Dim vgGrupo As String, i As Integer, vgItemAtual As Integer
If vgNaoEClick = False Then 'o usuário que clicou?
vgItemAtual = cboCampoGrupo.ListIndex 'cp escolhido
vgGrupo$ = ExtraiSQL$(vgExpSQL$, EXP_GROUPBY, True) 'GROUP BY atual
i = PosiDoNome(vgGrupo$ + ",", cboCampoGrupo.Text + ",") 'cp já existe no exp
If i > 0 Then 'se sim,
TiraNomeDaClausula EXP_GROUPBY, cboCampoGrupo.Text 'vamos retirá-lo
Else 'aninda não,
If Len(vgGrupo$) > 0 Then vgGrupo$ = vgGrupo$ + ", " 'vamos concatena-lo
vgGrupo$ = vgGrupo$ + cboCampoGrupo.Text 'a exp já existente
InsereClausula EXP_GROUPBY, vgGrupo$ 'troca cláusula na exp SQL
AjustaGroupBy vgGrupo$ 'ajustes cps (SUM)
End If
vgNaoEClick = True 'evita recursividade
cboCampoGrupo.ListIndex = vgItemAtual 'releciona cp escolhido
vgNaoEClick = False
End If
End Sub 'ordem do consulta
Private Sub cboCampoOrdem_Click()
Dim vgOrdem As String, x As String, i As Integer, j As Integer
vgOrdem$ = ExtraiSQL$(vgExpSQL$, EXP_ORDERBY, True) 'expressão de ordenacao (ORDER)
i = PosiDoNome(vgOrdem$ + ",", cboCampoOrdem.Text + ",") 'cp ja está na ordenação
If i > 0 Then 'sim,
TiraNomeDaClausula EXP_ORDERBY, cboCampoOrdem.Text 'então retira
Else 'não,
If Len(vgOrdem$) > 0 Then vgOrdem$ = vgOrdem$ + ", " 'então vamos
vgOrdem$ = vgOrdem$ + cboCampoOrdem.Text 'coloca-lo
If opcOrdem(1).Value Then 'é descendente
vgOrdem$ = vgOrdem$ + " DESC" 'concatena sufixo
End If
InsereClausula EXP_ORDERBY, vgOrdem$ 'troca ordenação na exp SQL
End If
End Sub Private Sub cboCampos_Click()
Dim T As String, C As String, m As String, vgTp As Integer 'dimensiona
If vgNaoEClick = False Then 'evita recursividade
AtualizaListaFiltro cboValor, cboCampos 'atualiza lista de filtros
C$ = Retira$(cboCampos.Text, "[]", UM_A_UM) 'tira os colchetes
vgTp = InStr(C$, ".") 'procura um ponto
If vgTp > 0 Then 'se tem o ponto (sempre!)
T$ = Left$(C$, vgTp - 1) 'nome da tabela
C$ = Mid$(C$, vgTp + 1) 'nome do campo
vgTp = vgdb(T$).Fields(C$).Type 'tipo do campo
End If
EncheOperadores cboOperador, (vgTp = dbText Or vgTp = dbMemo) 'enche lista de operadores
End If
End Sub 'enche lst com os campos apropriados
Private Sub AtualizaListaFiltro(vgCt1 As Control, vgCt2 As Control)
Dim i As Integer, T As String, vgTextoAnt As String, vgIndexAnt As Integer, _
Cp As String, vgTp As Integer T$ = Left$(vgCt2.Text, InStr(vgCt2.Text + ".", ".") - 1) 'tabela escolhida
vgTp = -1 'tipo do campo
If vgCt2.ListIndex >= 0 And Len(T$) > 0 Then 'se tem campo selecionado
Cp$ = Retira$(vgCt2.Text, "[]", UM_A_UM) 'vamos retirar todos []
If InStr(Cp$, ".") Then 'se tem nome tab antes do cp
Cp$ = Mid$(Cp$, InStr(Cp$, ".") + 1) 'separa do campo
End If
vgTp = vgdb.TableDefs(Retira$(T$, "[]", UM_A_UM)).Fields(Cp$).Type 'tipo do campo
End If
vgTextoAnt = vgCt1.Text 'texto digitado anteriormente
vgIndexAnt = -1
vgCt1.Clear 'limpa lst
If opcFiltro(0).Value Then
If vgTp = dbDate Then 'se for data
vgCt1.AddItem LoadResString(145) 'em branca
vgCt1.AddItem LoadResString(146) 'data do sistema
ElseIf vgTp = dbText Or vgTp = dbMemo Then 'se for tipo texto
vgCt1.AddItem "" 'em branca
End If
End If
With cboCampoOrdem 'vamos encher
For i = 0 To .ListCount - 1 'com todos os cps
If T$ <> Left$(.List(i), InStr(.List(i), ".") - 1) Or _
opcFiltro(0).Value Then 'possíveis menos os cps
vgCt1.AddItem .List(i) 'da tab já selecionada
End If
Next
End With
For i = 0 To vgCt1.ListCount - 1 'vamos ver qual o campo
If vgCt1.List(i) = vgTextoAnt Then 'estava selecionado
vgIndexAnt = i
Exit For 'achou... cai fora
End If
Next
vgNaoEClick = True 'evita recursividade
vgCt1.ListIndex = vgIndexAnt 'reseleciona cps esclohido
vgNaoEClick = False
End Sub
Private Sub opcFiltro_Click(Index As Integer)
cboOperador.Enabled = (Index = 0)
'labOperador.Enabled = (Index = 0)
|
|
|
|
|
|
Postada em 17/02/2006 15:42 hs
Valeu pela ajuda...
<DIV>Klaus Lana</DIV>
|
|
|
|
|
