Notifications
Clear all
2024 - VBA & Macros
16
Posts
4
Usuários
0
Reactions
3,831
Visualizações
Topic starter
Pessoal,
Tenho um sistema de Controle de Despesas Pessoais que, por sinal, fiz até uma gravação dele e disponibilizei aqui no planilhando.com.
Ele cumpre o que promete! Mas eu ainda não posso disponibilizá-lo, pois, inexplicavelmente, o mesmo apresenta erro ao ser fechado.
Eu já abri um fórum sobre isso, mas não obtive respostas. Vejam abaixo:
http://www.planilhando.com.br/forum/viewtopic.php?f=10&t=15207
Por conta disso, na esperança de resolver esse problema, estou já há alguns dias na tentativa e erro. Creio que eu já tenha resolvido boa parte dos erros, mas o que esta reincidindo é esse:
Alguém sabe quais são as possíveis causa desse erro?
Postado : 14/04/2015 8:39 am
Documentação da Microsoft
https://msdn.microsoft.com/pt-br/library/5szkzs17.aspx
Laennder Alves
Microsoft MVP
Postado : 14/04/2015 9:00 am
Coloque o cõdigo da rotina MySub...
ou aonde cai a linha amarela quando o erro acontece...
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 14/04/2015 10:17 am
Topic starter
Fernando,
Esse ''mySub'' tem o objetivo de evitar que, ao encerrar o excel/projeto, o mesmo fique na memória do computador.
Veja abaixo:
Application.OnKey "{Escape}", ""
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim blnIsOpen As Boolean
On Error GoTo ErrHandler
Set xlApp = New Excel.Application
blnIsOpen = True
Call fechar
xlApp.Quit
blnIsOpen = False
ExitHere:
Exit Sub
ErrHandler:
If blnIsOpen = True Then
xlApp.Quit
End If
MsgBox Err.Description & vbCrLf & Err.Number & vbCrLf & Err.Source, vbCritical, "MySub"
Resume ExitHere
Postado : 14/04/2015 10:32 am
Topic starter
Fernando,
Na verdade são macros de duas userform's que acarretam nesse erro.
1° mysub (eu exclui esse código, e o erro, lógico, sumiu, aparecendo apenas se eu abri a userform19.)
2° Eu não sei qual macro é, mas sei que é alguma da userform19, pois se eu não abrir essa userform, o erro não acontece.
Macros da userform19:
Dim tamanhoLargura, tamanhoAltura
Option Explicit
'listrado
Private Declare Function SetWindowLong& Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long _
, ByVal wCmd As Long) As Long
Private Const GWL_WNDPROC As Long = (-4&)
Private hwnd As Long
'icone
Private Declare Function ExibirÍcone Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
' o termo FindWindwA não pode ser alterado
'// Constante do Ícone
Private Const FOCO_ICONE = &H80
Private Const ICONE = 0&
'tamanho das colunas
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
Dim Form_Personalizado As Long
Dim hIcone As Long
Dim mclsFormChanger As CFormChanger
Dim nAtualizaForm As New Classeform
Private Const imprimir As String = "Relatorio"
Private Const NomeDaPlanilha As String = "cliente"
Private Const LinhaCabecalho As Integer = 1
'define constantes para controlar as colunas de dados
Const colcodigo As Integer = 1
Const colcliente As Integer = 2
Const colccusto As Integer = 3
Const colcrazão As Integer = 4
Const coltipo As Integer = 5
Const colsoma As Integer = 18
Const colmédia As Integer = 19
Const colentrada As Integer = 20
Const colsaída As Integer = 21
Const coltelefone As Integer = 22
Const colemail As Integer = 23
Const indiceMinimo As Byte = 2
'define variavies para controlar a
Private alterar As Boolean
Private novo As Boolean
Private excluir As Boolean
'define as constantes para as cores do textbox
Const corDesabilitaTextBox As Long = -2147483633
Const corHabilitaTextBox As Long = -2147483643
'define a planilha usada e o indice do registro
Private CadastroProdutos As Worksheet
Private indiceRegistro As Long
Private Sub combobox2_Change()
If ComboBox2.Text <> "" Then
Image65.Visible = True
Image67.Visible = False
End If
End Sub
Private Sub ComboBox2_Enter()
If ComboBox2.Text <> "" Then
Image65.Visible = True
Image67.Visible = False
End If
End Sub
Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Image67.Visible = True
Image65.Visible = False
End Sub
Private Sub ComboBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Image65.Visible = True
Image67.Visible = False
End Sub
Private Sub ComboBoxCampos_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub Frame17_Click()
TextBox59.Text = "tel"
Me.Hide
UserForm81.Show
End Sub
Private Sub Frame17_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Frame17.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Frame18_Click()
End Sub
Private Sub Frame18_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Frame18.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image22_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image22.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image23_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image23.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image24_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image24.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image25_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image25.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image26_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image26.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image27_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image27.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image28_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image28.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image28_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image28.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image29_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image29.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image30_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image30.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image31_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image31.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image32_Click()
Shell "calc.exe"
End Sub
Private Sub Image59_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image59.SpecialEffect = fmSpecialEffectSunken
If txtproduto.Text = "" Then
Image59.ControlTipText = "Você ainda não selecionou um Cliente!"
Else
Image59.ControlTipText = "Insira-o na programação que você está fazendo!"
End If
End Sub
Private Sub CommandButton3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Label43.Visible = True
End Sub
Private Sub Image66_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image66.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image68_Click()
On Error Resume Next
If txtproduto.Text = "" Then
MsgBox "Gentileza selecionar um cliente!", vbCritical, "Atenção!"
Exit Sub
End If
Dim lastRow As Object
Sheets("GRAFICO_CLIENTE").Select
Set lastRow = Plan30.Range("a1:a1").End(xlUp)
lastRow.Offset(0, 0).Value = txtCodigo.Text
ThisWorkbook.Worksheets("GRAFICO_CLIENTE").Activate
Me.Hide
UserForm80.Show
End Sub
Private Sub Image32_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image32.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Image65_Click()
If ComboBox2.Text = "" Then
MsgBox "Por favor, selecione o ano a ser pesquisado e Tente Novamente!", vbInformation, "Atenção!"
ComboBox2.SetFocus
Exit Sub
End If
If Label41.Caption = ComboBox2.Text Then
MsgBox "Os dados referentes a este ano estão carregados! Selecione outro ano e Tente Novamente!", vbInformation, "Atenção!"
Exit Sub
End If
Sheets("cliente").Select
Dim lastRow As Object
Set lastRow = Plan22.Range("z:z").End(xlUp)
lastRow.Offset(0, 0).Value = ComboBox2.Value
Call PreencherCabeçalhoLinhas
Call formatação_lsLista
Call formato_islista
Image28.Enabled = False
novo = False
alterar = False
excluir = False
Set CadastroProdutos = ThisWorkbook.Worksheets("cliente")
Call HabilitaBotoesAlteracao
Call carregaDados
Call DesabilitaControles
Call LimpaControles
Call atualizar
Label41.Caption = ComboBox2.Text
If TextBoxFiltro.Text <> "" Then
Call TextBoxFiltro_Change
Call TamanhoColAutomatico
MsgBox "Pesquisa realizada com sucesso!", vbInformation, "Atenção!"
Exit Sub
End If
If TextBoxFiltro.Text = "" Then
Call TamanhoColAutomatico
MsgBox "Pesquisa realizada com sucesso!", vbInformation, "Atenção!"
Exit Sub
End If
End Sub
Private Sub Label39_Click()
End Sub
Private Sub Image68_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image68.SpecialEffect = fmSpecialEffectSunken
End Sub
Private Sub Label57_Click()
Shell "calc.exe"
End Sub
Private Sub Lslista_ItemCheck(ByVal Item As MSComctlLib.ListItem)
Label104.Visible = True
Label96.Visible = True
Call Somar2
Dim j As Integer
If Item.Checked = True Then
Item.ForeColor = RGB(0, 0, 255) 'Changement couleur
'Item.Bold = True 'Gras
Item.Selected = True
For j = 1 To Item.ListSubItems.Count
Item.ListSubItems(j).ForeColor = RGB(0, 0, 255)
'Item.ListSubItems(j).Bold = True
Item.Selected = True
Next j
Else
Item.ForeColor = RGB(1, 0, 0) 'Changement couleur
Item.Bold = False
Item.Selected = False
For j = 1 To Item.ListSubItems.Count
Item.ListSubItems(j).ForeColor = RGB(1, 0, 0)
Item.ListSubItems(j).Bold = False
Item.Selected = False
Next j
End If
End Sub
Private Sub lslista_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
Select Case KeyCode
Case vbKeyDelete
Call image22_Click
End Select
Select Case KeyCode
Case vbKeyF12 And TextBox34.Text = 1
Unload Me
UserForm9.Hide
End Select
End Sub
Private Sub ListView1_BeforeLabelEdit(Cancel As Integer)
End Sub
Private Sub TextBox32_Change()
TextBox32 = Format(TextBox32, "Currency")
End Sub
Private Sub TextBox35_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
End Sub
Private Sub TextBox35_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
If TextBox35.Locked = False Then
TextBox35.Text = ""
UserForm81.Show
End If
End Sub
Private Sub TextBox35_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Frame17.SpecialEffect = fmSpecialEffectRaised
End Sub
Private Sub TextBox36_Change()
End Sub
Private Sub TextBox36_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Frame18.SpecialEffect = fmSpecialEffectRaised
End Sub
Private Sub TextBox58_Change()
If TextBox58.Text = 0 Then
Frame5.Visible = False
Call OcultaColunas
Call TamanhoColAutomatico
End If
End Sub
Private Sub TextBoxFiltro_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Call OcultaColunas
Call TamanhoColAutomatico
Label10.Visible = False
Dim StringLength
StringLength = Len(TextBoxFiltro.Text)
[TextBox58] = StringLength - 1
End Sub
Private Sub TextBoxFiltro_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Dim StringLength
If TextBox34.Text = "1" Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image66.Visible = True
Image31.Visible = False
Label10.Visible = True
Call LimpaControles
StringLength = Len(TextBoxFiltro.Text)
[TextBox58] = StringLength + 1
End If
End Sub
Private Sub Somar2()
Dim valor2 As Double
Dim valor3 As Double
Dim i
For i = 1 To lslista.ListItems.Count
If lslista.ListItems.Item(i).Checked = False Then
Frame5.Visible = True
Else
On Error Resume Next
valor2 = valor2 + CDbl(Me.lslista.ListItems(i).ListSubItems(19))
valor3 = valor3 + CDbl(Me.lslista.ListItems(i).ListSubItems(20))
End If
Next i
Label104.Caption = valor2
Label96.Caption = valor3
Label105.Caption = Format(Label96.Caption / TextBox54.Value, "0.00%")
Label106.Caption = Format(Label104.Caption / TextBox57.Value, "0.00%")
End Sub
Private Sub UserForm_Activate()
Application.OnKey "{Escape}", ""
Set nAtualizaForm.Form = Me
Form_Personalizado = FindWindowA(vbNullString, Me.Caption)
Call ExibirÍcone(Form_Personalizado, FOCO_ICONE, ICONE, ByVal hIcone)
Set mclsFormChanger = New CFormChanger
Set mclsFormChanger.Form = Me
mclsFormChanger.ShowTaskBarIcon = True
Call TamanhoColAutomatico
Call OcultaColunas
Label41.Caption = [af1]
hIcone = Image5.Picture.Handle
Form_Personalizado = FindWindowA(vbNullString, Me.Caption)
Call ExibirÍcone(Form_Personalizado, FOCO_ICONE, ICONE, ByVal hIcone)
Set mclsFormChanger = New CFormChanger
Set mclsFormChanger.Form = Me
mclsFormChanger.ShowTaskBarIcon = True
If TextBox34.Text = 1 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = True
Image31.Visible = False
Exit Sub
End If
If TextBox34.Text = 2 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
Exit Sub
End If
If TextBox34.Text = 5 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
Exit Sub
End If
If TextBox34.Text = 3 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
Exit Sub
End If
If TextBox34.Text = 6 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
Exit Sub
End If
End Sub
Private Sub TamanhoColAutomatico()
Dim Column As Long
Dim Counter As Long
Counter = 0
For Column = Counter To lslista.ColumnHeaders.Count - 2
SendMessage lslista.hwnd, LVM_SETCOLUMNWIDTH, Column, LVSCW_AUTOSIZE_USEHEADER
Next
Call OcultaColunas
End Sub
Private Sub btnOK_Click()
UserForm7.Show
End Sub
Sub formatação_lsLista()
With lslista
.View = lvwReport
.Gridlines = True
.Appearance = 1 '= 0 - ccFlat e 1- cc3d
.Arrange = 0 '= 0 lvwNome / 1 lvwautoleft / 2 lvwautotop
.CheckBoxes = True '= true ou false
'.ControlTipText =
.Enabled = True ' true ou false
.FlatScrollBar = False '= true ou false
.FullRowSelect = True ' = true ou false
.Gridlines = True '= true ou false
' .Height
'.HelpContextID
.HideColumnHeaders = False ' = true ou false
'.HideSelction = True '= true ou false
.HotTracking = False '= true ou false
.HoverSelection = False '= true ou false
.LabelEdit = 1 '= 0 lvw automatic ou 1 - lvwmanual
.LabelWrap = True ' = true ou false
.MultiSelect = False '= true ou false
.OLEDragMode = ccOLEDragManual
End With
End Sub
Private Sub OcultaColunas()
On Error Resume Next
With lslista
.ColumnHeaders(20).Width = 0
.ColumnHeaders(21).Width = 0
.ColumnHeaders(22).Width = 0
.ColumnHeaders(23).Width = 0
.ColumnHeaders(24).Width = 0
.ColumnHeaders(25).Width = 0
.ColumnHeaders(26).Width = 0
.ColumnHeaders(27).Width = 0
.ColumnHeaders(28).Width = 0
End With
End Sub
Private Sub cbModal_Change()
nAtualizaForm.Modal = cbModal.Value
End Sub
Private Sub Image28_Click()
Application.OnKey "{Escape}", ""
TextBox37.Text = TextBox35.Text
alterar = True
Application.Visible = False
If txtCodigo.Text <> vbNullString And txtCodigo.Text <> "" Then
txtCodigo.Enabled = True
Call HabilitaControles
Call DesabilitaBotoesAlteracao
'dá o foco ao primeiro controle de dados
txtproduto.SetFocus
Image28.Visible = False
Frame17.Visible = True
Frame18.Visible = True
lslista.Enabled = False
Else
MsgBox "Não há registro a ser alterado"
TextBoxFiltro = ""
ComboBoxCampos = ""
Frame17.Visible = False
Frame18.Visible = False
End If
End Sub
Sub trocar()
txtCodigo.Enabled = True
Call HabilitaControles
Call DesabilitaBotoesAlteracao
'dá o foco ao primeiro controle de dados
txtproduto.SetFocus
Image28.Visible = False
Frame17.Visible = True
Frame18.Visible = True
lslista.Enabled = False
TextBox59.Text = ""
End Sub
Private Sub Image24_Click()
Application.OnKey "{Escape}", ""
If TextBox34.Text = 1 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = True
Image31.Visible = False
Frame17.Visible = False
Frame18.Visible = False
Call arrumar
lslista.Enabled = True
Exit Sub
End If
If TextBox34.Text = 2 Then
Frame17.Visible = False
Frame18.Visible = False
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
lslista.Enabled = True
Call arrumar
Exit Sub
End If
If TextBox34.Text = 3 Then
Frame17.Visible = False
Frame18.Visible = False
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
lslista.Enabled = True
Call arrumar
Exit Sub
End If
End Sub
Sub arrumar()
Sheets("cliente").Select
Cells.Select
Cells.EntireColumn.AutoFit
TextBoxFiltro.SetFocus
Call PreencheCampos
Me.ComboBoxCampos.ListIndex = 1
PreencherListView
Call PreencherCabeçalhoLinhas
Call formatação_lsLista
Image28.Enabled = False
novo = False
alterar = False
excluir = False
Set CadastroProdutos = ThisWorkbook.Worksheets("cliente")
Call HabilitaBotoesAlteracao
Call carregaDados
Call DesabilitaControles
Call LimpaControles
Call atualizar
Call TamanhoColAutomatico
Call formato_islista
End Sub
Private Sub image22_Click()
Application.OnKey "{Escape}", ""
If txtCodigo.Text = "1" Then
MsgBox "Este registro é padrão do sistema e não aceita exclusão!", vbInformation, "Padrão"
Exit Sub
End If
Application.Visible = False
excluir = True
If txtCodigo.Text <> vbNullString And txtCodigo.Text <> "" Then
Call DesabilitaBotoesAlteracao
'MsgBox "Você confirma a exclusão deste registro. (Para excluir clique no botão OK.) "
Else
MsgBox "Não existe registro a ser excluído", , "Cadastro"
Exit Sub
End If
Dim RESULTADO As VbMsgBoxResult
RESULTADO = MsgBox("Deseja excluir o registro nº " & txtCodigo.Text & " ?", vbYesNo, "Confirmação")
If RESULTADO = vbYes Then
CadastroProdutos.Range(CadastroProdutos.Cells(indiceRegistro, colcodigo), CadastroProdutos.Cells(indiceRegistro, colcodigo)).EntireRow.Delete
MsgBox "O Registro escolhido foi excluído com sucesso.", , "Cadastro"
txtCodigo.Enabled = False
Call LimpaControles
Call TextBoxFiltro_Change
Call TamanhoColAutomatico
If TextBox34.Text = 1 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = True
Image31.Visible = False
Exit Sub
End If
If TextBox34.Text = 2 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
Exit Sub
End If
If TextBox34.Text = 3 Then
Image22.Visible = True
Image25.Visible = True
Image26.Visible = True
Image27.Visible = True
Image29.Visible = True
Image66.Visible = False
Image31.Visible = False
Exit Sub
End If
End If
Exit Sub
End Sub
Private Sub Image30_Click()
Application.OnKey "{Escape}", ""
Application.Visible = False
Dim proximoId As Long
Dim controle As Control
Dim str As String
Dim chk As TextBox
For Each controle In Me.Controls
If TypeName(controle) = "textbox" Then
str = str & controle.Caption & ","
End If
Next
UserForm20.TextBox19 = UserForm19.TextBox34 & str
UserForm19.Hide
UserForm20.Show
End Sub
Private Sub Image23_Click()
If txtproduto.Text = "" Then
MsgBox "Por favor, selecione um Cliente/fornecedor e tente novamente!", vbInformation, "Atenção!"
Exit Sub
End If
Application.OnKey "{Escape}", ""
Application.Visible = False
If alterar = True Then
Call SalvaRegistro(CDbl(txtCodigo.Text), indiceRegistro)
MsgBox "O Registro alterado com sucesso.", , "Cadastro"
txtCodigo.Enabled = False
Call PreencherCabeçalhoLinhas
Call LimpaControles
Call atualizar
Call DesabilitaControles
Call DesabilitaBotoesAlteracao
Image27.Visible = True
Image26.Visible = True
Call LimpaControles
Call TextBoxFiltro_Change
Call TamanhoColAutomatico
lslista.Enabled = True
Exit Sub
End If
End Sub
Private Sub SalvaRegistro(ByVal id As Long, ByVal Indice As Long)
With CadastroProdutos
Dim linha, Index
Dim i As Integer
Dim indiceRegistro As Long
Dim oList As Object
Dim j
On Error Resume Next
Set oList = lslista.SelectedItem
If oList Is Nothing Then
Exit Sub
End If
.Cells(Indice, colcodigo).Value = id
.Cells(Indice, colcliente).Value = Me.txtproduto.Text
.Cells(Indice, colcrazão).Value = Me.txtunidade.Text
.Cells(Indice, coltipo).Value = Me.txtvalorp.Text
.Cells(Indice, colccusto).Value = Me.TextBox1.Text
.Cells(Indice, coltelefone).Value = Me.TextBox35.Text
.Cells(Indice, colemail).Value = Me.TextBox36.Text
End With
Call AtualizaRegistroAtual
End Sub
Private Sub CarregaRegistro()
'carrega os dados do primeiro registro
With CadastroProdutos
If Not IsEmpty(.Cells(indiceRegistro, colcliente)) Then
Me.txtCodigo.Text = .Cells(indiceRegistro, colcodigo).Value
Me.txtproduto.Text = .Cells(indiceRegistro, colcliente).Value
Me.txtunidade.Text = .Cells(indiceRegistro, colcrazão).Value
Me.txtvalorp.Text = .Cells(indiceRegistro, coltipo).Value
Me.TextBox1.Text = .Cells(indiceRegistro, colccusto).Value
Me.TextBox32.Text = .Cells(indiceRegistro, colsoma).Value
Me.TextBox35.Text = .Cells(indiceRegistro, coltelefone).Value
Me.TextBox36.Text = .Cells(indiceRegistro, colemail).Value
End If
End With
Call AtualizaRegistroAtual
End Sub
Private Sub carregaDados()
indiceRegistro = 2
Call CarregaRegistro
End Sub
Private Sub AtualizaRegistroAtual()
lblRegistro.Caption = indiceRegistro - 1 & " de " & CadastroProdutos.UsedRange.Rows.Count - 1
'lblMensagem.Caption = ""
End Sub
Private Function ObterProximoId() As Long
Dim rangeIds As Range
'pega o range que se refere a toda a coluna do código (id)
Set rangeIds = CadastroProdutos.Range(CadastroProdutos.Cells(indiceMinimo, colcodigo), CadastroProdutos.Cells(CadastroProdutos.UsedRange.Rows.Count, colcodigo))
ObterProximoId = WorksheetFunction.max(rangeIds) + 1
End Function
Private Sub CarregaProdutos(ByVal Categoria As String)
Dim linha As Integer, colunaproduto As Integer, colunaCategoria As Integer
linha = 2
colunaproduto = 1
colunaCategoria = 2
With Sheets("Produtos")
Do While Not IsEmpty(.Cells(linha, colunaproduto))
If .Cells(linha, colunaCategoria).Value = Categoria Then
End If
linha = linha + 1
Loop
End With
End Sub
Private Sub CommandButton1_Click()
Application.OnKey "{Escape}", ""
Application.Visible = False
Unload Me
Unload frmComboBoxEncadeado
End Sub
Private Sub Image59_Click()
Application.OnKey "{Escape}", ""
If TextBox34.Text = 1 Then
MsgBox "Identifiquei que, no momento, nenhuma programação encontra-se em andamento e, por conta disso, a opção de Selecionar não está ativa!", vbInformation, "Atenção!"
Image59.Enabled = False
Exit Sub
End If
Application.Visible = False
If txtproduto.Text = "" Then
MsgBox "Gentileza selecionar um cliente!", vbCritical, "Atenção!"
Exit Sub
End If
If TextBox34.Text = 2 Then
Dim proximoId As Long
Dim controle As Control
Dim str As String
Dim chk As TextBox
For Each controle In Me.Controls
If TypeName(controle) = "textbox" Then
str = str & controle.Caption & ","
End If
Next
frmComboBoxEncadeado.TextBox18 = UserForm19.txtproduto & str
frmComboBoxEncadeado.TextBox20 = UserForm19.TextBox1 & str
frmComboBoxEncadeado.TextBox21 = UserForm19.txtunidade & str
frmComboBoxEncadeado.TextBox22 = UserForm19.txtvalorp & str
frmComboBoxEncadeado.TextBox23 = UserForm19.txtCodigo & str
frmComboBoxEncadeado.entrou
Unload Me
frmComboBoxEncadeado.Show
Sheets("real").Select
Exit Sub
End If
If TextBox34.Text = 3 Then
For Each controle In Me.Controls
If TypeName(controle) = "textbox" Then
str = str & controle.Caption & ","
End If
Next
frmComboBoxEncadeado.TextBox18 = UserForm19.txtproduto & str
frmComboBoxEncadeado.TextBox20 = UserForm19.TextBox1 & str
frmComboBoxEncadeado.TextBox21 = UserForm19.txtunidade & str
frmComboBoxEncadeado.TextBox22 = UserForm19.txtvalorp & str
frmComboBoxEncadeado.TextBox23 = UserForm19.txtCodigo & str
If frmComboBoxEncadeado.TextBox1.Text = "" Then
frmComboBoxEncadeado.TextBox1.SetFocus
End If
If frmComboBoxEncadeado.TextBox1.Text <> "" And frmComboBoxEncadeado.TextBox19.Text = "" Then
On Error Resume Next
frmComboBoxEncadeado.TextBox19.SetFocus
frmComboBoxEncadeado.TextBox19.BackColor = &H80000018
End If
If frmComboBoxEncadeado.TextBox1.Text <> "" Then
On Error Resume Next
frmComboBoxEncadeado.TextBox19.SetFocus
frmComboBoxEncadeado.TextBox19.BackColor = &H80000018
End If
frmComboBoxEncadeado.entrou
Unload Me
frmComboBoxEncadeado.Show
Sheets("real").Select
Exit Sub
End If
If TextBox34.Text = 5 Then
For Each controle In Me.Controls
If TypeName(controle) = "textbox" Then
str = str & controle.Caption & ","
End If
Next
UserForm9.TextBox38 = UserForm19.txtproduto & str
UserForm9.TextBox1 = UserForm19.TextBox1 & str
UserForm9.txtunidade = UserForm19.txtunidade & str
UserForm9.txtvalorp = UserForm19.txtvalorp & str
UserForm9.txtCodigo = UserForm19.txtCodigo & str
Unload Me
UserForm9.Show
Sheets("real").Select
Exit Sub
End If
If TextBox34.Text = 6 Then
For Each controle In Me.Controls
If TypeName(controle) = "textbox" Then
str = str & controle.Caption & ","
End If
Next
UserForm46.TextBox18 = UserForm19.txtproduto & str
UserForm46.TextBox20 = UserForm19.TextBox1 & str
UserForm46.TextBox21 = UserForm19.txtunidade & str
UserForm46.TextBox25 = UserForm19.txtvalorp & str
UserForm46.TextBox26 = UserForm19.txtCodigo & str
Unload Me
UserForm46.Show
Exit Sub
End If
End Sub
Private Sub CommandButton3_Click()
Shell "calc.exe"
Label43.Visible = True
End Sub
Private Sub Label23_Click()
Dim iLin As Integer
Dim rgCellInicio As Range
Dim wsRelat As Worksheet
Dim UltimaLinha As Long
Set wsRelat = ThisWorkbook.Worksheets(imprimir)
UltimaLinha = wsRelat.UsedRange.Rows.Count
wsRelat.Range("A2:" & "o" & UltimaLinha).ClearContents
Set rgCellInicio = wsRelat.Range("A65536").End(xlUp).Offset(1, 0)
'recuperar dados
Dim i As Integer, j As Integer
'Loop nas linhas
For i = 1 To lslista.ListItems.Count
iLin = iLin + 1
rgCellInicio.Cells(iLin, 1).Value = lslista.ListItems(i).Text
'Loop nas colunas
For j = 1 To lslista.ColumnHeaders.Count - 1
rgCellInicio.Cells(iLin, j + 1).Value = lslista.ListItems(i).ListSubItems(j).Text
Next j
Next i
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
Cells.Select
Cells.EntireColumn.AutoFit
End With
Sheets("relatorio").Select
Unload Me
End Sub
Private Sub Label24_Click()
Dim iLin As Integer
Dim rgCellInicio As Range
Dim wsRelat As Worksheet
Dim UltimaLinha As Long
Set wsRelat = ThisWorkbook.Worksheets(imprimir)
UltimaLinha = wsRelat.UsedRange.Rows.Count
wsRelat.Range("A2:" & "o" & UltimaLinha).ClearContents
Set rgCellInicio = wsRelat.Range("A65536").End(xlUp).Offset(1, 0)
'recuperar dados
Dim i As Integer, j As Integer
'Loop nas linhas
For i = 1 To lslista.ListItems.Count
iLin = iLin + 1
rgCellInicio.Cells(iLin, 1).Value = lslista.ListItems(i).Text
'Loop nas colunas
For j = 1 To lslista.ColumnHeaders.Count - 1
rgCellInicio.Cells(iLin, j + 1).Value = lslista.ListItems(i).ListSubItems(j).Text
Next j
Next i
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
Cells.Select
Cells.EntireColumn.AutoFit
End With
wsRelat.Activate
Macro1
Macro3
Macro2
End Sub
Private Sub Label9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Label23.Visible = True
Label24.Visible = True
End Sub
Private Sub lslista_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)
End Sub
Private Sub txtproduto_Change()
txtproduto = UCase(txtproduto)
End Sub
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
UserForm19.Hide
If TextBox34 = 1 Then
Unload Me
UserForm9.Show
Exit Sub
End If
If TextBox34 = 2 Then
'menu iniciar
Unload Me
UserForm7.Show
Exit Sub
End If
If TextBox34 = 3 Then
'menu iniciar
Unload Me
frmComboBoxEncadeado.Show
Exit Sub
End If
If TextBox34 = 4 Then
Unload Me
UserForm12.Show
Exit Sub
End If
If TextBox34 = 5 Then
'menu iniciar
Unload Me
UserForm9.Show
Exit Sub
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image30.SpecialEffect = fmSpecialEffectRaised
Image28.SpecialEffect = fmSpecialEffectRaised
Image22.SpecialEffect = fmSpecialEffectRaised
Image23.SpecialEffect = fmSpecialEffectRaised
Image24.SpecialEffect = fmSpecialEffectRaised
Image32.SpecialEffect = fmSpecialEffectRaised
Frame17.SpecialEffect = fmSpecialEffectRaised
Image66.SpecialEffect = fmSpecialEffectRaised
Image25.SpecialEffect = fmSpecialEffectRaised
Image29.SpecialEffect = fmSpecialEffectRaised
Image31.SpecialEffect = fmSpecialEffectRaised
Image26.SpecialEffect = fmSpecialEffectRaised
Image27.SpecialEffect = fmSpecialEffectRaised
Image68.SpecialEffect = fmSpecialEffectRaised
Image59.SpecialEffect = fmSpecialEffectRaised
Frame18.SpecialEffect = fmSpecialEffectRaised
If TextBox59.Text = "tel" Then
Call trocar
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
UserForm19.Hide
If TextBox34 = 1 Then
Unload Me
UserForm9.Show
Exit Sub
End If
If TextBox34 = 2 Then
'menu iniciar
Unload Me
Unload UserForm19
UserForm7.Show
Exit Sub
End If
If TextBox34 = 3 Then
'menu iniciar
Unload Me
frmComboBoxEncadeado.Show
Exit Sub
End If
If TextBox34 = 4 Then
Unload Me
UserForm12.Show
Exit Sub
End If
If TextBox34 = 5 Then
'menu iniciar
Unload Me
UserForm9.Show
Exit Sub
End If
End If
End Sub
Private Sub UserForm_Initialize()
Application.OnKey "{Escape}", ""
Dim i&
hwnd = GetWindow(FindWindow(vbNullString, Me.Caption), 5)
OldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
Label41.Caption = [af1]
TextBox32.Text = ""
With Me
.Top = Application.Top
.Left = Application.Left
.Height = Application.Height
.Width = Application.Width
ComboBox2.AddItem "2015"
ComboBox2.AddItem "2014"
ComboBox2.AddItem "2013"
UserForm19.Caption = "Clientes Cadastrados."
Sheets("cliente").Select
If [x1] < 2 Then
userform27.Show
Exit Sub
End If
Cells.Select
Cells.EntireColumn.AutoFit
TextBoxFiltro.SetFocus
Call PreencheCampos
Me.ComboBoxCampos.ListIndex = 1
Call PreencherCabeçalhoLinhas
Call formatação_lsLista
Image28.Enabled = False
novo = False
alterar = False
excluir = False
Set CadastroProdutos = ThisWorkbook.Worksheets("cliente")
Call HabilitaBotoesAlteracao
Call carregaDados
Call DesabilitaControles
Call LimpaControles
Call formatação_lsLista
Call somar
End With
End Sub
Sub ajeitar()
Sheets("cliente").Select
Cells.Select
Cells.EntireColumn.AutoFit
TextBoxFiltro.SetFocus
Call PreencheCampos
Me.ComboBoxCampos.ListIndex = 1
PreencherListView
Call PreencherCabeçalhoLinhas
Call formatação_lsLista
Image28.Enabled = False
novo = False
alterar = False
excluir = False
Set CadastroProdutos = ThisWorkbook.Worksheets("cliente")
Call HabilitaBotoesAlteracao
Call carregaDados
Call DesabilitaControles
Call LimpaControles
Call atualizar
Call TamanhoColAutomatico
Call formato_islista
End Sub
Private Sub CarregaCategorias()
Dim linha As Integer, coluna As Integer
linha = 1
coluna = 5
Me.ComboBox2.Clear
With Sheets("cliente")
Do While Not IsEmpty(.Cells(linha, coluna))
Me.ComboBox2.AddItem .Cells(linha, coluna).Value
linha = linha + 1
Loop
End With
End Sub
Private Sub cmdPrimeiro_Click()
indiceRegistro = indiceMinimo
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub cmdProximo_Click()
If indiceRegistro < CadastroProdutos.UsedRange.Rows.Count Then
indiceRegistro = indiceRegistro + 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub cmdUltimo_Click()
indiceRegistro = CadastroProdutos.UsedRange.Rows.Count
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub Image1_Click()
indiceRegistro = indiceMinimo
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub Image2_Click()
If indiceRegistro > indiceMinimo Then
indiceRegistro = indiceRegistro - 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub Image3_Click()
If indiceRegistro < CadastroProdutos.UsedRange.Rows.Count Then
indiceRegistro = indiceRegistro + 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub Image4_Click()
indiceRegistro = CadastroProdutos.UsedRange.Rows.Count
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub Label11_Click()
PDF
End Sub
Private Sub Label7_Click()
Unload UserForm19
Application.WindowState = xlMinimized
Application.WindowState = xlMaximized
Plan22.Select
Application.Visible = True
End Sub
Private Sub Label8_Click()
ActiveWorkbook.Save
Application.Quit
Unload UserForm19
End Sub
Private Sub Label9_Click()
Dim iLin As Integer
Dim rgCellInicio As Range
Dim wsRelat As Worksheet
Dim UltimaLinha As Long
Set wsRelat = ThisWorkbook.Worksheets(imprimir)
UltimaLinha = wsRelat.UsedRange.Rows.Count
wsRelat.Range("A2:" & "o" & UltimaLinha).ClearContents
Set rgCellInicio = wsRelat.Range("A65536").End(xlUp).Offset(1, 0)
'recuperar dados
Dim i As Integer, j As Integer
'Loop nas linhas
For i = 1 To lslista.ListItems.Count
iLin = iLin + 1
rgCellInicio.Cells(iLin, 1).Value = lslista.ListItems(i).Text
'Loop nas colunas
For j = 1 To lslista.ColumnHeaders.Count - 1
rgCellInicio.Cells(iLin, j + 1).Value = lslista.ListItems(i).ListSubItems(j).Text
Next j
Next i
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
Cells.Select
Cells.EntireColumn.AutoFit
End With
wsRelat.Activate
Macro3
Macro2
End Sub
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
Dim i
For i = 1 To lslista.ListItems.Count
If lslista.ListItems.Item(i).Checked = False Then
lslista.ListItems.Item(i).Checked = True
Call Somar2
End If
Next i
Exit Sub
End If
If CheckBox1.Value = False Then
For i = 1 To lslista.ListItems.Count
If lslista.ListItems.Item(i).Checked = True Then
lslista.ListItems.Item(i).Checked = False
Call Somar2
End If
Next i
Exit Sub
End If
If CheckBox1.Value = "" Then
For i = 1 To lslista.ListItems.Count
If lslista.ListItems.Item(i).Checked = True Then
lslista.ListItems.Item(i).Checked = False
Call Somar2
End If
Next i
Exit Sub
End If
End Sub
Private Sub somar()
Dim i As Long
Dim valor2 As Double
Dim valor3 As Double
On Error Resume Next
For i = 1 To Me.lslista.ListItems.Count
On Error Resume Next
valor2 = valor2 + CDbl(Me.lslista.ListItems(i).ListSubItems(19))
valor3 = valor3 + CDbl(Me.lslista.ListItems(i).ListSubItems(20))
Next i
TextBox57.Text = valor2
TextBox54.Text = valor3
Frame5.Visible = True
Call OcultaColunas
End Sub
Private Sub lslista_Click()
Dim linha, Index
Dim i As Integer
Dim indiceRegistro As Long
Dim oList As Object
Dim j
On Error Resume Next
Set oList = lslista.SelectedItem
If oList Is Nothing Then
Exit Sub
End If
indiceRegistro = UserForm19.ProcuraIndiceRegistroPodId(lslista.ListItems.Item(lslista.SelectedItem.Index))
If indiceRegistro <> -1 Then
Call UserForm19.CarregaRegistroPorIndice(indiceRegistro)
End If
If TextBox34.Text = "1" Then
Image22.Enabled = True
Image25.Visible = False
Image22.Visible = True
Exit Sub
End If
If TextBox34.Text = 2 Then
Image22.Enabled = True
Image25.Visible = False
Image22.Visible = True
Exit Sub
End If
End Sub
Private Sub lsLista_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
On Error Resume Next
Dim vbHourglass
Dim InvNumber
' Começa ordenar o listview pela coluna clicada
With lslista
' Display the hourglass cursor whilst sorting
Dim lngCursor As Long
lngCursor = .MousePointer
.MousePointer = vbHourglass
' Prevent the ListView control from updating on screen -
' this is to hide the changes being made to the listitems
' and also to speed up the sort
' Check the data type of the column being sorted,
' and act accordingly
Dim l As Long
Dim strFormat As String
Dim strData() As String
Dim lngIndex As Long
lngIndex = ColumnHeader.Index - 1
Select Case UCase$(ColumnHeader.Tag)
Case "DATE"
' Sort by date.
strFormat = "YYYYMMDDHhNnSs"
' Loop through the values in this column. Re-format
' the dates so as they can be sorted alphabetically,
' having already stored their visible values in the
' tag, along with the tag's original value
With .ListItems
If (lngIndex > 0) Then
For l = 1 To .Count
With .Item(l).ListSubItems(lngIndex)
.Tag = .Text & Chr$(0) & .Tag
If IsDate(.Text) Then
.Text = Format(CDate(.Text), _
strFormat)
Else
.Text = ""
End If
End With
Next l
Else
For l = 1 To .Count
With .Item(l)
.Tag = .Text & Chr$(0) & .Tag
If IsDate(.Text) Then
.Text = Format(CDate(.Text), _
strFormat)
Else
.Text = ""
End If
End With
Next l
End If
End With
' Sort the list alphabetically by this column
.SortOrder = (.SortOrder + 1) Mod 2
.SortKey = ColumnHeader.Index - 1
.Sorted = True
' Restore the previous values to the 'cells' in this
' column of the list from the tags, and also restore
' the tags to their original values
With .ListItems
If (lngIndex > 0) Then
For l = 1 To .Count
With .Item(l).ListSubItems(lngIndex)
strData = Split(.Tag, Chr$(0))
.Text = strData(0)
.Tag = strData(1)
End With
Next l
Else
For l = 1 To .Count
With .Item(l)
strData = Split(.Tag, Chr$(0))
.Text = strData(0)
.Tag = strData(1)
End With
Next l
End If
End With
Case "NUMBER"
' Sort Numerically
strFormat = String(30, "0") & "." & String(30, "0")
' Loop through the values in this column. Re-format the values so as they
' can be sorted alphabetically, having already stored their visible
' values in the tag, along with the tag's original value
With .ListItems
If (lngIndex > 0) Then
For l = 1 To .Count
With .Item(l).ListSubItems(lngIndex)
.Tag = .Text & Chr$(0) & .Tag
If IsNumeric(.Text) Then
If CDbl(.Text) >= 0 Then
.Text = Format(CDbl(.Text), _
strFormat)
Else
.Text = "&" & InvNumber( _
Format(0 - CDbl(.Text), _
strFormat))
End If
Else
.Text = ""
End If
End With
Next l
Else
For l = 1 To .Count
With .Item(l)
.Tag = .Text & Chr$(0) & .Tag
If IsNumeric(.Text) Then
If CDbl(.Text) >= 0 Then
.Text = Format(CDbl(.Text), _
strFormat)
Else
.Text = "&" & InvNumber( _
Format(0 - CDbl(.Text), _
strFormat))
End If
Else
.Text = ""
End If
End With
Next l
End If
End With
' Sort the list alphabetically by this column
.SortOrder = (.SortOrder + 1) Mod 2
.SortKey = ColumnHeader.Index - 1
.Sorted = True
' Restore the previous values to the 'cells' in this
' column of the list from the tags, and also restore
' the tags to their original values
With .ListItems
If (lngIndex > 0) Then
For l = 1 To .Count
With .Item(l).ListSubItems(lngIndex)
strData = Split(.Tag, Chr$(0))
.Text = strData(0)
.Tag = strData(1)
End With
Next l
Else
For l = 1 To .Count
With .Item(l)
strData = Split(.Tag, Chr$(0))
.Text = strData(0)
.Tag = strData(1)
End With
Next l
End If
End With
Case Else ' Assume sort by string
' Sort alphabetically. This is the only sort provided
' by the MS ListView control (at this time), and as
' such we don't really need to do much here
.SortOrder = (.SortOrder + 1) Mod 2
.SortKey = ColumnHeader.Index - 1
.Sorted = True
End Select
.MousePointer = lngCursor
End With
Image28.Enabled = False
Image22.Enabled = True
End Sub
Private Sub lslista_DblClick()
Dim linha, Index
Dim i As Integer
Dim indiceRegistro As Long
Dim oList As Object
Dim j
On Error Resume Next
Set oList = lslista.SelectedItem
If oList Is Nothing Then
Exit Sub
End If
indiceRegistro = UserForm19.ProcuraIndiceRegistroPodId(lslista.ListItems.Item(lslista.SelectedItem.Index))
If indiceRegistro <> -1 Then
Call UserForm19.CarregaRegistroPorIndice(indiceRegistro)
End If
If TextBox34.Text = "1" Then
Image59.Enabled = False
Image30.Enabled = False
Image28.Enabled = True
Image22.Enabled = False
Image29.Visible = False
Image28.Visible = True
Image25.Visible = True
Else
Image59.Enabled = True
Image30.Enabled = False
Image28.Enabled = True
Image22.Enabled = False
Image29.Visible = False
Image28.Visible = True
Image25.Visible = True
End If
End Sub
Private Sub LimpaControles()
Me.txtCodigo.Text = ""
Me.txtproduto.Text = ""
Me.txtunidade.Text = ""
Me.txtvalorp.Text = ""
Me.TextBox1.Text = ""
Me.TextBox32.Text = ""
Me.TextBox4.Text = ""
Me.TextBox6.Text = ""
Me.TextBox35.Text = ""
Me.TextBox36.Text = ""
End Sub
Private Sub HabilitaControles()
Me.txtproduto.Locked = False
Me.TextBox4.Locked = False
Me.TextBox35.Locked = False
Me.TextBox36.Locked = False
'altera a cor dos controles
Me.txtproduto.BackColor = corHabilitaTextBox
Me.TextBox35.BackColor = corHabilitaTextBox
Me.TextBox36.BackColor = corHabilitaTextBox
Me.TextBox4.BackColor = corHabilitaTextBox
Me.TextBox6.BackColor = corHabilitaTextBox
End Sub
Private Sub DesabilitaControles()
Me.txtproduto.Locked = True
Me.txtunidade.Locked = True
Me.txtvalorp.Locked = True
Me.TextBox1.Locked = True
Me.TextBox4.Locked = True
Me.TextBox35.Locked = True
Me.TextBox36.Locked = True
'altera a cor dos controles
Me.txtproduto.BackColor = corDesabilitaTextBox
Me.TextBox1.BackColor = corDesabilitaTextBox
Me.txtvalorp.BackColor = corDesabilitaTextBox
Me.txtunidade.BackColor = corDesabilitaTextBox
Me.TextBox4.BackColor = corDesabilitaTextBox
Me.TextBox6.BackColor = corDesabilitaTextBox
Me.TextBox35.BackColor = corDesabilitaTextBox
Me.TextBox36.BackColor = corDesabilitaTextBox
End Sub
Private Sub HabilitaBotoesAlteracao()
'habilita os botões de alteração
Image28.Enabled = False
Image22.Enabled = False
Image30.Enabled = True
Image23.Enabled = False
Image24.Enabled = False
End Sub
Private Sub DesabilitaBotoesAlteracao()
'desabilita os botões de alteração
Image28.Enabled = False
Image22.Enabled = True
Image26.Visible = False
Image27.Visible = False
Image29.Visible = True
Image31.Visible = True
Image66.Visible = True
Image30.Enabled = False
Image24.Enabled = True
Image23.Enabled = True
End Sub
Private Function ValidaCamposFormulario() As Boolean
If Me.txtproduto.Value = "" Then
MsgBox " 'Matrícula' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
Me.txtproduto.SetFocus
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtunidade.Value = "" Then
MsgBox "'Setor' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
Me.txtunidade.SetFocus
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtvalorp.Value = "" Then
MsgBox " 'Cargo' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
Me.txtvalorp.SetFocus
ValidaCamposFormulario = False
Exit Function
ElseIf Me.ComboBox3.Value = "" Then
MsgBox "'Status' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
Me.ComboBox3.SetFocus
ValidaCamposFormulario = False
Exit Function
End If
ValidaCamposFormulario = True
End Function
Private Sub PreencherCabeçalhoLinhas()
Dim Ws As Worksheet
Dim coluna As Integer
Dim linha As Integer
Dim itm As ListItem, n As Long, lngCol As Long
Dim vardata As Variant
Call atualizar
Set Ws = ThisWorkbook.Worksheets(NomeDaPlanilha)
coluna = 1
linha = LinhaCabecalho
Me.lslista.ListItems.Clear
Me.lslista.ColumnHeaders.Clear
vardata = Ws.Range("b1").CurrentRegion.Value
With Ws
While .Cells(linha, coluna).Value <> Empty
With lslista
.View = lvwReport
.Gridlines = True
.ColumnHeaders.Add Text:=Ws.Cells(linha, coluna), Width:=Ws.Cells(linha, coluna).Width
End With
coluna = coluna + 1
Wend
'Preenche as Linhas
With lslista
For n = 2 To UBound(vardata)
Set itm = .ListItems.Add(n - 1, , vardata(n, 1))
For lngCol = 2 To UBound(vardata, 2)
'verifica se é Data e formata a Coluna
If IsDate(vardata(n, lngCol)) Then
itm.ListSubItems.Add , , vardata(n, lngCol)
' itm.ListSubItems.Add , , Format(vardata(n, lngCol), "R$ #,##0.00")
Else
itm.ListSubItems.Add , , vardata(n, lngCol)
End If
Next lngCol
Next n
End With
End With
End Sub
End Sub
Postado : 14/04/2015 11:06 am
Topic starter
... continuação
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image1.SpecialEffect = fmSpecialEffectRaised
End Sub
Private Sub Image2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image2.SpecialEffect = fmSpecialEffectRaised
End Sub
Private Sub Image3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image3.SpecialEffect = fmSpecialEffectRaised
End Sub
Private Sub Image4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image4.SpecialEffect = fmSpecialEffectRaised
End Sub
Sub atualizar()
Dim rngCelula As Range
ActiveWorkbook.Sheets("cliente").Activate
Range("l9000").Select
For Each rngCelula In Selection
rngCelula.FormulaLocal = rngCelula.Value
Next rngCelula
[b1].Select
End Sub
Public Function ProcuraIndiceRegistroPodId(ByVal id As Long) As Long
Dim i As Long
Dim retorno As Long
Dim encontrado As Boolean
i = indiceMinimo
With CadastroProdutos
Do While Not IsEmpty(.Cells(i, colcodigo))
If .Cells(i, colcodigo).Value = id Then
retorno = i
encontrado = True
Exit Do
End If
i = i + 1
Loop
End With
'caso não encontre o registro, retorna -1
If Not encontrado Then
retorno = -1
End If
ProcuraIndiceRegistroPodId = i
End Function
Public Sub CarregaRegistroPorIndice(ByVal Indice As Long)
'carrega os dados do registro baseado no índice
indiceRegistro = Indice
Call CarregaRegistro
End Sub
Sub formato_islista()
Me.Label10.Caption = "Total de Dados: " & Format(Me.lslista.ListItems.Count, "000")
' para formatar é aqui
' para formatar é aqui
Dim X As Integer
For X = 1 To lslista.ListItems.Count
Me.lslista.ListItems(X).SubItems(18) = Format(Me.lslista.ListItems(X).SubItems(18), "0.00")
Next X ' loop
End Sub
Private Sub ComboBoxCampos_Change()
'Me.TextBoxFiltro.SetFocus
End Sub
Sub PreencherListView()
Dim lastRow As Long
Dim li As ListItem
Dim X As Long
'limpar
lslista.ListItems.Clear
lastRow = Plan22.Cells(Plan22.Cells.Rows.Count, "a").End(xlUp).Row
' Adiciona itens
For X = 2 To lastRow
Set li = lslista.ListItems.Add(Text:=Format(Plan22.Cells(X, "a").Value, "00"))
li.ListSubItems.Add Text:=Plan22.Cells(X, "b").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "c").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "d").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "e").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "f").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "g").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "h").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "i").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "j").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "k").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "l").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "m").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "n").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "o").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "p").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "Q").Value
li.ListSubItems.Add Text:=Plan22.Cells(X, "R").Value
li.ListSubItems.Add Text:=Format(Plan22.Cells(X, "t").Value, "0.00")
li.ListSubItems.Add Text:=Format(Plan22.Cells(X, "u").Value, "0.00")
li.ListSubItems.Add Text:=Format(Plan22.Cells(X, "s").Value, "0.00")
Next
End Sub
Private Sub TextBoxFiltro_Change()
If TextBoxFiltro = "" Then
PreencherCabeçalhoLinhas
formato_islista
Exit Sub
If Me.ComboBoxCampos.ListIndex = -1 Then
Me.TextBoxFiltro = ""
Exit Sub
End If
Dim strObjetoBuscar As String
Dim lngResultado As Long
'Dim lngColumna As Long, lngFila As Long
Dim a As Integer
Dim coluna
Dim li
End If
coluna = Me.ComboBoxCampos.ListIndex + 1
lslista.ListItems.Clear
strObjetoBuscar = TextBoxFiltro.Value
If strObjetoBuscar = "" Then GoTo 99
strObjetoBuscar = LCase(strObjetoBuscar)
For a = 2 To 10000
lngResultado = InStr(1, Plan22.Cells(a, coluna), strObjetoBuscar, vbTextCompare)
If lngResultado > 0 Then
Set li = lslista.ListItems.Add(Text:=Format(Plan22.Range("A" & a).Value, "000"))
li.ListSubItems.Add Text:=Plan22.Cells(a, "b").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "c").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "d").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "e").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "F").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "g").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "h").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "i").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "j").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "k").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "l").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "m").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "n").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "o").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "p").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "Q").Value
li.ListSubItems.Add Text:=Plan22.Cells(a, "R").Value
li.ListSubItems.Add Text:=Format(Plan22.Cells(a, "s").Value, "0.00")
li.ListSubItems.Add Text:=Format(Plan22.Cells(a, "t").Value, "0.00")
li.ListSubItems.Add Text:=Format(Plan22.Cells(a, "u").Value, "0.00")
End If
Next a
99:
Me.Label10.Caption = "Total de Dados: " & Format(Me.lslista.ListItems.Count, "000")
Call OcultaColunas
Call somar
End Sub
Private Sub PreencheCampos()
Dim Ws As Worksheet
Dim coluna As Integer
Dim linha As Integer
Set Ws = ThisWorkbook.Worksheets(NomeDaPlanilha)
coluna = 1 'de 1 para 2
linha = LinhaCabecalho
With Ws
While .Cells(linha, coluna).Value <> Empty
Me.ComboBoxCampos.AddItem .Cells(linha, coluna)
coluna = coluna + 1
If coluna = 5 Then Exit Sub
Wend
End With
End Sub
Private Sub PreencheCabecalho(ByRef lista())
Dim Ws As Worksheet
Dim coluna As Integer
Dim linha As Integer
Set Ws = ThisWorkbook.Worksheets(NomePlanilha)
coluna = 1 'de 1 p 2
linha = LinhaCabecalho
With Ws
While .Cells(linha, coluna).Value <> Empty
lista(0, coluna - 1) = .Cells(linha, coluna) 'de -1 p -2
coluna = coluna + 1
Wend
End With
Postado : 14/04/2015 11:07 am
Topic starter
Pessoal,
No projeto em questão eu utilizo muito os colchetes para trazer um valor de um célula para o código.
Exemplo:
textbox1 = [a1] + [b1]
Ou seja, não utilizei Dim. Vocês acham que é necessário fazer da seguinte forma:
dim x1
dim x2
X1 = [A1]
X2 = [B1]
textbox1.text = x1 + x2
Eu fiz assim, mas o sistema ficou muito lento!!
Postado : 15/04/2015 6:30 am
particularmente não creio que seja por isso que ficou lento, com certeza que deve ter sido pelos eventos que vc colocou, isso é um assassino de desempenho
mas...
eu sempre procuro as maneira mais rapidas e eficientes "nem sempre as corretas(ou que o pessoal fala que é o correto)"
textbox1 = [a1] + [b1]
X1 = [A1]
se vc vai usar essa expressão apenas uma vez
textbox1 = cells(1,1).value2 + cells(1,2).value2
se vc vai usar mais de uma vez, adicione os valores em uma variavel
x=cells(1,1).value2 + cells(1,2).value2
Somente é impossíveis até que alguém faça
A logica está presa na irracionalidade humana, e morta nos que se consideram donos da verdade.
"ALGUM MODERADOR ME EXPULSE DO FÓRUM POR FAVOR"
Postado : 15/04/2015 6:40 am
Calma Lorenzo, muitas dúvidas em uma...
Primeiro, vc não sabe daonde vem a msg? Isso é grave!
Usa o Ctrl+L *(janela do localizar) para colocar um ponto de interrupção em todas as linhas que contenham MsgBox *(com certeza uma delas está rodando, qdo ela for aparecer, vc saberá)
Em seguida, me explica, vc tá abrindo um Excel pra em seguida fechá-lo umas 3 vezes pra ter certeza q ele fechou, isso faz com que xlApp já está fechado e o erro q vc tem acontece, pois o xlApp deve ter virado Nothing
Qto a seu código gigante no post ali em cima, eu juro pra vc que eu li 5 linhas dele, daí vi o tamanho da barra de rolagem e resolvi não continuar.
O erro do da variávei with não definida se dá quando vc está no código referenciando algo que não está instanciado.
Se a msg está aparecendo, e essa msg não é de erro padrão (Fim Depurar), é customizada, significa que vc a capturou e a imagem q vc enviou é de um msgbox, por isso, procure todos os msgbox e coloque um F9 *(ponto de interrupção) .... ao rodar de novo, replicar o problema, vc vai ver exatamente qual rotina chamou essa msgbox e poderá estudar o que houve ali.
qto à outra dúvida, qto menos vezes vc ler o objeto range, melhor. Usar colchetes ou range("") não faz diferença qto a desempenho. Eu não indico o uso dos colchetes pq vc sempre vai depender da planilha ativa. Se quiser acelerar seu código, é assunto pra outro tópico...
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 15/04/2015 7:29 am
Topic starter
Fernando,
Parabéns!
Muito didática a sua explicação!
Creio que resolvi o problema, mas não darei esse forum como resolvido ainda, pois utilizarei o sistema por, no mínimo, dois dias e. durante esse tempo, observarei o encerramento do mesmo.
Só mais uma coisa: existe a possibilidade de colocar uma exclamação (f9) em todas msgbox de uma só vez? pergunto isso, pois o meu projeto tem 382 msgbox!
Postado : 15/04/2015 1:26 pm
não é "exclamação", é "ponto de interrupção"... Não tem como colocar pontos de interrupção assim, mas tem como colocar stop
Faz assim tecle Ctr+U *(janela de substituir texto por texto)
Substitua tudo que for
"Msgbox "
por
"Stop: Msgbox "
*(sem as aspas, coloquei as aspas pra vc ver que vc TEM que escrever o espaço depois do x... Se não fizer isso, vai estragar as msgboxs assim: if msgbox(blablabla) then )]
Quando terminar, volte na janela do substituir e faça o contrário, substitua todos os
"Stop: Msgbox "
por
"Msgbox "
*(tb sem as aspas, claro)
Deve funcionar....
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 15/04/2015 9:24 pm
Topic starter
Fernando,
Antes de qualquer coisa, ja tentei substituir as msgbox com espaço, sem espaço, mas o que acontece nada mais é do que um erro de síntese e, por conta disso, a sua sugestão, pelo menos pra mim, não deu certo.
É o seguinte:
Supondo que os erros não são originados por msgbox, ou melhor, supondo que nem ao menos temos ideia das causas possíveis dos erros. Como a gente pode encontrá-los?
O que é feito no projeto para termos a certeza de que erros em tempo de execução e entre outros não ocorrerão?
Postado : 16/04/2015 9:19 am
O que se faz em projetos e colocar tratamento adequado de erros em todas as rotinas, esses tratamentos de erro devem todos chamar uma única rotina para tratamento de erro padrão, daí vc colocaria o ponto de interrupção num lugar só.
Assim:
Sub Rotina1()
On Error Goto TratarErro
dim i as integer 'integer tem limite de 32000
'todo seu código
i = 40000 'essa linha gera um erro pq integer vai até 32000, e nao aceita 40000
On error goto 0
Exit Sub
TratarErro:
call Tratamento("Rotina1")
End Sub
Sub Rotina2()
On Error Goto TratarErro
dim i as integer 'integer tem limite de 32000
'todo seu código
i = 40000 'essa linha gera um erro pq integer vai até 32000, e nao aceita 40000
On error goto 0
Exit Sub
TratarErro:
call Tratamento("Rotina2")
End Sub
Sub Tratamento(Rotina as string)
MsgBox "A rotina com erro é " & Rotina, vbokonly
End Sub
No seu caso, como vc não fez isso, vc teria que analisar sue código, saber quais rotinas são chamadas que geram esse erro, e colocar os pontos de interrupção nelas. E então, executar passo a passo até o erro acontecer, brincando com as opção de depuração (F8, F5, Shift+F8, Ctrl+Shift+F8, Ctrl+F9, etc)
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 16/04/2015 5:59 pm
Topic starter
não obtive sucesso! =/
Postado : 21/04/2015 8:52 am
Cara, eu passei algumas formas diferentes, todas boas, e vc não teve sucesso com nenhuma...
Eu desisto..
Sorry,
FF
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 22/04/2015 9:42 am
Página 1 / 2
Próximo