none
como imprimir listview com vba RRS feed

  • Pergunta

  • tenho o seguinte formulário e quero imprimir o conteúdo da listview e da caixa de testo que contem o valor total


    Private Sub CmdCapitarInforma_Click()
    If ChbAvista.Value = "" Then
    End If
       TextBox25 = TxtValordoPedido()
    End Sub

    Private Sub Cmd_Orssamento_Click()
    ThisWorkbook.Worksheets("Produtos").Activate
        Range("B3").Select
         For cont = 1 To 100
       If ActiveCell = TxtNomedoProduto.Text Then
        ActiveCell.Offset(0, 1).Value = TxtNomedoProduto.Value
        ActiveCell.Value = TxtNomedoProduto.Value
        ActiveCell.Offset(0, 10).Value = TextQuant.Value
        End If
        ActiveCell.Offset(1, 0).Activate
       Next
           Range("B3").Select
    End Sub

    Private Sub Cmd_Vender_Click()
    'Ativar a primeira planilha
            ThisWorkbook.Worksheets("Porcetagen").Activate
                    'Selecionar a célula A3
                
                  Range("B2:B2").Select
                    'ProcurAr a primeira célula vazia
                Do
                If Not (IsEmpty(ActiveCell)) Then
                    ActiveCell.Offset(1, 0).Select
                     ActiveCell.Offset = Empty
                End If
            Loop Until IsEmpty(ActiveCell) = True
                    
                   'Carregar os dados digitados nas caixas de texto para a planilha
                ActiveCell.Offset(0, 0).Value = lbltotal.Caption
                ActiveCell.Value = lbltotal.Caption
                
     ActiveWorkbook.Save
     Frm_Vendas.Show
      ListPreco.Clear
          LtQuantDescricao.Clear
          LtValorUnitario.Clear
          lbltotal = Empty
    End Sub




    Private Sub CmdCalcular_Click()
    CmdCalcular.BackColor = &HE0E0E0
    CmdCarrinho.BackColor = &HFF00&
      If TxtValorDoProduto.Text = "" Then
            MsgBox "É necessario fazer uma pesquisa e digitar a quantidade!", vbInformation, "Tela de boas vindas"
            TxtNomedoProduto.SetFocus
            Exit Sub
        End If
        
        If CDbl(TextQuant.Text) <= CDbl(TxtQuantidadeEmEStoque.Text) Then 'verificando a quantidade em estoque
            TxtValorTotalUnt.Text = Format(CDbl(TxtValorDoProduto.Text) * CDbl(TextQuant.Text), "  #,##.00") ' QUANDO FOR MOEDA )
        Else
            MsgBox "Quantidade vendida maior que a quantidade em estoque!", vbInformation, "Tela de boas vindas"
            TextQuant.SetFocus 'campo quantidade recebe o focu
            TextQuant.SelStart = 0 'defifinindo o inicio da seleção
            TextQuant.SelLength = Trim(TxtValorDoProduto.Text) 'seleciona todo o conteudo do campo eliminando espacos em branco
            Exit Sub
        End If
    TxtValorTotalUnt.Text = Format(CDbl(TxtValorDoProduto.Text) * CDbl(TextQuant.Text), "  #,##.00") ' QUANDO FOR MOEDA )
       Call Destravar.carrinho
    End Sub

    Private Sub CmdCarrinho_Click()
    Call Atualizar
    Call soma
     CmdCarrinho.Visible = False
    End Sub

    Private Sub CmdLiberar_Click()
    Call Destravar.Destravar
        If CmdLiberar.Caption = "Liberar" Then
            CmdLiberar.Caption = "Bloquear"
            
        Else
            CmdLiberar.Caption = "Liberar"
            Call Travar.Trancar
        End If
    End Sub

    Private Sub CmdLimpaarr_Click()
          'ListPreco.Clear
          'LtQuantDescricao.Clear
          'LtValorUnitario.Clear
          'lbltotal = Empty
    End Sub
            

    Private Sub CmdLimparr_Click()
        TxtVenderCpfDoCliente.Value = Empty
        TxtValordoPedido.Value = Empty
        LblTotalDoPedido.Caption = Empty
        End Sub

    Private Sub CmdLiparFrmProdutos_Click()
    TxtNomedoProduto = Empty
    End Sub





    Private Sub CmdSAIR_Click()
        Unload Me
    End Sub

    Private Sub CmdSomar_Click()
            Dim total As Double ''Cria uma variavel do tipo dublu
            For x = 0 To ListPreco.ListCount - 1 ''Faz um loop de 0 ate
              ''(Quantidade de inens -1
            total = total + ListPreco.List(x, 0) '' incrementa total a cadaloop
            Next
            TxtSomar = CStr(total) '' Mostra o total no label22
            
            TxtSomar.TextAlign = Format(TxtSomar.TextAlign, "#,##.00") ' QUANDO FOR MOEDA )
    End Sub

    Private Sub CmdPpesquizar_Click()
    Txt_Cod_do_Produto.SpecialEffect = fmSpecialEffectEtched
    'Verificar se foi digitado um nome na primeira caixa de texto
            If ComboBox1.Text = "" Then
                     MsgBox "Digite o Nome do produto!"
                ComboBox1.SetFocus
                 Call Destravar.TextQuant
                   GoTo linha1
             Else
                Call Destravar.liberar1
                
                Call Destravar.CmdLiberar
                Call Destravar.TextQuant
            End If
    With Worksheets("Produtos").Range("B:B")
            Set c = .Find(ComboBox1.Value, LookIn:=xlValues, _
            LookAt:=xlPart)
        If Not c Is Nothing Then
                TxtNomedoProduto.Value = c.Value
                TxtMarcadoProduto.Value = c.Offset(0, 1).Value
                TxtReferenciadoproduto.Value = c.Offset(0, 2).Value
                TxtMarcadoCarro.Value = c.Offset(0, 3).Value
                TxtNomedoCarro.Value = c.Offset(0, 4).Value
                TxtNumerodapratileira.Value = c.Offset(0, 5).Value
                TxtNumerodaGaveta.Value = c.Offset(0, 6).Value
                TxtValorDoProduto.Value = c.Offset(0, 7).Value
                TxtQuantidadeEmEStoque.Value = c.Offset(0, 9).Value
                Txt_Cod_do_Produto.Value = c.Offset(0, 11).Value

           End If
            End With
    linha1:
    End Sub

    Private Sub CmdSairFrmProdutos_Click()
         If MsgBox("Deseja relmente sair do sistema?", vbExclamation + vbYesNo, "Alerta") = vbYes Then
           Unload Me
           Else
          Exit Sub
        End If
    End Sub
            
        
    Private Sub CmdLimpar_Click()
       'Limpar as caixas de texto
           
    End Sub

    Private Sub CmdLimpaar_Click()
            'Limpar as caixas de texto
            TxtDPF.Value = Empty
            TextBox20.Value = Empty
            TextBox21.Value = Empty
            TxtValordoPedido.Value = Empty
            TextBox22.Value = Empty
    End Sub

    Private Sub Label10_Change()
        Label10 = Format(Date & "")
    End Sub



    Private Sub CmdTeste_Click()

    'Verificar se foi digitado um nome na primeira caixa de texto
            If TxtTeste.Text = "" Then
                 MsgBox "Digite o Nome do produto"
            ComboBox1.SetFocus
            GoTo linha1
            End If
     With Worksheets("Produtos").Range("A:A")
            Set c = .Find(ComboBox1.Value, LookIn:=xlValues, _
            LookAt:=xlPart)
        
        If Not c Is Nothing Then
                
               ComboBox1.Value = c.Value
                TxtTeste.Value = c.Offset(0, 1).Value
         End If
            End With
    linha1:
    End Sub

    Private Sub TxtSomaTotal_Change()
     TxtSomaTotal = ListPreco()
    End Sub



    Private Sub ComboBox1_Enter()
    If ComboBox1.BackColor = &H80000005 Then
    ComboBox1.BackColor = &HC0FFFF
    ElseIf ComboBox1.BackColor = &HC0FFFF Then
    ComboBox1.BackColor = &H80000006
    ComboBox1.ForeColor = &H80000005
    ElseIf ComboBox1.BackColor = &H80000006 Then
    ComboBox1.BackColor = &H80000005
    ComboBox1.ForeColor = &H80000008
    End If
    With Me.ComboBox1
            .Clear    ' limpa o conteúdo do listbox
           MyUniqueList = UniqueItemList(Worksheets("Produtos").Range("B3:B30000"), True)
            For i = 1 To UBound(MyUniqueList)
                .AddItem MyUniqueList(i)
            Next i
            .ListIndex = 0    ' seleciona o primeiro item
        End With
    End Sub


    Private Sub ButonAtualizar_Click()
        Dim MyUniqueList As Variant, i As Long
        With Me.ListBox1
            .Clear    ' limpa o conteúdo do listbox
            
            MyUniqueList = UniqueItemList(Worksheets("Produtos").Range("A1:A30000"), True)
            For i = 1 To UBound(MyUniqueList)
                .AddItem MyUniqueList(i)
            Next i
            .ListIndex = 0    ' seleciona o primeiro item
        End With
      
         'listbox2
        With Me.ListBox2
            .Clear    ' limpa o conteúdo do listbox
            MyUniqueList = UniqueItemList(Worksheets("Produtos").Range("H1:H30000"), True)
            For i = 1 To UBound(MyUniqueList)
                .AddItem MyUniqueList(i)
            Next i
            .ListIndex = 0    ' seleciona o primeiro item
        End With
    End Sub

    Private Sub CmdAtualizarr_Click()
     Dim MyUniqueList As Variant, i As Long
        With Me.ListBox1
            .Clear    ' limpa o conteúdo do listbox
            
            MyUniqueList = UniqueItemList(Worksheets("Produtos").Range("B1:B30000"), True)
            For i = 1 To UBound(MyUniqueList)
                .AddItem MyUniqueList(i)
            Next i
            .ListIndex = 0    ' seleciona o primeiro item
        End With
      
         'listbox2
        With Me.ListBox2
            .Clear    ' limpa o conteúdo do listbox
            MyUniqueList = UniqueItemList(Worksheets("Produtos").Range("I1:I30000"), True)
            For i = 1 To UBound(MyUniqueList)
                .AddItem MyUniqueList(i)
            Next i
            .ListIndex = 0    ' seleciona o primeiro item
            
            
        End With
    End Sub



    Private Sub CommandButton13_Click()
       If vsFlexArray1.Value = selecte Then
       FixedRows = ""
       End If
    End Sub


    Private Sub CommandButton14_Click()
    Frm_Cancelar_Item.Show
    End Sub

    Private Sub Label31_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
       If TxtValordoPedido = "" Then
       TxtValordoPedido = 0
       Else
       Label31 = TxtValordoPedido.Text + TxtAcresimo.Text
       End If
       Label31 = Format(Label31, "#,##.00") ' QUANDO FOR MOEDA )
    End Sub

    Private Sub TextBox23_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    If ComboBox1 = "" Then
    Exit Sub
    Else
    TextBox23 = ComboBox1
    End If
    End Sub




    Private Sub TxtAcresimo_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    TxtAcresimo.Text = "200%"
    TxtAcresimo.Locked = True
    End Sub

    Private Sub TxtDesconto_Change()
    TxtDesconto.Text = Format(TxtDesconto.Text, "#,##.00") ' QUANDO FOR MOEDA )
    TxtDesconto.Text = "5%"
    End Sub

    Private Sub TextBox21_Change()
    TextBox21.Text = Format(TextBox21.Text, "#,##.00") ' QUANDO FOR MOEDA )
    End Sub

    Private Sub TextBox22_Change()
    TextBox22.Text = Format(TextBox22.Text, "#,##.00") ' QUANDO FOR MOEDA )
    End Sub






    Private Sub FrameCADASTRODePRODUTOS_Click()

    End Sub

    Private Sub CommandButton21_Click()
    'Verificar se foi digitado um nome na primeira caixa de texto
            If ComboBox2.Text = "" Then
                     MsgBox "Digite o Nome do produto!"
                ComboBox2.SetFocus
                 Call Destravar.TextQuant
                   GoTo linha1
             Else
                Call Destravar.liberar1
                
                Call Destravar.CmdLiberar
                Call Destravar.TextQuant
            End If
    With Worksheets("Produtos").Range("B:B")
            Set c = .Find(ComboBox1.Value, LookIn:=xlValues, _
            LookAt:=xlPart)
        If Not c Is Nothing Then
                TxtNomedoProduto.Value = c.Value
                TxtMarcadoProduto.Value = c.Offset(0, 1).Value
                TxtReferenciadoproduto.Value = c.Offset(0, 2).Value
                TxtMarcadoCarro.Value = c.Offset(0, 3).Value
                TxtNomedoCarro.Value = c.Offset(0, 4).Value
                TxtNumerodapratileira.Value = c.Offset(0, 5).Value
                TxtNumerodaGaveta.Value = c.Offset(0, 6).Value
                TxtValorDoProduto.Value = c.Offset(0, 7).Value
                TxtQuantidadeEmEStoque.Value = c.Offset(0, 9).Value
                Txt_Cod_do_Produto.Value = c.Offset(0, 11).Value

           End If
            End With
    linha1:

    End Sub

    Private Sub TextBox8_Change()
    TextBox8.Text = Format(TextBox8.Text, "#,##.00") ' QUANDO FOR MOEDA )
    End Sub

    Private Sub CommandButton15_Click()
    Call Pesquizar
    End Sub


    Private Sub CommandButton17_Click()
    ListView1.SelectedItem = ""
    ListView1.SelectedItem.SubItems(1) = ""
     ListView1.SelectedItem.SubItems(2) = ""
     ListView1.SelectedItem.SubItems(3) = ""
     ListView1.SelectedItem.SubItems(4) = ""
     ListView1.SelectedItem.SubItems(5) = ""
     ListView1.SelectedItem.SubItems(6) = ""
     ListView1.SelectedItem.SubItems(7) = ""
     ListView1.SelectedItem.SubItems(8) = ""
     ListView1.SelectedItem.SubItems(9) = ""
     ListView1.ControlTipText = 0
     
    End Sub

    Private Sub Frame1_Click()

    End Sub



    Private Sub TextQuant_Enter()
    Call Destravar.CmdCalcular
    CmdCalcular.BackColor = &HC0FF00
    End Sub

    Private Sub TxtValordoPedido_Change()
    TxtValordoPedido.Text = Format(TxtValordoPedido.Text, "#,##.00") ' QUANDO FOR MOEDA )
    End Sub

    Private Sub TxtValorDoProduto_Change()
    TxtValorDoProduto.Text = Format(TxtValorDoProduto.Text, "#,##.00") ' QUANDO FOR MOEDA )
    End Sub
    'ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
    Private Sub Pesquizar()
            If Txt_Cod_do_Produto = "" Then
                     MsgBox "Digite o Nome do produto!"
                Txt_Cod_do_Produto.SetFocus
                 Call Destravar.TextQuant
                   GoTo linha1
             Else
                Call Destravar.liberar1
                Call Destravar.CmdLiberar
                Call Destravar.TextQuant
            End If
    With Worksheets("Produtos").Range("A:A")
            Set c = .Find(Txt_Cod_do_Produto.Value, LookIn:=xlValues, _
            LookAt:=xlPart)
        If Not c Is Nothing Then
                'TxtNomedoProduto.Value = c.Value
                TxtNomedoProduto.Value = c.Offset(0, 1).Value
                TxtMarcadoProduto.Value = c.Offset(0, 2).Value
                TxtReferenciadoproduto.Value = c.Offset(0, 3).Value
                TxtMarcadoCarro.Value = c.Offset(0, 4).Value
                TxtNomedoCarro.Value = c.Offset(0, 5).Value
                TxtNumerodapratileira.Value = c.Offset(0, 6).Value
                TxtNumerodaGaveta.Value = c.Offset(0, 7).Value
                TxtValorDoProduto.Value = c.Offset(0, 8).Value
                TxtQuantidadeEmEStoque.Value = c.Offset(0, 10).Value
                Txt_Cod_do_Produto.Value = c.Offset(0, 12).Value

           End If
           End With
    linha1:
    'ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
    End Sub

    Private Sub UserForm_Activate()
     Call ListView
    Call Travar.Trancar
    ComboBox1 = "Clique aqui para pesquisar"
    Label10 = Format(Now, "Long Date") & " - " & Right(Now(), 8)


        End Sub
    'ilicializa ListView1

    Private Sub ListView()

    With ListView1
    .Gridlines = True
    .View = lvwReport
    .FullRowSelect = True

    .ColumnHeaders.Add Index:=1, Text:="COD", Width:=30
    .ColumnHeaders.Add Index:=2, Text:="Nome", Width:=100
    .ColumnHeaders.Add Index:=3, Text:="Marca", Width:=55
    .ColumnHeaders.Add Index:=4, Text:="REF", Width:=50
    .ColumnHeaders.Add Index:=5, Text:="Mar do Carro", Width:=50
    .ColumnHeaders.Add Index:=6, Text:="Nome do Carro", Width:=50
    .ColumnHeaders.Add Index:=7, Text:="Nº da pratileira", Width:=50
    .ColumnHeaders.Add Index:=8, Text:="Nº da gaveta", Width:=50
    .ColumnHeaders.Add Index:=9, Text:="Valor do Untario", Width:=100
    .ColumnHeaders.Add Index:=10, Text:="Q_Em estoque", Width:=70
    .ColumnHeaders.Add Index:=11, Text:="Valor total", Width:=70

    End With
    End Sub

    Sub Atualizar()
    Dim Item As ListItem
    Dim linhafinal As Integer
    Dim i As Integer

    'ListView1.ListItems.Clear
    'LinhaFinal = 1 'Plan1.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 1 To 1
     Set Item = ListView1.ListItems.Add(Text:=Txt_Cod_do_Produto.Text)   '(Text:=Plan1.Cells(i, 1))
      Item.SubItems(1) = TxtNomedoProduto.Text
      Item.SubItems(2) = TxtMarcadoProduto.Text
      Item.SubItems(3) = TxtReferenciadoproduto.Text 'Plan1.Cells(i, 4)
      Item.SubItems(4) = TxtMarcadoCarro.Text 'Plan1.Cells(i, 4) - (DateValue(Now))
      Item.SubItems(5) = TxtNomedoCarro.Text 'Plan1.Cells(i, 5)
      Item.SubItems(6) = TxtNumerodapratileira.Text 'Plan1.Cells(i, 5)
      Item.SubItems(7) = TxtNumerodaGaveta.Text 'Plan1.Cells(i, 5)
      Item.SubItems(8) = TxtValorDoProduto 'Plan1.Cells(i, 5)
      Item.SubItems(9) = TxtQuantidadeEmEStoque.Text 'Plan1.Cells(i, 5)
      Item.SubItems(10) = TxtValorTotalUnt.Text 'Plan1.Cells(i, 5)
    Next
      'finaliza ListView1
    End Sub
    Sub soma()
        Dim i As Integer
           
           i = TxtValorTotalUnt
        If Txt_total.Text = "" Then
           Txt_total = TxtValorTotalUnt
        ElseIf Txt_total.Text = Txt_total.Text Then
           Txt_total.Text = Txt_total.Text + i / 1
         End If
             Txt_total.Text = Format(Txt_total.Text, "#,##.00")

    End Sub
     
    Private Function UniqueItemList(InputRange As Range, _
         HorizontalList As Boolean) As Variant
          Dim cl As Range, cUnique As New Collection, i As Long, uList() As Variant
            Application.Volatile
          On Error Resume Next
          For Each cl In InputRange
                If cl.Formula <> "" Then
                    cUnique.Add cl.Value, CStr(cl.Value)
                End If
            Next cl
            UniqueItemList = ""
            If cUnique.Count > 0 Then
                ReDim uList(1 To cUnique.Count)
                For i = 1 To cUnique.Count
                    uList(i) = cUnique(i)
                Next i
                UniqueItemList = uList
                If Not HorizontalList Then
                    UniqueItemList = _
                    Application.WorksheetFunction.Transpose(UniqueItemList)
                End If
            End If
            On Error GoTo 0
       
    End Function
    'Fecha listbox


    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
      If CloseMode = vbFrmLogin - ControlMenu Then
    Cancel = True
    MsgBox "Deseja relmente sair do sistema? Cliqui em sair", vbCritical, "Erro"
    End If
    End Sub




    terça-feira, 4 de fevereiro de 2014 18:43

Todas as Respostas