Usuário com melhor resposta
NumLock desativando sozinho

Pergunta
-
Bom dia Pessoal,
Estou finalizando meu formulário de pesquisa mas estou com um problema que é, diga-se de passagem, bem incomodo. Neste formulário tenho dois textbox para inserção da data inicial e da data final de pesquisa.
Meu problema é que quando começo a digitar as datas pelo teclado numérico o NumLock desativa e tenho que ficar habilitando-o novamente para terminar de inserir a data.
Esta desativação costuma acontecer depois dos dois primeiros dígitos quando a primeira "/" é inserida.
Então eu gostaria de saber se existe alguma forma de manter o NumLock sempre ativo e impedir sua desativação e como posso integrar isso ao meu projeto.
O código do formulário segue abaixo:
Private Const NomePlanSaida As String = "Dados" Private Const NomePlanRelatorio As String = "DadosTemp" Private Const LinhaCabecalho As Integer = 1 'INICIO EVENTOS FORMATAÇÃO DOS TEXTBOX DATAS' Private Sub dataf_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) 'Limita a Qde de caracteres' dataf.MaxLength = 10 'para permitir que apenas números sejam digitados' If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then KeyAscii = 0 End If End Sub Private Sub dataf_Change() 'Formata : dd/mm/aaaa' If Len(dataf) = 2 Or Len(dataf) = 5 Then dataf.Text = dataf.Text & "/" SendKeys "{End}", True End If End Sub Private Sub datai_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) 'Limita a Qde de caracteres' datai.MaxLength = 10 'para permitir que apenas números sejam digitados' If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then KeyAscii = 0 End If End Sub Private Sub datai_Change() 'Formata : dd/mm/aaaa' If Len(datai) = 2 Or Len(datai) = 5 Then datai.Text = datai.Text & "/" SendKeys "{End}", True End If End Sub 'FIM EVENTOS FORMATAÇÃO DOS TEXTBOX DATAS' Private Sub UserForm_Activate() 'Define algumas propriedades do ListView' With Me.lstLista .Gridlines = True .HideColumnHeaders = False .View = lvwReport End With 'Preenche Combo Box' setor.AddItem "" setor.AddItem "Administração" setor.AddItem "CD 2" setor.AddItem "HPBE" setor.AddItem "Logistica" setor.AddItem "Manutenção" setor.AddItem "Meio Ambiente" setor.AddItem "PCP" setor.AddItem "Qualidade" setor.AddItem "Segurança" setor.AddItem "SMBE" setor.ListIndex = 0 validacao.AddItem "" validacao.AddItem "Aprovado" validacao.AddItem "Banco de Ideias" validacao.AddItem "Aguardando análise da Comissão" validacao.ListIndex = 0 'Chama a sub para preencher a ListView' Call LoadListView End Sub Sub RestauraControles() datai.Value = "" dataf.Value = "" nome.Value = "" setor.ListIndex = 0 Call LoadListView nome.SetFocus End Sub Private Sub limpa_Click() RestauraControles End Sub Private Sub fechar_Click() Unload cmsPesquisa End Sub 'Preenche a ListView' Private Sub LoadListView() 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 Set ws = ThisWorkbook.Worksheets(NomePlanSaida) coluna = 1 linha = LinhaCabecalho Me.lstLista.ListItems.Clear Me.lstLista.ColumnHeaders.Clear vardata = ws.Range("A1").CurrentRegion.Value With ws While .Cells(linha, coluna).Value <> Empty With lstLista .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 lstLista 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 , , Format(vardata(n, lngCol), "dd/mm/yyyy") Else itm.ListSubItems.Add , , vardata(n, lngCol) End If Next lngCol Next n End With End With End Sub 'Consulta Nome' Sub nome_Change() lastRow = Plan2.Cells(Rows.Count, "a").End(xlUp).Row lstLista.ListItems.Clear 'Adiciona itens' For x = 2 To lastRow If UCase(Plan2.Cells(x, 2)) Like "*" & UCase(nome) & "*" Then Set li = lstLista.ListItems.Add(Text:=Plan2.Cells(x, "a").Value) li.ListSubItems.Add Text:=Plan2.Cells(x, "b").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "c").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "d").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "e").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "f").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "g").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "h").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "i").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "j").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "k").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "l").Value li.ListSubItems.Add Text:=Plan2.Cells(x, "m").Value End If Next End Sub 'Filtrar pelas Datas' Private Sub cbtSo2Dts_Click() Dim I As Long If datai = "" Then MsgBox "Digite uma Data Valida", , "Data Inicial Obrigatória!!!" datai.SetFocus Exit Sub End If For I = lstLista.ListItems.Count To 1 Step -1 If CDate(lstLista.ListItems(I).SubItems(5)) < datai.Value Then lstLista.ListItems.Remove I ElseIf CDate(lstLista.ListItems(I).SubItems(5)) > dataf.Value Then lstLista.ListItems.Remove I End If Next End Sub ' Carrega o cadastro selecionado' Private Sub lstLista_DblClick() Dim linha, Index Dim I As Integer Dim oList As Object Dim indiceRegistro As Long Set oList = lstLista.SelectedItem If oList Is Nothing Then Exit Sub Else indiceRegistro = cmsCadastro.ProcuraIndiceRegistroPodId(lstLista.ListItems.Item(lstLista.SelectedItem.Index)) If indiceRegistro <> -1 Then Call cmsCadastro.CarregaRegistroPorIndice(indiceRegistro) End If Unload Me End If cmsCadastro.Show End Sub
- Editado Carlos H V Brito quinta-feira, 16 de abril de 2015 12:47
Respostas
-
O NumLock está desativando porque esse é um dos efeitos do SendKeys. Troque a rotina abaixo:
Private Sub dataf_Change() 'Formata : dd/mm/aaaa' If Len(dataf) = 2 Or Len(dataf) = 5 Then dataf.Text = dataf.Text & "/" SendKeys "{End}", True End If End Sub
por, por exemplo:
Private Sub dataf_Change() 'Formata : dd/mm/aaaa' If Len(dataf) = 2 Or Len(dataf) = 5 Then dataf.Text = dataf.Text & "/" dataf.SelStart = Len(dataf) End If End Sub
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
- Marcado como Resposta Carlos H V Brito quinta-feira, 16 de abril de 2015 14:44
Todas as Respostas
-
Tente isso:
Public Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long Function AltEstadoTecla(Tecla, mAtiva As Boolean) Dim ws As Object Set ws = CreateObject("WScript.shell") If mAtiva Then If GetKeyState(Tecla) = 0 Then ws.SendKeys "{numlock}" Else If GetKeyState(Tecla) = 1 Then ws.SendKeys "{numlock}" End If Set ws = Nothing End Function
Para chamar use:
altestadoTecla 144, true
Fonte:
http://comunidade.itlab.com.br/eve/forums/a/tpc/f/273606921/m/2257015873
Natan
-
O NumLock está desativando porque esse é um dos efeitos do SendKeys. Troque a rotina abaixo:
Private Sub dataf_Change() 'Formata : dd/mm/aaaa' If Len(dataf) = 2 Or Len(dataf) = 5 Then dataf.Text = dataf.Text & "/" SendKeys "{End}", True End If End Sub
por, por exemplo:
Private Sub dataf_Change() 'Formata : dd/mm/aaaa' If Len(dataf) = 2 Or Len(dataf) = 5 Then dataf.Text = dataf.Text & "/" dataf.SelStart = Len(dataf) End If End Sub
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
- Marcado como Resposta Carlos H V Brito quinta-feira, 16 de abril de 2015 14:44
-
-
-
Prezado Felipe,
No caso de campo de texto tipo caixa de texto ou listagem que serve de pesquisa. Como faço para mandar um comasdo para continuar alterando o campo sem usar o sendKeys "F2".
Private Sub txtrazaosocial_Change() If VarEspaco = 1 Then VarEspaco = 0 Else Me.Recalc Me.txtrazaosocial.SetFocus SendKeys "{F2}" End If End Sub
-
o que você pode fazer é trocar o
SendKeys "{f2}"
por esse comando
Dim ws As Object Set ws = CreateObject("WScript.shell") ws.SendKeys "{f2}"
ai ficaria assim
Private Sub txtrazaosocial_Change() If VarEspaco = 1 Then VarEspaco = 0 Else Me.Recalc Me.txtrazaosocial.SetFocus Dim ws As Object Set ws = CreateObject("WScript.shell") ws.SendKeys "{f2}" End If End Sub
estava com o mesmo problema e achei um forum aonde tinha essa solução, que funcionou muito bem.
- Editado alissonmathias segunda-feira, 23 de julho de 2018 14:56
-
O NumLock está desativando porque esse é um dos efeitos do SendKeys. Troque a rotina abaixo:
Private Sub dataf_Change() 'Formata : dd/mm/aaaa' If Len(dataf) = 2 Or Len(dataf) = 5 Then dataf.Text = dataf.Text & "/" SendKeys "{End}", True End If End Sub
por, por exemplo:
Private Sub dataf_Change() 'Formata : dd/mm/aaaa' If Len(dataf) = 2 Or Len(dataf) = 5 Then dataf.Text = dataf.Text & "/" dataf.SelStart = Len(dataf) End If End Sub
Felipe Costa Gualberto - http://www.ambienteoffice.com.br