MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    [Resolvido]Duplicar registros em subformulários

    avatar
    Helden
    Intermediário
    Intermediário

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 96
    Registrado : 27/05/2016

    [Resolvido]Duplicar registros em subformulários Empty [Resolvido]Duplicar registros em subformulários

    Mensagem  Helden 16/9/2021, 17:35

    Boa tarde pessoal, realizei bastante pesquisa para tentar duplicar registros em subsubformulario com combobox, estou com dificuldades.

    tenho resumidamente:
    Fml_Paciente
        fonte de registro:  Tbl_Paciente  
              registros : CódigoPaciente; NomePaciente; DN

    Subformulário : Fml_Receita
        fonte de registro: consulta
              Tbl_Receita
                 registros: CódigoReceita, CódigoPaciente, DataReceita, Protocolo

    SubSubFormulário: Fml_ItensDaReceita
           fonte de registro: Tbl_ItensDaReceita
                   combobox: Medicamento (fonte de controle Tbl_ItensDaReceita; Origem da linha tblMedicamento
                   combobox: Dose (fonte de controle Tbl_ItensDaReceita; Origem da linha tblDose

    Tabelas vinculadas

    Ja tentei :
    Private Sub Comando30_Click()
    DoCmd.RunCommand acCmdSelectRecord
    DoCmd.RunCommand acCmdCopy
    DoCmd.GoToRecord , , acNewRec
    DoCmd.RunCommand acCmdPaste
    End Sub
    ________________________________________________________________
    Private Sub Comando31_Click()
    If MsgBox("Confirma a duplicação?", vbQuestion + vbYesNo) = vbYes Then
    Dim IDNovo As Long
    CurrentDb.Execute "INSERT INTO Tbl_Receita (CódigoPaciente, DataReceita, Protocolo) SELECT CódigoPaciente, DataReceita, Protocolo
    FROM Tbl_Receita WHERE CódigoReceita= " & Me! CódigoReceita & ";", dbFailOnError
    IDNovo = DMax("CódigoReceita", Me.RecordSource)
    CurrentDb.Execute "INSERT INTO Tbl_ItensDaReceita (CódigoReceita, Medicamento, Quantidade, Posologia, Dose, Dosagem, Peso_ou_SC,
    Unidade, Tempo_de_Infusão, Via, Unidade_da_Dosagem, Obs, Protocolo, Hora_da_aplicação) SELECT " & IDNovo & ", Medicamento,
    Quantidade, Posologia, Dose,
    Dosagem, Peso_ou_SC, Unidade, Tempo_de_Infusão, Via, Unidade_da_Dosagem, Obs, Protocolo, Hora_da_aplicação
    WHERE CódigoReceita= " & Me!CódigoReceita & ";", dbFailOnError
    Me.Requery
    End If
    End If
    End Sub
    ___________________________________________________________________________
    TEntei também a macro do botão duplicar mas não duplica os registros das combobox no SubSubformulario
    _____________________________________________________________________________________
    tentei esse código, ele até emite a mensagem de registros duplicados, mas preciso colocar o CódigoPaciente na Tbl_Receita. o mesmo CódigoPaciente para todas receitas porque o paciente é o mesmo, só vai duplicar as receitas. Como coloco na Tbl_Receita o CódigoPaciente? neste código abaixo:
    O formulario principal é Fml_Paciente (tbl_Paciente)

    Private Sub Comando31_Click()

    Dim bd As dao.Database
    Dim rs As dao.Recordset 'tbl_Receita
    Dim rsOF As dao.Recordset 'tbl_ItensDaReceita
    Dim rst As dao.Recordset 'subformulario
    Dim Duplicar As Integer
    Dim i As Integer


    If IsNull(Me.txtDuplicar) Then

    MsgBox "Aten??o! Preencha a quantidade de registros a serem duplicados.", , "Aten??o!"
    Exit Sub

    End If

    Set bd = CurrentDb()
    Set rs = bd.OpenRecordset("Tbl_Receita")

    Duplicar = txtDuplicar
    For i = 1 To Duplicar
    'pri
    meiro cria o novo CódigoReceita na Tbl_Receita
    rs.AddNew
    rs.Fields("DataReceita") = Me!DataReceita
    rs.Update
    DoCmd.RunCommand acCmdSaveRecord 'Salvo o Registro
    'abre a tabela para inserir os registros copiados
    Set rsOF = bd.OpenRecordset("Tbl_ItensDaReceita")
    'fazendo referencia ao subformulario
    Set rst = Me.Fml_ItensDaReceita.Form.Recordset
    rst.MoveFirst 'Vai percorrer todo o subformulario
    Do While Not rst.EOF ' ate o fim
    With rst
    rsOF.AddNew
    rsOF!CódigoReceita = DLast("CódigoReceita", "Tbl_Receita") 'Busca o ultimo CódigoReceita para fazer a vincula??o entre os registros
    'estes s?o campos que voce quer copiar
    rsOF!Medicamento = rst!Medicamento
    rsOF.Update
    .MoveNext
    End With
    Loop

    Next i

    MsgBox "Registros replicados!", vbInformation, "Replica??o!"

    Set rs = Nothing
    Set rst = Nothing
    Set rsOF = Nothing
    End Sub
    avatar
    Helden
    Intermediário
    Intermediário

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 96
    Registrado : 27/05/2016

    [Resolvido]Duplicar registros em subformulários Empty Re: [Resolvido]Duplicar registros em subformulários

    Mensagem  Helden 19/9/2021, 20:24

    Ficou assim: pessquisa no forum codigo do Escandinavo
    Private Sub Comando31_Click()

    Dim bd As dao.Database
    Dim rs As dao.Recordset 'tbl_Receita
    Dim rsOF As dao.Recordset 'tbl_ItensDaReceita
    Dim rst As dao.Recordset 'subformulario
    Dim Duplicar As Integer
    Dim i As Integer


    If IsNull(Me.txtDuplicar) Then

    MsgBox "Aten??o! Preencha a quantidade de registros a serem duplicados.", , "Aten??o!"
    Exit Sub

    End If

    Set bd = CurrentDb()
    Set rs = bd.OpenRecordset("Tbl_Receita")
    Duplicar = txtDuplicar
    For i = 1 To Duplicar
    'primeiro cria o novo CódigoReceita na Tbl_Receita
    rs.AddNew
    rs.Fields("DataReceita") = Me!DataReceita
    rs.Fields("CódigoPaciente") = Me!CódigoPaciente
    rs.Update

    DoCmd.RunCommand acCmdSaveRecord 'Salvo o Registro
    'abre a tabela para inserir os registros copiados
    Set rsOF = bd.OpenRecordset("Tbl_ItensDaReceita")
    'fazendo referencia ao subformulario
    Set rst = Me.Fml_ItensDaReceita.Form.Recordset
    rst.MoveFirst 'Vai percorrer todo o subformulario
    Do While Not rst.EOF ' ate o fim
    With rst
    rsOF.AddNew
    rsOF!CódigoReceita = DLast("CódigoReceita", "Tbl_Receita") 'Busca o ultimo CódigoReceita para fazer a vincula??o entre os registros
    'estes s?o campos que voce quer copiar
    rsOF!Medicamento = rst!Medicamento
    rsOF.Update
    .MoveNext
    End With
    Loop

    Next i

    MsgBox "Registros replicados!", vbInformation, "Replica??o!"

    Set rs = Nothing
    Set rst = Nothing
    Set rsOF = Nothing

    End Sub

    obs: coloquei ao mover mouse nos subformularios o Me.Requery e Me.Refresh para acarregar os forrmularios.

      Data/hora atual: 16/10/2021, 17:49