Esqueceu sua senha? Você pode usar o mecanismo de lembrete neste link: Recuperar senha

Você receberá um link de reativação no email cadastrado.

Não recebeu o email? Lembre-se checar o Lixo Eletrônico.

modelos de sistema - gestão de clinica.

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
anielise
Colaborador
Colaborador
Mensagens: 21
Registrado em: Qua Jun 26, 2019 5:56 pm

Re: modelos de sistema - gestão de clinica.

Mensagem por anielise » Dom Ago 11, 2019 8:57 pm

como consigo colocar formula na coluna do access de modo que logicamente calcula automaticcamnte e atualiza.

eu tenho 4 colunas

status funcionario = ativo/ inativo

ultimo exame = data

tempo corrido = DIAS360(ultimo exame;HOJE()))

status validade exame = SE(status funcionario="INATIVO";"INATIVO";(SE(tempo corrido >365;"VENCIDO";"NO PRAZO"))

podem me ajudar. gostaria mto que isso acontece no access.

quanto a questão anterior eu consegui resolver o problema só não entendi o motivo de dar o erro. eu gostaria de aprender.

sabedoria é muito nessa vida.



Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


anielise
Colaborador
Colaborador
Mensagens: 21
Registrado em: Qua Jun 26, 2019 5:56 pm

Re: modelos de sistema - gestão de clinica.

Mensagem por anielise » Seg Ago 12, 2019 7:50 pm

Vou disponibilizar um código que adaptei para que um calculo seja colocado direto no listview, no lugar de inserir a informação no access (eu não consegui colocar formulas lá)

Código: Selecionar todos

Option Explicit
Global db As New ADODB.Connection
Global RS As New ADODB.Recordset
Global PETH As String
Sub CONECTADB()
Set db = New ADODB.Connection
 With db
 .Provider = "Microsoft.ACE.OLEDB.16.0"
 .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\cadastro.accdb"
 .Open
 End With
End Sub
Sub fechadb()
db.Close: Set db = Nothing
Set RS = Nothing
End Sub


Sub LIST_PACIENTES()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
With F_1.ListView2
        With .ColumnHeaders
            .Clear
             'adiciona colunas
            .Add , , "COD", 25 '1
            .Add , , "EMPRESA", 200, 0
            .Add , , "NOME", 200, 0 '2
            .Add , , "DOC", 50, 0  '3
            .Add , , "NUMERO", 120, 0 '4
            .Add , , "STATUS DO EXAME", 100, 0 '5
                    
        End With
        .View = 3 'exibir em modo de relatório
    End With

sql = "SELECT * FROM PACIENTES"
'define a conexão e abre o Recordset com os dados da tabela empresa
Call CONECTADB
'*carrega lista de dados

Set RS = New ADODB.Recordset
RS.Open sql, db, 3, 3

On Error Resume Next
'Preenche o controle listview com os dados da tabela
F_1.ListView2.ListItems.Clear

While Not RS.EOF
Set list = F_1.ListView2.ListItems.Add(Text:=RS(0))
      If Not IsNull(RS(11)) Then
      list.SubItems(1) = RS(11)
      End If
      If Not IsNull(RS(1)) Then
      list.SubItems(2) = RS(1)
      End If
      If Not IsNull(RS(3)) Then
      list.SubItems(3) = RS(3)
      End If
      If Not IsNull(RS(4)) Then
      list.SubItems(4) = RS(4)
      End If
      If RS(9) = "Ativo" And RS(18) <> "" And Now() - RS(18) < 365 Then
      list.SubItems(5) = "no prazo"
      ElseIf RS(9) = "Ativo" And RS(18) <> "" And Now() - RS(18) > 365 Then
      list.SubItems(5) = "Vencido"
      ElseIf RS(9) = "Inativo" Then
      list.SubItems(5) = "Inativo"
      End If
RS.MoveNext
Wend
'desconectar
Call fechadb
F_1.Label51 = F_1.ListView2.ListItems.Count
'habilitar novamente
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub




Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1189
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: modelos de sistema - gestão de clinica.

Mensagem por Reinaldo » Ter Ago 13, 2019 6:16 am

"...com banco de dados fechado..."
Como sua rotina e bem segmentada, ao efetuar as checagens diversas a conexão com o BD e aberta e fechada constantemente. Em uma das sub rotinas o BD e fechado e retorna para a rotina inicial para fechar o bd, gerando o erro. Não pude precisar exatamente o ponto, pois seu projeto tem referencia a formulario e sub rotinas que não estão presente nesse modelo, o que dificulta o acompanhamento;
mas por ser no fechamento do BD uma solução:

Código: Selecionar todos

Sub fechadb()
    On Error Resume Next
    db.Close: Set db = Nothing
    Set RS = Nothing
End Sub

"...onde vai adicionar novo registro..."
Aqui não entendi a demanda, se é ao abrir a tabela access e logo abaixo do ultimo registro fica uma linha com 0, isso e padrão do BD, e não afeta em nada inclusão/verificação.
Porem é preciso atentar que como deixou o campo Id manual, a primeira inclusão se não especificada ira incluir o registo como Id=0 )Zero. Veja o registro Ortoclinic na tbl Empresa


