Copying lines

Navigation
-2

Good morning,

Can anyone help me with an example of vba to be used in copying spring lines? When I am copying from a source document to a target document, I am able to pass the document rows, but I am not able to pass the user fields relative to the document header. 

Private Sub EditorCopiaLinhas_AntesDeCopiar(ByVal ModuloOrigem As String, ObjectoOrigem As Object, ByVal ModuloDestino As String, ObjectoDestino As Object, Cancel As Boolean)

Dim objOrigem As GcpBEDocumentoCompra
Dim objDestino As GcpBEDocumentoCompra
Dim i As Long

i = 1
    If ModuloDestino = "C" Then

        Set ComprasOrigem = ObjectoOrigem
        Set ComprasDestino = ObjectoDestino


         While i <= ComprasDestino.Linhas.NumItens
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_DataDocumento") = ComprasOrigem.Linhas(i).CamposUtil("CDU_DataDocumento").Valor
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_Descricao2") = ComprasOrigem.Linhas(i).CamposUtil("CDU_Descricao2").Valor
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_Entidade") = ComprasOrigem.Linhas(i).CamposUtil("CDU_Entidade").Valor
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_NrComprovante") = ComprasOrigem.Linhas(i).CamposUtil("CDU_NrComprovante").Valor
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_NumDocExterno") = ComprasOrigem.Linhas(i).CamposUtil("CDU_NumDocExterno").Valor
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_TaxaIvaEstrangeiro") = ComprasOrigem.Linhas(i).CamposUtil("CDU_TaxaIvaEstrangeiro").Valor
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_TipoDoc") = ComprasOrigem.Linhas(i).CamposUtil("CDU_TipoDoc").Valor
            ComprasDestino.Linhas.Edita(i).CamposUtil("CDU_TipoEntidade") = ComprasOrigem.Linhas(i).CamposUtil("CDU_TipoEntidade").Valor
            i = i + 1
          Wend
    End If
End Sub
    
asked by anonymous 07.08.2018 / 13:55

1 answer

1

The copy of CDUs can only be done (at least directly) if the source document and the destination document are from the same module (Sales -> Sales, Purchases -> Purchases, etc.), otherwise validate one by one to make a valid match.

Copying lines can be done as follows (with CDUs included): 

Private Sub CopiaLinhas()
Dim objDocOrigem    As GcpBEDocumentoVenda
Dim objDocDestino   As GcpBEDocumentoVenda
Dim lngLinha        As Long
Dim strAvisos       As String

    On Error GoTo Erro

    'Obter o documento de origem
    Set objDocOrigem = BSO.Comercial.Vendas.Edita("000", "ECL", "2018", 1)
    Set objDocDestino = New GcpBEDocumentoVenda

    'Inicializar o documento de destino
    With objDocDestino
        .TipoDoc = "ECL"
        .Serie = "2018"
        .TipoEntidade = "C"
        .Entidade = "SOFRIO"
    End With

    'Preencher todos os dados relacionados
    BSO.Comercial.Vendas.PreencheDadosRelacionados objDocDestino

    If Not objDocOrigem Is Nothing Then
        'Copiar linhas
        For lngLinha = 1 To objDocOrigem.Linhas.NumItens
            BSO.Comercial.Internos.CopiaLinhaEX "V", objDocOrigem, "V", objDocDestino, lngLinha
        Next

        'Validar se existem CDU no cabeçalho e copiar em caso afirmativo
        If objDocOrigem.CamposUtil.NumItens > 0 Then
            Set objDocDestino.CamposUtil = objDocOrigem.CamposUtil
        End If

        'Gravar o documento de destino
        BSO.Comercial.Vendas.Actualiza objDocDestino, strAvisos
    End If

    'Caso tenham sido emitidos avisos, mostrá-los numa mensagem
    If LenB(strAvisos) > 0 Then
        PlataformaPRIMAVERA.Dialogos.MostraMensagem PRI_SimplesOk, strAvisos, PRI_Informativo
    End If

    Set objDocOrigem = Nothing
    Set objDocDestino = Nothing

    Exit Sub

Erro:
    'Mostrar o erro numa mensagem
    PlataformaPRIMAVERA.Dialogos.MostraErro Err.Description, PRI_Exclama
End Sub

It should be noted that the TipoDoc , Serie , NumDoc , Filial , TipoEntidade and Entidade should be changed to the desired values.

    
07.08.2018 / 15:15
Where is the error? "system is not declared in this scope" CSS does not load in mobile version when installing SSL certificate free