ATENÇÃO NOVOS USUÁRIOS

Se registrou recentemente? Seu cadastro será avaliado e mendiante aprovação, a conta será ativada e você poderá usufruir do fórum. O tempo de avaliação gira em torno de 24 a 48 horas.

Esqueceu sua senha?

Você pode usar o mecanismo de lembrete neste link: Recuperar senha

Você receberá um link de reativação no email cadastrado.

Não recebeu o email? Lembre-se checar o Lixo Eletrônico.

Erro 35602

Fórum para dúvidas gerais sobre programação Web
ThiagoN
Acabou de chegar
Acabou de chegar
Mensagens: 1
Registrado em: Qui Abr 10, 2014 6:18 pm

Erro 35602

Mensagem por ThiagoN » Qui Abr 10, 2014 9:57 pm

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



Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder