Ir ao conteúdo
  • Cadastre-se

Ajuda trocar Listview por Listbox


Ir à solução Resolvido por COMPRADOR,

Posts recomendados

boa tarde

 

tenho o código abaixo que está dando certinho. Contudo alguns computadores não estão aceitando listview. Queria então trocar a listview2 por uma listbox1.

Poderiam me ajudar na adaptação do código?

Tentei mas to meio que boiando e não deu certo.

Se puderem ajudar agradeço.

 

código com listview:

Dim wbCadastro As WorkbookDim wsCadastro As Worksheet'Desenvolvido por Renam Fernando Ruthes'Canal Lógica VBA - YouTube'email: [email protected] Sub btn_filtro_Click()Me.ListView2.Height = 210Me.ListView2.Top = 150Me.CmbRegional = ""ThisWorkbook.Sheets("Filtro").SelectThisWorkbook.Sheets("Filtro").Cells(2, 1) = ""Call limpaCall copiaMe.CmbRegional.SetFocusEnd SubPrivate Sub btnCancelar_Click()Unload MefrmCadastro.ShowEnd SubPrivate Sub CmbRegional_Change()   'Muda a cor se tiver conteúdoIf Me.CmbRegional = "" ThenCmbRegional.BackColor = &HFFFFFFElseCmbRegional.BackColor = &H80C0FFEnd IfSheets("Filtro").SelectRange("a2") = Me.CmbRegionalCall pesquisaCall listaCall AtualizaFicha'lbl_registros = Me.ListView2.ListItems.CountEnd SubSub lista()ListView2.ListItems.Clearlbl_registros = ""'Adiciona os dados a listview2ThisWorkbook.Sheets("Filtro").Select lin = 5               Do Until ThisWorkbook.Sheets("Filtro").Cells(lin, 1) = ""                               If Cells(lin, 1).Rows.Hidden = False Then        Set li = ListView2.ListItems.Add(Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 88).Value) 'ENDEREÇO        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 89).Value 'CIDADE        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 90).Value 'TIPO        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 91).Value 'ÁREADISPONIVELMP        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 92).Value 'LOCAÇÃO MENSAL        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 93).Value 'VIGENCIA        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 94).Value 'MEMBROS                      End If               lin = lin + 1        Loop       'lbl_registros = Me.ListView2.ListItems.Count   End SubPrivate Sub CommandButton2_Click()Application.ScreenUpdating = FalseCall AtualizaFichaThisWorkbook.Sheets("FICHA REGIONAL").SelectRange("D2") = Me.CmbRegional               If CmbRegional = "" Then       End If       If Range("D2") = "" Then    'nada faz    Else    Range("a32").Select    Range(Selection, Selection.End(xlToRight)).Select    Range(Selection, Selection.End(xlDown)).Select    Selection.ClearContents    Range("a32").Select    End If       Range("a32").Select   Dim i As Integer, j As Integer        'Loop das linhas    For i = 1 To ListView2.ListItems.Count        Cells(i + 31, 1) = ListView2.ListItems(i).Text                    'Loop das colunas         For j = 1 To ListView2.ColumnHeaders.Count - 1            Cells(i + 31, j + 1) = ListView2.ListItems(i).ListSubItems(j).Text        Next j       Next i          Unload Me    frmFichaRegional.Show       Application.ScreenUpdating = TrueEnd SubPrivate Sub TextBox1_Change()End SubPrivate Sub UserForm_Initialize()   Application.ScreenUpdating = FalseCall DefinePlanilhaDadosCall copiaListView2.ListItems.Clear'configura o tamamanho inicial do form a altua da listview e sua posiçãoMe.ListView2.Height = 230Me.ListView2.Top = 150'  Adiciona as colunas a ListView2            With ListView2        .Gridlines = True        .View = lvwReport        .FullRowSelect = True        .ColumnHeaders.Add Text:="Endereço", Width:=200        .ColumnHeaders.Add Text:="Cidade", Width:=100        .ColumnHeaders.Add Text:="Tipo", Width:=60, Alignment:=2        .ColumnHeaders.Add Text:="Área Disponível MPSP, Width:=30, Alignment:=2"        .ColumnHeaders.Add Text:="Locação Mensal", Width:=60, Alignment:=2        .ColumnHeaders.Add Text:="Vigência", Width:=60, Alignment:=2        .ColumnHeaders.Add Text:="Membros", Width:=60, Alignment:=2         End WithListView2.ListItems.Clear'Adiciona os dados a listview2ThisWorkbook.Sheets("Filtro").Select lin = 5               Do Until ThisWorkbook.Sheets("Filtro").Cells(lin, 1) = ""        If Cells(lin, 1).Rows.Hidden = False Then                              Set li = ListView2.ListItems.Add(Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 88).Value) 'ENDEREÇO        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 89).Value 'CIDADE        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 90).Value 'TIPO        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 91).Value 'ÁREADISPONIVELMP        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 92).Value 'LOCAÇÃO MENSAL        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 93).Value 'VIGENCIA        li.ListSubItems.Add Text:=ThisWorkbook.Sheets("Filtro").Cells(lin, 94).Value 'MEMBROS                        End If               lin = lin + 1    Loop                    'lbl_registros = Me.ListView2.ListItems.Countlinha = 2Do Until ThisWorkbook.Sheets("REGISTRO REGIONAIS").Cells(linha, 2) = ""        CmbRegional.AddItem ThisWorkbook.Sheets("REGISTRO REGIONAIS").Cells(linha, 2)  '1 refere-se a 1ª coluna onde estão os dados ref. regional        linha = linha + 1Loop     Application.ScreenUpdating = TrueEnd SubPrivate Sub DefinePlanilhaDados()    Dim abrirArquivo As Boolean    Dim WB As Workbook    Dim caminhoCompleto As String    Dim ARQUIVO_DADOS As String    Dim PASTA_DADOS As String          abrirArquivo = True       ARQUIVO_DADOS = "BANCO DE DADOS ENGENHARIA.xlsm"          If ThisWorkbook.Name <> ARQUIVO_DADOS Then        'monta a string do caminho completo                    caminhoCompleto = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, vbNullString) & ARQUIVO_DADOS    End If               'verifica se o arquivo não está aberto        For Each WB In Application.Workbooks            If WB.Name = ARQUIVO_DADOS Then                abrirArquivo = False                Exit For            End If        Next               'atribui o arquivo        If abrirArquivo Then            Set wbCadastro = Workbooks.Open(FileName:=caminhoCompleto, ReadOnly:=True)        Else            Set wbCadastro = Workbooks("BANCO DE DADOS ENGENHARIA.xlsm")        End If            Set wsCadastro = wbCadastro.Worksheets("REGISTRO ENDEREÇOS")       'oculta o arquivo de dados    wbCadastro.Windows(1).Visible = False     End SubPrivate Sub limpa()    Worksheets("Filtro").Select    Range("a5").Select    Range(Selection, Selection.End(xlToRight)).Select    Range(Selection, Selection.End(xlDown)).Select    Selection.ClearContents    Range("a5").Select    On Error Resume Next      End SubPrivate Sub copia()    ThisWorkbook.Sheets("Filtro").Visible = True       Call limpa         Dim intervalo As Range    Dim intervalo2 As Range       wbCadastro.Activate    wbCadastro.Sheets("registro endereços").Select       Set intervalo = wbCadastro.Sheets("registro endereços").Range("a1:ci1000")       intervalo.Copy                  ThisWorkbook.Activate    Worksheets("Filtro").Select    Worksheets("Filtro").Range("A4").Select    Selection.PasteSpecial Paste:=xlPasteValues       Set intervalo2 = ActiveSheet.Range("a4:ci1000")    intervalo2.RemoveDuplicates Columns:=1, Header:=xlNo    '*** Copy the action Summary data from each original Action Plan ***End SubPrivate Sub pesquisa()    ThisWorkbook.Sheets("Filtro").Select    ThisWorkbook.Sheets("Filtro").Range("A4").Select    ThisWorkbook.Sheets("Filtro").Range("A4:CI1000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _    ("A1:B3"), CopyToRange:=Range("CJ4:Cp4"), Unique:=FalseEnd SubPrivate Sub AtualizarArquivo(ByVal ReadOnly As Boolean)  End SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)   Call AtualizarArquivo(True)             If CloseMode = vbFormControlMenu Then        Cancel = True        MsgBox "Favor clique no botão VOLTAR" _          , vbCritical _          , "Erro"    End If   End SubPrivate Sub AtualizaFicha()Sheets("FICHA REGIONAL").SelectRange("C2") = Me.CmbRegionalSheets("REGISTRO REGIONAIS").SelectRange("a1").SelectDim Rng As Range    Set Rng = Sheets("REGISTRO REGIONAIS").Cells.Find(What:=CmbRegional.Value, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)           If Not Rng Is Nothing Then       txtfoto.Value = Rng.Offset(, 1)         End If   Sheets("FICHA REGIONAL").SelectWith imgRegSheets("FICHA REGIONAL").imgReg.Picture = LoadPicture(ThisWorkbook.Path & "\FOTOS UNIDADES\" & txtfoto)Sheets("FICHA REGIONAL").imgReg.PictureSizeMode = fmPictureSizeModeStretchEnd With            Sheets("FICHA ENDEREÇO").Select           End Sub
Link para o comentário
Compartilhar em outros sites

  • Solução

oi consegui com o seguinte código: 

 

 
 
'Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel
'Autor: Tomás Vásquez
'março de 2008
 
Option Explicit
 
 
Const colENDEREÇO As Integer = 2
Const colCIDADE As Integer = 3
Const colREGIONAL As Integer = 4
Const colTIPO As Integer = 6
Const colÁREA_DISPONÍVEL_MP As Integer = 17
Const colLOCAÇÃO_MENSAL As Integer = 19
Const colVIGÊNCIA As Integer = 20
Const colMEMBRO As Integer = 34
Const COLSITUAÇÃO As Integer = 42
 
Const indiceMinimo As Byte = 2
Const corDisabledTextBox As Long = -2147483633
Const corEnabledTextBox As Long = -2147483643
 
 
Private wsCadastro As Worksheet
Private wbCadastro As Workbook
Private valor_pesquisado As String
 
 
Private Sub btnCancelar_Click()
    
 Unload Me
 frmCadastro.Show
    End Sub
 
 
Private Sub frmRegistro_Click()
 
End Sub
 
Private Sub ListBox1_Click()
 
End Sub
 
Private Sub TxtRegional_Change()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
valor_pesquisado = TxtRegional.Text
 
Call CarregaDadosInicial
Call AtualizaFicha
Call EnviarExcel
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub
 
Private Sub UserForm_Initialize()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
 
    Call DefinePlanilhaDados
 
    Call Limpa
    
    Call CarregaDadosInicial
    
    Call EnviarExcel
      
    TxtRegional.SetFocus
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
 
Private Sub CarregaDadosInicial()
 
 
     Dim linha As Integer
    Dim coluna As Integer
    Dim linhalistbox As Integer
    Dim valor_celula As String
    Dim conta_registros As Integer
    
  
    linha = 2
    coluna = 4 'coluna da busca na planilha
    linhalistbox = 0
    conta_registros = 0
    
    ListBox1.Clear
    
    With wsCadastro
        While .Cells(linha, coluna).Value <> Empty
            valor_celula = .Cells(linha, coluna).Value
            
            If UCase(Left(valor_celula, Len(valor_pesquisado))) = UCase(valor_pesquisado) Then
                
             With ListBox1
             
             ListBox1.ColumnWidths = "500;120;120;80;80;80;80;60;60"
             .AddItem
                .List(linhalistbox, 0) = wsCadastro.Cells(linha, 2)
                .List(linhalistbox, 1) = wsCadastro.Cells(linha, 3)
                .List(linhalistbox, 2) = wsCadastro.Cells(linha, 4)
                .List(linhalistbox, 3) = wsCadastro.Cells(linha, 6)
                .List(linhalistbox, 4) = wsCadastro.Cells(linha, 17)
                .List(linhalistbox, 5) = Format(wsCadastro.Cells(linha, 19), "R$ #.###,##")
                .List(linhalistbox, 6) = Format(wsCadastro.Cells(linha, 20), "dd/mm/yyyy")
                .List(linhalistbox, 7) = wsCadastro.Cells(linha, 34)
                .List(linhalistbox, 8) = wsCadastro.Cells(linha, 42)
 
             linhalistbox = linhalistbox + 1
             conta_registros = conta_registros + 1
             End With
                
            End If
            linha = linha + 1
        Wend
    End With
    
If ListBox1.ListCount > 0 Then
lbl_registros = ListBox1.ListCount - 1
Else
lbl_registros = "0"
End If
    
End Sub
 
 
 
 
Private Sub DefinePlanilhaDados()
    Dim abrirArquivo As Boolean
    Dim WB As Workbook
    Dim caminhoCompleto As String
    Dim ARQUIVO_DADOS As String
    Dim PASTA_DADOS As String
       
    abrirArquivo = True
    
    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
        
        'verifica se o arquivo não está aberto
        For Each WB In Application.Workbooks
            If WB.Name = ARQUIVO_DADOS Then
                abrirArquivo = False
                Exit For
            End If
        Next
        
        'atribui o arquivo
        If abrirArquivo Then
            Set wbCadastro = Workbooks.Open(FileName:=caminhoCompleto, ReadOnly:=True)
        Else
            Set wbCadastro = Workbooks(ARQUIVO_DADOS)
        End If
    Else
        Set wbCadastro = ThisWorkbook
    End If
    
    Set wsCadastro = wbCadastro.Worksheets("REGISTRO ENDEREÇOS")
    
    'oculta o arquivo de dados
    wbCadastro.Windows(1).Visible = False
    
   
    
End Sub
 
Private Sub CommandButton2_Click()
 
   If TxtRegional = "" Then
   Exit Sub
   Else
            Call AtualizaFicha
            Sheets("FICHA REGIONAL").Select
            frmFichaRegional.Show
   End If
End Sub
 
 
Private Sub AtualizaFicha()
 
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
 
Sheets("FICHA REGIONAL").Select
Range("C2") = Me.TxtRegional
 
Sheets("REGISTRO REGIONAIS").Select
Range("a1").Select
 
 
Dim Rng As Range
 
    Set Rng = Sheets("REGISTRO REGIONAIS").Cells.Find(What:=TxtRegional.Value, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        
    If Not Rng Is Nothing Then
 
Sheets("FICHA REGIONAL").Select
  
Sheets("FICHA REGIONAL").imgReg.Picture = LoadPicture(ThisWorkbook.Path & "\FOTOS UNIDADES\" & Rng.Offset(, 1))
Sheets("FICHA REGIONAL").imgReg.PictureSizeMode = fmPictureSizeModeStretch
 
 
           
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
            
End If
 
End Sub
 
Private Sub EnviarExcel()
 
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
'cria varíavel para contagem da linha a ser preenchida
Dim Nlin As Integer
'cria uma variável para contar as linhas da listbox
Dim Cont As Integer
 
'limpa a região com dados anteriores
Worksheets("FICHA REGIONAL").Range("A32:I1000").ClearContents
 
'linha inicial da planilha que carregará os dados
Nlin = 31
 
'preenche as outras linhas até o fim da listbox
For Cont = 0 To Me.ListBox1.ListCount - 1
Worksheets("FICHA REGIONAL").Range("A" & Nlin + 1) = Me.ListBox1.List(Cont, 0)
Worksheets("FICHA REGIONAL").Range("B" & Nlin + 1) = Me.ListBox1.List(Cont, 1)
Worksheets("FICHA REGIONAL").Range("C" & Nlin + 1) = Me.ListBox1.List(Cont, 2)
Worksheets("FICHA REGIONAL").Range("D" & Nlin + 1) = Me.ListBox1.List(Cont, 3)
Worksheets("FICHA REGIONAL").Range("E" & Nlin + 1) = Me.ListBox1.List(Cont, 4)
Worksheets("FICHA REGIONAL").Range("F" & Nlin + 1) = Format(Me.ListBox1.List(Cont, 5), "R$ #.###,##")
Worksheets("FICHA REGIONAL").Range("G" & Nlin + 1) = Format(Me.ListBox1.List(Cont, 6), "dd/mm/yyyy")
Worksheets("FICHA REGIONAL").Range("H" & Nlin + 1) = Me.ListBox1.List(Cont, 7)
Worksheets("FICHA REGIONAL").Range("I" & Nlin + 1) = Me.ListBox1.List(Cont, 8)
 
 
Nlin = Nlin + 1
Next
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
 
Sub Limpa()
 
    Worksheets("FICHA REGIONAL").Select
    Range("a32").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("a32").Select
 
    On Error Resume Next
    
 
End Sub
 
 
Valeu a todos pela ajuda, e fica o código que consegui se alguém precisar.
Obrigada
Link para o comentário
Compartilhar em outros sites

  • 2 meses depois...

Bom dia,preciso de ajuda para modificar 3 códigos que foram feitos para Listview.Preciso que me ajudem a modefica-los para Listbox devido ao listview não ter suporte ao office 64bits.Espero que possam me ajudar,segue abaixo os códigos

 

1º codigo

 

 

Private Sub carregar_DblClick()
 
 
 
    Dim Buscar As Long
    
    Buscar = CLng(lstvFiltro.SelectedItem.ListSubItems(1).Text)
    SqlOrçDet = "SELECT * FROM tbOrç_Detalhe WHERE Nro_Orçamento = " & Buscar
    SqlOrçGrad = "SELECT * FROM tbOrçamento_Grade WHERE Nro_Orçamento = " & Buscar
    
    rsOrçDet.Close
    rsOrçGrad.Close
    
    rsOrçDet.Open SqlOrçDet, cn, adOpenKeyset, adLockOptimistic
    rsOrçGrad.Open SqlOrçGrad, cn, adOpenKeyset, adLockOptimistic
    
    With frmOrçamento
        .txtNome = rsOrçDet("Nome_Cli")
        If rsOrçDet("Acresc_Desc") = 1 Then
        Else
        End If
        
        With .lstvOrç
        .ListItems.Clear
        For i = 1 To rsOrçGrad.RecordCount
        
            On Error Resume Next
            .ListItems.Add 1, , Format(rsOrçGrad(1), "0")
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 1, , rsOrçGrad(2)
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 2, , Format(rsOrçGrad(3), "")
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 3, , Format(rsOrçGrad(4), "") 'codigo
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 4, , Format(rsOrçGrad(5), "")
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 5, , Format(rsOrçGrad(6), "")
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 6, , Format(rsOrçGrad(7), "")
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 7, , Format(rsOrçGrad(8), "")
            On Error Resume Next
            .ListItems(1).ListSubItems(7).Bold = True
            On Error Resume Next
            rsOrçGrad.MoveNext
            
        Next i
        
        End With
        
        .CalcTotal
        .btnNovo.Enabled = True
        .btnGravar.Enabled = True
        .CommandButton2.Enabled = True
        .btnExcluir.Enabled = True
        NroOrç = rsOrçDet("Nro_Orçamento")
        
    End With
    
    Inc = False
 
    Buscar = CLng(lstvFiltro.SelectedItem.ListSubItems(1).Text)
    SqlOrçDet = "SELECT * FROM tbOrç_Detalhe WHERE Nro_Orçamento = " & Buscar
    SqlOrçGrad = "SELECT * FROM tbOrçamento_Grade WHERE Nro_Orçamento = " & Buscar
    
    rsOrçDet.Close
    rsOrçGrad.Close
    
    rsOrçDet.Open SqlOrçDet, cn, adOpenKeyset, adLockOptimistic
    rsOrçGrad.Open SqlOrçGrad, cn, adOpenKeyset, adLockOptimistic
    
    With frmOrçamento
        .txtNome = rsOrçDet("Nome_Cli")
        If rsOrçDet("Acresc_Desc") = 1 Then
        Else
        End If
        
        With .ListView1
        .ListItems.Clear
        For i = 1 To rsOrçGrad.RecordCount
        
            On Error Resume Next
            .ListItems.Add 1, , Format(rsOrçGrad(1), "0") 'Auxiliar
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 1, , rsOrçGrad(3) 'Quantidade
            On Error Resume Next
            .ListItems(1).ListSubItems.Add 2, , Format(rsOrçGrad(5), "")
            On Error Resume Next
            rsOrçGrad.MoveNext
            
        Next i
        
        End With
        
        .CalcTotal
        .btnNovo.Enabled = True
        .btnGravar.Enabled = True
        NroOrç = rsOrçDet("Nro_Orçamento")
        
    End With
    Inc = False
    Unload Me
    
 
    
End Sub
 
 
2º Código
 
 
Sub carregar()
    
    With Me.lstvFiltro
    
        .ListItems.Clear
        If rsOrçDet.RecordCount > 0 Then
            rsOrçDet.MoveFirst
            For i = 1 To rsOrçDet.RecordCount
                .ListItems.Add 1, , Format(rsOrçDet("Data"), "dd/mm/yyyy")
                .ListItems(1).ListSubItems.Add 1, , Format(rsOrçDet("Nro_Orçamento"), "0,00")
                .ListItems(1).ListSubItems.Add 2, , rsOrçDet("Nome_Cli")
                .ListItems(1).ListSubItems.Add 3, , Format(rsOrçDet("Total_Liquido"), "currency")
                rsOrçDet.MoveNext
                
            Next i
            
        End If
        
    End With
    
       Me.lblReg.Caption = " Registros Encontrados: " & Format(rsOrçDet.RecordCount, "0,00")
       
End Sub
 
 
 
3º Código
 
 
Private Sub btnGravar_Click()
 
Dim i As Integer
 
    If Me.txtNome = Empty Then
        MsgBox "Digite um nome para esse Detalhamento.", vbExclamation, "Atenção"
        Me.txtNome.SetFocus
        Exit Sub
    End If
    If Not Me.lstvOrç.ListItems.Count > 0 Then
        MsgBox "É necessário incluir pelo menos um Item na Lista" & Chr(13) _
            & ".", vbExclamation, ""
            Me.txtPreTotal.SetFocus
            Exit Sub
    End If
    
        If Inc = True Then
            rsOrçDet.AddNew
        Else
            rsOrçGrad.Close
            SqlOrçGrad = "DELETE FROM tbOrçamento_Grade WHERE Nro_Orçamento = " & NroOrç 'Apaga os registros antigos
            rsOrçGrad.Open SqlOrçGrad, cn, adOpenKeyset, adLockOptimistic               'pra incluir os dados atualizados
           
            SqlOrçGrad = "SELECT * FROM tbOrçamento_Grade"
            rsOrçGrad.Open SqlOrçGrad, cn, adOpenKeyset, adLockOptimistic
            
        End If
        
        rsOrçDet(1) = Date
        rsOrçDet(2) = Me.txtNome
        rsOrçDet(3) = 1
        rsOrçDet(3) = 3
        rsOrçDet(4) = 0
        rsOrçDet(5) = 0
        rsOrçDet.Update
        
        For i = 1 To Me.lstvOrç.ListItems.Count
            With Me.lstvOrç
                rsOrçGrad.AddNew
                rsOrçGrad(0) = NroOrç
                rsOrçGrad(1) = .ListItems(1)
                rsOrçGrad(2) = .ListItems(i).ListSubItems(1)
                rsOrçGrad(3) = CDbl(.ListItems(i).ListSubItems(2))
                rsOrçGrad(4) = CDbl(.ListItems(i).ListSubItems(3))
                On Error Resume Next
                rsOrçGrad(5) = CDbl(.ListItems(i).ListSubItems(4))
                rsOrçGrad.Update
            End With
        Next i
        If Inc = True Then
            rsNro.AddNew
            rsNro(0) = NroOrç
            rsNro.Update
        End If
        
        Inc = False
        LimpaControles
        rsNro.MoveLast
        NroOrç = rsNro(0).Value + 1
         iCancel = 0
 
        
End Sub
 
 
 
Aguardo Retono.
 
Link para o comentário
Compartilhar em outros sites

Visitante
Este tópico está impedido de receber novas respostas.

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...