Estou adaptando o modelo 3.5 e quando eu clico para pesquisar no formulário de cadastro, o seguinte erro me aparece:
"Key is not unique in collection, 35602, ListItems", aperto ok, e o formulário de pesquisa me aparece novamente!
Alguém saberia como resolver esse problema?
Não achei onde anexar o arquivo, portando estou escrevendo abaixo.
Option Explicit
'constantes para auxiliar na verificação do código
Private Const Ascendente As Byte = 0
Private Const Descendente As Byte = 1
Private caminhoArquivoDados As String
'INICIO - REDIMENSIONAR AUTOMATICAMENTE COLUNAS DO LISTVIEW
'TamanhoColAutomatico - 'Define os Tamanhos das colunas automaticamente
'http://www.vb6.com.br/29/Controles-Micr ... TVIEW.html
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const LVM_FIRST = &H1000
Private Const LVM_SETCOLUMNWIDTH = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE = -1
Private Const LVSCW_AUTOSIZE_USEHEADER = -2
'FIM - REDIMENSIONAR AUTOMATICAMENTE COLUNAS DO LISTVIEW
Private Sub btnExportar_Click()
Call Exportar
End Sub
Private Sub btnFiltrar_Click()
Call PopulaListBox(txtequipamento.Text, txtmarca.Text, txtmodelo.Text, txtnotafiscal.Text, txtdataemissao.Text)
End Sub
Private Sub ListView_ColumnClick(ByVal ColumnHeader As Object)
'Rem Organizar os itens na coluna clicada. Se já estamos _
'ordenar por essa coluna, inverta a ordem de classificação. _
'Caso contrário, defina a ordem de classificação para crescente. _
_
'O SortKey é baseado em zero, a ColumnHeaderIndex é um baseado.
If ListView.SortKey = ColumnHeader.Index - 1 Then
'Rem Click estava na coluna classificada. _
'Alterne o valor SortOrder - 0 Crescente, 1 Decrescente.
ListView.SortOrder = 1 - ListView.SortOrder
Else: Click ' _
'estava em uma coluna diferenteClassificar sobre a nova coluna em ordem crescente.
ListView.SortKey = ColumnHeader.Index - 1
ListView.SortOrder = lvwAscending
End If
End Sub
Private Sub lstLista_DblClick()
Dim linha, Index
Dim i As Integer
Dim oList As Object
Dim indiceRegistro As Long
On Error Resume Next
Set oList = lstLista.SelectedItem
If oList Is Nothing Then 'Exit Sub
lblMensagens.Caption = "É preciso selecionar um item válido na lista"
Else
indiceRegistro = frmCadastro.ProcuraIndiceRegistroPodId(lstLista.ListItems.Item(lstLista.SelectedItem.Index))
If indiceRegistro <> -1 Then
Call frmCadastro.CarregaRegistroPorIndice(indiceRegistro)
End If
Unload Me
End If
End Sub
Private Sub DefinePlanilhaDados()
Dim wb As Workbook
Dim caminhoCompleto As String
Dim ARQUIVO_DADOS As String
Dim PASTA_DADOS As String
ThisWorkbook.Activate
ARQUIVO_DADOS = Range("ARQUIVO_DADOS").Value
PASTA_DADOS = Range("PASTA_DADOS").Value
If ThisWorkbook.Name <> ARQUIVO_DADOS Then
'monta a string do caminho completo
If PASTA_DADOS = vbNullString Or PASTA_DADOS = "" Then
caminhoCompleto = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, vbNullString) & ARQUIVO_DADOS
Else
If Right(PASTA_DADOS, 1) = "\" Then
caminhoCompleto = PASTA_DADOS & ARQUIVO_DADOS
Else
caminhoCompleto = PASTA_DADOS & "\" & ARQUIVO_DADOS
End If
End If
End If
caminhoArquivoDados = caminhoCompleto
End Sub
Private Sub UserForm_Initialize()
'lv.ListItems.Clear 'Clear ListView from previous filled data
lstLista.ColumnHeaders.Clear 'Clear the Column Headers
lstLista.ListItems.Clear
With lstLista
.Gridlines = True
.View = lvwReport
'.FullRowSelect
' .ColumnHeaders.Add Text:="ID", Width:=20
' .ColumnHeaders.Add Text:="NOME", Width:=60
' .ColumnHeaders.Add Text:="Endereço", Width:=120
' .ColumnHeaders.Add Text:="FONE", Width:=30
' .ColumnHeaders.Add Text:="CIDADE", Width:=50
End With
'preenche o cboDirecao e seleciona o primeiro item
cboDirecao.Clear
cboDirecao.AddItem "Ascendente"
cboDirecao.AddItem "Descendente"
cboDirecao.ListIndex = 0
Call DefinePlanilhaDados
Call Populaativofixo
Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)
End Sub
Private Sub Exportar()
Dim i As Integer
Dim NewWorkBook As Workbook
Dim rst As ADODB.Recordset
' Preenche o RecordSet com os filtros atuais
Set rst = PreecheRecordSet(txtequipamento.Text, txtmarca.Text, txtmodelo.Text, txtnotafiscal.Text, txtdataemissao.Text)
'cria um novo Workbook
Set NewWorkBook = Application.Workbooks.Add
' Efetua loop em todos os campos, retornando os nomes de campos
' à planilha.
For i = 0 To rst.Fields.Count - 1
NewWorkBook.Sheets(1).Range("A1").Offset(0, i).Value = rst.Fields(i).Name
Next i
NewWorkBook.Sheets(1).Range("A2").CopyFromRecordset rst
NewWorkBook.Activate
End Sub
Private Sub Populaativofixo()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & caminhoArquivoDados & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT DISTINCT AtivoFixo FROM [Equipamento$]"
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenDynamic, _
adLockBatchOptimistic
End With
Do While Not rst.EOF
If Not IsNull(rst(0).Value) Then
lstativofixo.AddItem rst(0).Value
End If
rst.MoveNext
Loop
' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
conn.Close
End Sub
Private Sub PopulaListBox(ByVal equipamento As String, _
ByVal marca As String, _
ByVal modelo As String, _
ByVal notafiscal As String, _
ByVal dataemissao As String)
On Error GoTo TrataErro
Dim rst As ADODB.Recordset
Dim campo As Field
Dim myArray() As Variant
Dim i As Integer
Dim li As ListItem, fld As Field, ch As ColumnHeader
Dim Column As Long
Dim Counter As Long
Counter = 0
Set rst = PreecheRecordSet(equipamento, marca, modelo, notafiscal, dataemissao)
'preenche o combobox com os nomes dos campos
'persiste o índice
Dim indiceTemp As Long
indiceTemp = cboOrdenarPor.ListIndex
cboOrdenarPor.Clear
For Each campo In rst.Fields
cboOrdenarPor.AddItem campo.Name
Next
'recupera o índice selecionado
cboOrdenarPor.ListIndex = indiceTemp
'Colunas a Preencher Inicia na Primeira
For i = 0 To rst.Fields.Count - 1 'For i = 1 : a partir da 2ª coluna
Set ch = lstLista.ColumnHeaders.Add(, , rst.Fields(i).Name)
'ch.Width = 48 'Define o Tamanho de Todas as COLUNAS
'MsgBox rst.Fields(i).Name
Next
'Clear the Column Headers
lstLista.ListItems.Clear
'coloca as linhas do RecordSet num Array, se houver linhas neste
If Not rst.BOF Then
Do While Not rst.EOF
'Preenche o LISTVIEW a partir da 2ª Coluna
'Set li = lstLista.ListItems.Add(, "k" & rst.Fields(0), CheckNull(rst.Fields(1)))
'Fill in the rest of the columns
'For i = 2 To rst.Fields.Count - 1
'li.SubItems(i - 1) = CheckNull(rst.Fields(i))
'Preenche o LISTVIEW a partir da 1ª Coluna
Set li = lstLista.ListItems.Add(, "k" & rst.Fields(0), CheckNull(rst.Fields(0)))
'Fill in the rest of the columns
For i = 1 To rst.Fields.Count - 1
li.SubItems(i) = CheckNull(rst.Fields(i))
Next
rst.MoveNext 'Move to next record
Loop
'Define os Tamanhos das colunas automaticamente
Call TamanhoColAutomatico
End If
'atualiza o label de mensagens
If rst.RecordCount <= 0 Then
lblMensagens.Caption = rst.RecordCount & " registros encontrados"
Else
lblMensagens.Caption = rst.RecordCount & " registros encontrados"
End If
Exit Sub
' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
'conn.Close
TrataSaida:
Exit Sub
TrataErro:
Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
MsgBox Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End Sub
Private Sub TamanhoColAutomatico()
Dim Column As Long
Dim Counter As Long
Counter = 0
For Column = Counter To lstLista.ColumnHeaders.Count - 2
SendMessage lstLista.hWnd, LVM_SETCOLUMNWIDTH, Column, LVSCW_AUTOSIZE_USEHEADER
Next
End Sub
Public Function CheckNull(FieldValue As Variant)
On Error GoTo Error
If IsNull(FieldValue) Then
CheckNull = ""
Else
CheckNull = FieldValue
End If
' Exit Sub
Error:
'GeneralErrors "CheckNull", Err.Number, Err.Description
Resume Next
End Function
Private Function PreecheRecordSet(ByVal equipamento As String, _
ByVal marca As String, _
ByVal modelo As String, _
ByVal notafiscal As String, _
ByVal dataemissao As String) As Recordset
On Error GoTo TrataErro
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
Dim i As Integer
Dim campo As Field
Dim myArray() As Variant
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & caminhoArquivoDados & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT * FROM [Equipamento$]"
'monta a cláusula WHERE
'Equipamentos
Call MontaClausulaWhere(txtequipamento.Name, "Equipamento", sqlWhere)
'Marca
Call MontaClausulaWhere(txtmarca.Name, "Marca", sqlWhere)
'Modelo
Call MontaClausulaWhere(txtmodelo.Name, "Modelo", sqlWhere)
'Ativo Fixo
For i = 1 To lstativofixo.ListCount
'verifica se o item está selecionado
If lstativofixo.Selected(i - 1) Then
'Monta a cláusula WHERE com OR
Debug.Print lstativofixo.List(i - 1) & " selecionado"
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " OR"
End If
sqlWhere = sqlWhere & " UCASE(AtivoFixo) LIKE UCASE('%" & Trim(lstativofixo.List(i - 1)) & "%')"
End If
Next
'Nota Fiscal
Call MontaClausulaWhere(txtnotafiscal.Name, "NotaFiscal", sqlWhere)
'Data Emissao
Call MontaClausulaWhere(txtdataemissao.Name, "DataEmissao", sqlWhere)
'faz a união da string SQL com a cláusula WHERE
If sqlWhere <> vbNullString Then
sql = sql & " WHERE " & sqlWhere
End If
'faz a união da string SQL com a cláusula ORDER BY
If cboOrdenarPor.ListIndex <> -1 Then
sqlOrderBy = " ORDER BY " & cboOrdenarPor.List(cboOrdenarPor.ListIndex, 0)
'define a direção
Select Case cboDirecao.ListIndex
Case Ascendente
sqlOrderBy = sqlOrderBy & " ASC"
Case Descendente
sqlOrderBy = sqlOrderBy & " DESC"
End Select
'une a query order ao sql
sql = sql & sqlOrderBy
End If
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenForwardOnly, _
adLockBatchOptimistic
End With
Set rst.ActiveConnection = Nothing
' Fecha a conexão.
conn.Close
Set PreecheRecordSet = rst
Exit Function
TrataErro:
Set rst = Nothing
End Function
Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
'NomeDoContato
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " AND"
End If
sqlWhere = sqlWhere & " UCASE(" & NomeCampo & ") LIKE UCASE('%" & Trim(Me.Controls(NomeControle).Text) & "%')"
End If
End Sub
'Faz a transpasição de um array, transformando linhas em colunas
Private Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant
If IsArray(avValues) Then
On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)
ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If
Array2DTranspose = avTransposed
Exit Function
ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume
End Function
Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E