Reinaldo
Gostou da resposta?:?: :oops: :D :mrgreen:

Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1189
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: modelos de sistema - gestão de clinica.

Mensagem por Reinaldo » Ter Ago 13, 2019 6:23 am

"...como consigo colocar formula na coluna do access de modo..."
Há na definição de tipo do campo na tabela access (modo design) onde define texto/numero... um tipo considerado "Calculado", que ao ser selecionado abre o construtor de expressões.
Nota: Usualmente não é recomendado incluir campo calculado no BD, esse calculo preferencialmente deve ser efetuado nas consultas/seleçao/relatorios


Reinaldo
Gostou da resposta?:?: :oops: :D :mrgreen:

Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


anielise
Colaborador
Colaborador
Mensagens: 21
Registrado em: Qua Jun 26, 2019 5:56 pm

Re: modelos de sistema - gestão de clinica.

Mensagem por anielise » Ter Ago 13, 2019 2:25 pm

Caro Reinaldo tem me ajudado muito e sei que vou pedir mais ajuda. obrigada pela força.



eu preciso de uma macro eu preciso que seja pesquisado na COLUNA a referencia onde devo salvar a informação.

criei uma macro para meu excel sub exames e queria adaptar para gravar a informação no acces mas não sei como seria essa adapação.

se não tiver jeito de criar macro para essa função. será que consigo usar a macro que esta logo abaixo chamado Sub fncMain() de uma analizada nela e pode me ensinar. quero entender se ela abre a pasta de destino e salva e depois fecha igual do access. ou não.

Código: Selecionar todos

Sub exames()

'F_2.Abox7.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA) = F_2.Abox7.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop

'F_2.Abox8.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA) = F_2.Abox8.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox9.Valuue
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox9.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox10.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox10.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox11.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox11.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox12.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox12.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox13.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox13.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox14.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox14.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox15.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox15.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox16.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox16.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox17.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox17.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox18.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox18.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox19.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox19.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox20.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox20.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox21.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox21.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox22.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox22.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox23.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox23.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
'F_2.Abox24.Value
COLUNA = 17
Worksheets("c_exame").Select
i = Sheets("c_exame").Cells(1, 1).End(xlDown).Row
Do Until Sheets("c_exame").Cells(7, COLUNA) = ""
If Sheets("c_exame").Cells(7, COLUNA).Value = F_2.Abox24.Value Then
Sheets("c_exame").Cells(i, COLUNA) = "1"
For COLUNA = 17 To 40
Next COLUNA
End If
COLUNA = COLUNA + 1
Loop
End Sub

Código: Selecionar todos

Sub fncMain()
    Dim lngLastLin As Long
    Dim wksOri As Worksheet
    Dim wkbDes As Workbook
    Dim wksDes As Worksheet
    
    Set wksOri = ThisWorkbook.Worksheets("PlanOrigem")
    Set wkbDes = Workbooks.Open("c:\temp\Destino.xlsm")
    Set wksDes = wkbDes.Worksheets("PlanDestino")
    
    With wksDes
        lngLastLin = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
    wksDes.Cells(lngLastLin, 1) = wksOri.Range("A1")
    
    wkbDes.Close SaveChanges:=True
End Sub



Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1189
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: modelos de sistema - gestão de clinica.

Mensagem por Reinaldo » Ter Ago 13, 2019 4:03 pm

