criei este modulo na aplicacao para exibir somente o formulario e ocultar as planilhas.
Sub AUTO_OPEN()
Application.Visible = False
lista.Show
End Sub
aassim ele exit o formulario direto quando eu chamo a aplicao, o que eu estou querendo saber e como eu faco um botao no formulario que pare a execucao e volte para a manipulacao dos codigos e das planilhas para que eu possa fazer alteracoes quando for necessario.
abaixo segue o codigo do botao que criei .
Private Sub cmdparar_Click()
Call sair
End Sub
Sub sair()
Sheets("Senha").Activate
Range("A2").Select
Dim senha As String
senha = InputBox("Informe a Senha, Somente Pessoas Autorizadas")
'While ActiveCell <> ""
If senha = ActiveCell Then
MsgBox " voce vai finalizar o processo!!!"
Application.Quit
Application.Visible = True
'lista.Show
Else
MsgBox "Voce Nao tem autorizacao ou a senha esta Incorreta!!!"
Call sair
Exit Sub
End If
'Wend
End Sub
segue imagem do formulario nest link
https://i.imgur.com/I02871A.png
abaixo segue o codigo completo
'*****************************************
Private Sub cbxtipo_Click()
'"******************************************
'* habilita o botao para salvar os dados
'*******************************************
If txttc.Text = "" Then
MsgBox " VOCE TEM DE SELECIONAR NA LISTAGEM UM THINCLIENT PARA SER ALTERADO"
Else
cmdSalva.Enabled = True
End If
End Sub
Private Sub cmdaltera_Click()
If txttc.Text = "" Then
MsgBox " VOCE TEM DE SELECIONAR NA LISTAGEM UM THINCLIENT PARA SER ALTERADO"
Else
txtip.Text = Empty
txtestacao.Text = Empty
txtlinha.Text = Empty
cbxtipo.Value = Empty
Call chama
End If
'**************************************************
'CHAMA ROTINA PARA DIGITAR O IP QUE SERA PROCURADO
'**************************************************
End Sub
Sub chama()
Dim ip As String
Dim rng As Range
ip = InputBox("Informe o IP")
'************************************************
'* COMPARAR O VALOR DIGITADO SE ESTA NA PLANILHA
'************************************************
If Trim(ip) <> "" Then
With Sheets("Cadastro").Range("C:C")
Set rng = .Find(what:=ip, MatchCase:=False)
If Not rng Is Nothing Then
Application.Goto rng, True
MsgBox " ESTE IP JA ESTA EM USO FAVOR DIGITAR NOVAMENTE UM IP VALIDO"
chama
Else
txtip.Text = ip
estacao
End If
End With
End If
End Sub
Sub estacao()
Dim stn As Range
'************************************************
'* COMPARAR O VALOR DIGITADO SE ESTA NA PLANILHA
'************************************************
'* inicio rotina consulta estacao
'************************************************
If Trim(txtip.Text) <> "" Then
With Sheets("Estacoes").Range("A:D")
Set stn = .Find(what:=txtip.Text, MatchCase:=False)
If Not stn Is Nothing Then
Application.Goto stn, True
'MsgBox " IP localizado "
txtestacao.Text = ActiveCell.Offset(0, 1).Select
txtestacao.Text = ActiveCell.Value
txtlinha.Text = ActiveCell.Offset(0, 1).Select
txtlinha.Text = ActiveCell.Value
cbxtipo.SetFocus
Else
MsgBox "ESTE IP NAO FOI LOCALIZADO NA LISTA"
End If
End With
End If
End Sub
Private Sub cmdestacoes_Click()
''******************************************************
'* botao de selecao das linhas para o listbox
'******************************************************
Call Filtra_Estacoes
End Sub
Private Sub cmdestacoes2_Click()
Call Filtra_Estacoes
End Sub
Private Sub cmdfecha_Click()
MsgBox " voce ira finalizar o processo"
ActiveWorkbook.Save
Application.Quit
Workbooks("Lista de Tc1.XLSM").Close
End Sub
Private Sub cmdparar_Click()
Call sair
End Sub
Sub sair()
Sheets("Senha").Activate
Range("A2").Select
Dim senha As String
senha = InputBox("Informe a Senha, Somente Pessoas Autorizadas")
'While ActiveCell <> ""
If senha = ActiveCell Then
MsgBox " voce vai finalizar o processo!!!"
Application.Quit
Application.Visible = True
'lista.Show
Else
MsgBox "Voce Nao tem autorizacao ou a senha esta Incorreta!!!"
Call sair
Exit Sub
End If
'Wend
End Sub
Private Sub cmdSalva_Click()
'**************************************
'* ativa a planilha onde vai gravar
'**************************************
Sheets("Cadastro").Activate
Range("A2").Select
While ActiveCell <> ""
If txttc.Text = ActiveCell Then
ActiveCell.Offset(0, 2).Value = txtip.Text
ActiveCell.Offset(0, 1).Value = txtestacao.Text
ActiveCell.Offset(0, 3).Value = txtlinha.Text
ActiveCell.Offset(0, 4).Value = cbxtipo.Text
ActiveWorkbook.Save
End If
ActiveCell.Offset(1, 0).Activate
Wend
MsgBox " Voce Gravou os Dados Com sucesso !!!"
txttc.Text = Empty
txtip.Text = Empty
txtestacao.Text = Empty
txtlinha.Text = Empty
cbxtipo.Text = Empty
End Sub
Private Sub CommandButton2_Click()
If txttc.Text = "" Then
MsgBox " VOCE TEM DE SELECIONAR NA LISTAGEM UM THINCLIENT PARA SER REMOVIDO"
Else
Call remover
End If
End Sub
Sub remover()
Sheets("Cadastro").Activate
Range("A2").Select
While ActiveCell <> ""
If txttc.Text = ActiveCell Then
ActiveCell.Offset(0, 2).Value = "Not Available"
ActiveCell.Offset(0, 1).Value = "NÃO_ALOCADO"
ActiveCell.Offset(0, 3).Value = "SITE_PRESIDENTE_ALTINO"
ActiveCell.Offset(0, 4).Value = ""
End If
ActiveCell.Offset(1, 0).Activate
Wend
MsgBox " Voce Removeu Com Sucesso !!!"
End Sub
Private Sub CommandButton3_Click()
MsgBox "voce tem de digitar a senha para parar o processo"
End Sub
Sub Filtra_Estacoes()
'*****************************************************************
'* INICIO ROTINA QUE FILTRA OS DADOS DA LIST BOX
'*****************************************************************
Dim linha, linhalistbox As Integer
Dim valor_celula As String
linhalistbox = 0
linha = 2
lstestacoes.Clear
Plan1.Select
With Plan1
While .Cells(linha, 4).Value <> ""
valor_celula = .Cells(linha, 4).Value
If UCase(Left(valor_celula, Len(cmdestacoes.Text))) = UCase(cmdestacoes.Text) Then
valor_celula = .Cells(linha, 2).Value
If UCase(Left(valor_celula, Len(cmdestacoes2.Text))) = UCase(cmdestacoes2.Text) Then
Me.lstestacoes.ColumnWidths = "40;70;150;150;50"
With lstestacoes
.AddItem
.List(linhalistbox, 0) = Plan1.Cells(linha, 1)
.List(linhalistbox, 1) = Plan1.Cells(linha, 3)
.List(linhalistbox, 2) = Plan1.Cells(linha, 2)
.List(linhalistbox, 3) = Plan1.Cells(linha, 4)
.List(linhalistbox, 4) = Plan1.Cells(linha, 5)
End With
linhalistbox = linhalistbox + 1
End If
End If
linha = linha + 1
Wend
End With
End Sub
'*****************************************************************************************************************
Private Sub lsttc_Click()
cmdSalva.Enabled = False
End Sub
Private Sub txttc_Change()
txttc.Text = UCase(txttc.Value)
End Sub
Private Sub UserForm_Activate()
cmdSalva.Enabled = False
Dim lin As Integer
lin = 2
Do Until Sheets("Cadastro").Cells(lin, 1).Value = Empty
lsttc.AddItem Sheets("Cadastro").Cells(lin, 1).Value
lin = lin + 1
Loop
Call Filtra_Estacoes
End Sub
Private Sub lsttc_Change()
cmdSalva.Enabled = False
Dim lin As Integer
lin = 2
Do Until Sheets("Cadastro").Cells(lin, 1).Value = Empty
If Sheets("Cadastro").Cells(lin, 1).Value = lsttc.Value Then
txttc.Value = Sheets("Cadastro").Cells(lin, 1).Value
txtip.Value = Sheets("Cadastro").Cells(lin, 3).Value
txtestacao.Value = Sheets("Cadastro").Cells(lin, 2).Value
txtlinha.Value = Sheets("Cadastro").Cells(lin, 4).Value
cbxtipo.Value = Sheets("Cadastro").Cells(lin, 5).Value
Exit Do
End If
lin = lin + 1
Loop
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Clique no Botao Finalizar Programa Salvando"
End If
End Sub
agradeco desde ja
