Ir ao conteúdo
  • Cadastre-se
COMPRADOR

RESOLVIDO Ajuda trocar Listview por Listbox

Recommended Posts

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: logicavba@gmail.comPrivate 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

Compartilhar este post


Link para o post
Compartilhar em outros sites

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

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.
 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações 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

×