Não entendi o objetivo da Sub Exames; principalmente o trecho abaixo que se repete varias vezes

Código: Selecionar todos

For COLUNA = 17 To 40
Next COLUN
Pode fornecer maiores detalhes e em que tabela do access espera/precisa/deseja ter algo similar

"...quero entender se ela abre...
Veja se os comentários ajudam

Código: Selecionar todos

Sub fncMain()
Dim wksOri As Worksheet
Dim wkbDes As Workbook
Dim wksDes As Worksheet
'Atribui as variaveis Worksheet sua referencia
Set wksOri = ThisWorkbook.Worksheets("PlanOrigem")
Set wkbDes = Workbooks.Open("c:\temp\Destino.xlsm")
Set wksDes = wkbDes.Worksheets("PlanDestino")

'Acrescenta o valor de A1 da planilha origem para a planilha destino
With wksDes
    wksDes.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) = wksOri.Range("A1")
End With
'Fecha planilha destino
wkbDes.Close SaveChanges:=True
End Sub


Reinaldo
Gostou da resposta?:?: :oops: :D :mrgreen:

anielise
Colaborador
Colaborador
Mensagens: 21
Registrado em: Qua Jun 26, 2019 5:56 pm

Re: modelos de sistema - gestão de clinica.

Mensagem por anielise » Ter Ago 13, 2019 4:22 pm

Reinaldo escreveu:
Ter Ago 13, 2019 4:03 pm
Não entendi o objetivo da Sub Exames; principalmente o trecho abaixo que se repete varias vezes

Código: Selecionar todos

For COLUNA = 17 To 40
Next COLUN
Pode fornecer maiores detalhes e em que tabela do access espera/precisa/deseja ter algo similar

"...quero entender se ela abre...
Veja se os comentários ajudam

Código: Selecionar todos

Sub fncMain()
Dim wksOri As Worksheet
Dim wkbDes As Workbook
Dim wksDes As Worksheet
'Atribui as variaveis Worksheet sua referencia
Set wksOri = ThisWorkbook.Worksheets("PlanOrigem")
Set wkbDes = Workbooks.Open("c:\temp\Destino.xlsm")
Set wksDes = wkbDes.Worksheets("PlanDestino")

'Acrescenta o valor de A1 da planilha origem para a planilha destino
With wksDes
    wksDes.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) = wksOri.Range("A1")
End With
'Fecha planilha destino
wkbDes.Close SaveChanges:=True
End Sub

está em anexo o sistema inicial da clinica

senha para adm é davi2020

no f_02 (formulário pacientes) quando vou fazer novo atendimento. as combox nele tem os exames que fazemos.

exemplo se tal pessoa vai ser atendido e realiza exame clinico. (da combobox) no registro vai procurar a coluna correspondente a exame clinico e salva como n° 1 na (linha, coluna correspondente) e assim por diantes.
cada exame tem sua coluna correspondente.

por isso criado a macro sub exame.
lógico não sou master em programação fui testando e testando saiu essa mesmo grande. se tiver comoreduzir ela para mim fico mto grata.

e olha to super feliz que eu esteja conseguindo aprender com vcs. consegui fazer o sql com excell e agora vai...
Anexos
saudetrab.zip
(2.22 MiB) Baixado 2 vezes



anielise
Colaborador
Colaborador
Mensagens: 21
Registrado em: Qua Jun 26, 2019 5:56 pm

Re: modelos de sistema - gestão de clinica.

Mensagem por anielise » Ter Ago 13, 2019 10:23 pm

oi boa noite tudo bem?

estou com um problema no procedimento salvar_atualizar_exames
e no atualizar _exames

não está reconhecendoo if.. mesmo que a referencia seja igual ao item selecionado não reconhece asssim não atualiza minhas informações.

é normal tbm quando salvar em outra pasta de trabalho. ficar piscando a tela?

um grande abraço e otima quarta feira.

Código: Selecionar todos

Global lngLastLin As Long
Global wkbDes As Workbook
Global wksDes As Worksheet


Global OBS As String
Global i As Integer
Global Data As Date
Global maximo As Integer

Global LINHA  As Byte
Global coluna As Byte
Sub SALVAR_ATUALIZAR_EXAMES()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False

'=========salvar_atualizar

Dim resultado As VbMsgBoxResult

