Vídeo recomendado
https://youtu.be/diWPPPhW-9E

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: 23
Registrado em: Qua Jun 26, 2019 5:56 pm

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

Mensagem por anielise »

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: 23
Registrado em: Qua Jun 26, 2019 5:56 pm

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

Mensagem por anielise »

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: 1537
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 »

"...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


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
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 »

"...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


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: 23
Registrado em: Qua Jun 26, 2019 5:56 pm

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

Mensagem por anielise »

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: 1537
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 »

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


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

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

Mensagem por anielise »

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 898 vezes


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

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

Mensagem por anielise »

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 859 vezes


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