sql = "SELECT * FROM c_exame " & " WHERE código like '" & F_2.cod5.Value & "'"
'define a conexão e abre o Recordset com os dados da tabela empresa
Call CONECTADB
'*carrega lista de dados
Set RS = New ADODB.Recordset
RS.Open sql, db, 3, 3

If F_2.cod5.Value <> "" And F_2.cod5.Value = RS(0) Then
resultado = MsgBox("cadastro existente no Código " & RS(0) & ", deseja atualizar ", vbYesNo, "atualizar")
      If resultado = vbYes Then
      Call fechadb
      Call ATUALIZAR_EXAMES
      Exit Sub
      End If
Exit Sub
End If
Call fechadb
'Call SALVAR_EXAMES

'=========fim salvar atualizar

   'habilitar novamente
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub SALVAR_EXAMES()

Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False

On Error GoTo Aviso
Data = F_2.Abox1.Value
OBS = F_2.ALTURA.Value & " " & F_2.CONFINAMENTO.Value & " " & F_2.VEICULOS.Value

    Set wkbDes = Workbooks.Open(ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx")
    Set wksDes = wkbDes.Worksheets("c_exame")
    wksDes.Application.Visible = False
    maximo = Application.WorksheetFunction.Max(wksDes.Range("A:A"))
    F_2.cod5 = maximo + 1
    With wksDes
    lngLastLin = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
    wksDes.Cells(lngLastLin, 1) = F_2.cod5.Value
    wksDes.Cells(lngLastLin, 2) = F_2.cod2.Value
    wksDes.Cells(lngLastLin, 3) = F_2.cod3.Value
    wksDes.Cells(lngLastLin, 4) = F_2.Abox3.Text
    wksDes.Cells(lngLastLin, 5) = F_2.Abox31.Text
    wksDes.Cells(lngLastLin, 6) = F_2.Abox5.Text
    wksDes.Cells(lngLastLin, 7) = F_2.TextBox2.Text
    wksDes.Cells(lngLastLin, 8) = DateValue(Data)
    wksDes.Cells(lngLastLin, 9) = F_2.box11.Text
    wksDes.Cells(lngLastLin, 10) = F_2.box12.Text
    wksDes.Cells(lngLastLin, 11) = F_2.Abox26.Text
    wksDes.Cells(lngLastLin, 12) = F_2.box1.Text
    wksDes.Cells(lngLastLin, 13) = OBS
    wksDes.Cells(lngLastLin, 15) = F_2.Abox30.Text
   '==================== para atendimentos
   
   Call exames
   

  
    ' fechar
    wksDes.Application.Visible = True
    wkbDes.Close SaveChanges:=True
    Call salvarultimoexame
    Call FILTRO_ATENDIMENTO_PACIENTE
    MsgBox "Dados Gravados com Sucesso" & " id n° " & F_2.cod5.Value
Exit Sub
Aviso: MsgBox "PASTA ABERTA POR OUTRO USUÁRIO OU NÃO ENCONTRADA NO DESTINO " & ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx"
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub ATUALIZAR_EXAMES()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False

'On Error Resume Next
Dim resultado As VbMsgBoxResult
Data = F_2.Abox1.Value
LINHA = 1
coluna = 17
Dim valorpesquisa
valorpesquisa = F_2.cod5.Value
OBS = F_2.ALTURA.Value & " " & F_2.CONFINAMENTO.Value & " " & F_2.VEICULOS.Value

Set wkbDes = Workbooks.Open(ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx")
Set wksDes = wkbDes.Worksheets("c_exame")
    
Do Until wksDes.Cells(LINHA, 1) = "" 'vai executar o laço até encontrar uma célula vazia
         'condicção para localizar o registro
If wksDes.Cells(LINHA, 1) = valorpesquisa Then 'se encontrar o valor registro na célula pesquisada
    wksDes.Cells(LINHA, 1) = F_2.cod5.Value
    wksDes.Cells(LINHA, 2) = F_2.cod2.Value
    wksDes.Cells(LINHA, 3) = F_2.cod3.Value
    wksDes.Cells(LINHA, 4) = F_2.Abox3.Text
    wksDes.Cells(LINHA, 5) = F_2.Abox31.Text
    wksDes.Cells(LINHA, 6) = F_2.Abox5.Text
    wksDes.Cells(LINHA, 7) = F_2.TextBox2.Text
    wksDes.Cells(LINHA, 8) = DateValue(Data)
    wksDes.Cells(LINHA, 9) = F_2.box11.Text
    wksDes.Cells(LINHA, 10) = F_2.box12.Text
    wksDes.Cells(LINHA, 11) = F_2.Abox26.Text
    wksDes.Cells(LINHA, 12) = F_2.box1.Text
    wksDes.Cells(LINHA, 13) = OBS
    wksDes.Cells(LINHA, 15) = F_2.Abox30.Text
  'limpar exames
  For coluna = 17 To 40
  wksDes.Cells(LINHA, coluna) = ""
  Next coluna
  ' preencher dados
  Call exames
  Call salvarultimoexame
      ' fechar
  wkbDes.Close SaveChanges:=True
  Call FILTRO_ATENDIMENTO_PACIENTE
  MsgBox "Dados Alterado com Sucesso" & " id n° " & F_2.cod5.Value
Else
wkbDes.Close SaveChanges:=True
Exit Sub
End If
LINHA = LINHA + 1
Loop


Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub exames()
Set wkbDes = Workbooks.Open(ThisWorkbook.Path & "\CADASTRO DE ATENDIMENTOS.xlsx")
Set wksDes = wkbDes.Worksheets("c_exame")
'F_2.Abox7.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna) = F_2.Abox7.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop

'F_2.Abox8.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna) = F_2.Abox8.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox9.Valuue
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox9.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox10.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox10.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox11.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox11.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox12.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox12.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox13.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox13.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox14.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox14.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox15.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox15.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox16.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox16.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox17.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox17.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox18.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox18.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox19.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox19.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox20.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox20.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox21.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox21.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox22.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox22.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox23.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox23.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
'F_2.Abox24.Value
coluna = 17
i = wksDes.Cells(1, 1).End(xlDown).Row
Do Until wksDes.Cells(1, coluna) = ""
If wksDes.Cells(1, coluna).Value = F_2.Abox24.Value Then
wksDes.Cells(i, coluna) = "1"
For coluna = 17 To 40
Next coluna
End If
coluna = coluna + 1
Loop
End Sub
Sub salvarultimoexame()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Aviso
' salvar ultimo exame no cadastro
Dim valorpesquisa
valorpesquisa = F_2.cod3.Value
sql = "SELECT * FROM PACIENTES where COD like '" & valorpesquisa & "'"

Call CONECTADB
'*carrega lista de dados
Set RS = New ADODB.Recordset
RS.Open sql, db, 3, 3
'On Error Resume Next
'salva
  RS.Update
  If F_2.op2 = True Then
  RS!situação = "Inativo"
  Else
  RS!situação = "Ativo"
  End If
  RS!U_consulta = F_2.Abox1
  RS.Update

'desconectar
Call fechadb
Exit Sub
Aviso: MsgBox "Paciente não Cadastrado"
   'habilitar novamente
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Sub exportar_guia()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
    Static wod1 As Word.Application
    Static wod1Doc As Word.Document
    
    Set wod1 = New Word.Application
    Set wod1Doc = wod1.Documents.Add(ThisWorkbook.Path & "\Guia de Encaminhamento.docx")
         
         With wod1Doc
            .FormFields("WD1").Range = F_2.Abox5.Text 'ENCAMINHAMENTO
            .FormFields("WD2").Range = F_2.Abox1.Text 'DATA
            .FormFields("WD3").Range = F_2.box11.Text 'EMPRESA
            .FormFields("WD4").Range = F_2.box1.Text 'NOME DO PACIENTE
            .FormFields("WD5").Range = F_2.box5.Text  'DN
            .FormFields("WD6").Range = F_2.box4.Text 'DOC
            .FormFields("WD7").Range = F_2.Abox26.Text 'TIPO DE EXAME
            .FormFields("WD8").Range = F_2.box12.Text 'FUNÇÃO

            .FormFields("WD9").Range = F_2.Abox7.Text
            .FormFields("WD10").Range = F_2.Abox8.Text
            .FormFields("WD11").Range = F_2.Abox9.Text
            .FormFields("WD12").Range = F_2.Abox10.Text
            .FormFields("WD13").Range = F_2.Abox11.Text
            .FormFields("WD14").Range = F_2.Abox12.Text
            .FormFields("WD15").Range = F_2.Abox13.Text
            .FormFields("WD16").Range = F_2.Abox14.Text
            .FormFields("WD17").Range = F_2.Abox15.Text
            .FormFields("WD18").Range = F_2.Abox16.Text
            .FormFields("WD19").Range = F_2.Abox17.Text
            .FormFields("WD20").Range = F_2.Abox18.Text
            .FormFields("WD21").Range = F_2.Abox19.Text
            .FormFields("WD22").Range = F_2.Abox20.Text
            .FormFields("WD23").Range = F_2.Abox21.Text
            .FormFields("WD24").Range = F_2.Abox22.Text
            .FormFields("WD25").Range = F_2.Abox23.Text
            .FormFields("WD26").Range = F_2.Abox24.Text
            wod1.Visible = True
         End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub exportar_exame()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Dim OBS As String
OBS = F_2.ALTURA.Value & " " & F_2.CONFINAMENTO.Value & " " & F_2.VEICULOS.Value

    Static wod1 As Word.Application
    Static wod1Doc As Word.Document
    Set wod1 = New Word.Application
    Set wod1Doc = wod1.Documents.Add(ThisWorkbook.Path & "\ASO.docx")
         With wod1Doc
            .FormFields("WD27").Range = FormatDateTime(F_2.Abox1, vbLongDate) 'DATA
            .FormFields("WD1").Range = F_2.box11.Text 'EMPRESA
            .FormFields("WD2").Range = F_2.box1.Text 'NOME DO PACIENTE
            .FormFields("WD3").Range = F_2.box4.Text 'DOC
            .FormFields("WD4").Range = F_2.box6.Text 'idade
            .FormFields("WD5").Range = F_2.box5.Text  'DN
            .FormFields("WD6").Range = F_2.box12.Text 'FUNÇÃO
            .FormFields("wd29").Range = F_2.box3.Text 'tipo doc
            .FormFields("WD28").Range = F_2.TextBox1.Text 'setor
            
            .FormFields("WD7").Range = F_2.Abox26.Text 'TIPO DE EXAME
            .FormFields("WD8").Range = OBS   'observações
            
            .FormFields("WD9").Range = F_2.Abox7.Text
            .FormFields("WD10").Range = F_2.Abox8.Text
            .FormFields("WD11").Range = F_2.Abox9.Text
            .FormFields("WD12").Range = F_2.Abox10.Text
            .FormFields("WD13").Range = F_2.Abox11.Text
            .FormFields("WD14").Range = F_2.Abox12.Text
            .FormFields("WD15").Range = F_2.Abox13.Text
            .FormFields("WD16").Range = F_2.Abox14.Text
            .FormFields("WD17").Range = F_2.Abox15.Text
            .FormFields("WD18").Range = F_2.Abox16.Text
            .FormFields("WD19").Range = F_2.Abox17.Text
            .FormFields("WD20").Range = F_2.Abox18.Text
            .FormFields("WD21").Range = F_2.Abox19.Text
            .FormFields("WD22").Range = F_2.Abox20.Text
            .FormFields("WD23").Range = F_2.Abox21.Text
            .FormFields("WD24").Range = F_2.Abox22.Text
            .FormFields("WD25").Range = F_2.Abox23.Text
            .FormFields("WD26").Range = F_2.Abox24.Text
             wod1.Visible = True
         End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub limpar_atendimento()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
F_2.op1 = False
F_2.op2 = False
F_2.op3 = False
F_2.op4 = False
F_2.op5 = False

F_2.acheck1 = False
F_2.acheck2 = False
F_2.aCheck3 = False

F_2.Abox7 = ""
F_2.Abox8 = ""
F_2.Abox9 = ""
F_2.Abox10 = ""
F_2.Abox11 = ""
F_2.Abox12 = ""
F_2.Abox13 = ""
F_2.Abox14 = ""
F_2.Abox15 = ""
F_2.Abox16 = ""
F_2.Abox17 = ""
F_2.Abox18 = ""
F_2.Abox19 = ""
F_2.Abox20 = ""
F_2.Abox21 = ""
F_2.Abox22 = ""
F_2.Abox23 = ""
F_2.Abox24 = ""
F_2.Abox26 = ""
'habilitar novamente
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Anexos
SaudeTRAB.zip
(1.51 MiB) Baixado 1 vez



Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder