Ver Mensaje Individual
  #2  
Antiguo 22-04-2025
NANAUJ1970 NANAUJ1970 is offline
Miembro
NULL
 
Registrado: jul 2017
Posts: 9
Reputación: 0
NANAUJ1970 Va por buen camino
Una buena forma de hacerlo es usando autofirma. Lo puedes descargar gratuitamente e instalarlo. Este accede al almacen de certificados de windows.

Aqui tienes un codigo en D7 para firmar un xml usando el metodo de autofirma. Hay que pasarle los parametros nombre del fichero xml normal y el nombre que quieres que cree firmado.

Código Delphi [-]
USES    Capicom_TLB,....

procedure FirmarXML(const XMLFileName: string; const SignedXMLFileName: string);
var
  CertStore: IStore;
  Certs: ICertificates;
  Cert: ICertificate2;
  i: Integer;
  CertName: string;
  CertBuscar: string;
  TempVar: OleVariant;
  TempCert: ICertificate;
  AliasCertificado: string;
  AutoFirmaPath: string;
  RutaAutoFirma: string;
  certpassword: string;
  Comando: string;
begin


  AutoFirmaPath:=ansilowercase(f.Buscarautofirmapath);
  AutoFirmaPath := trim(StringReplace(AutoFirmaPath, '"%1"', '', [rfReplaceAll]));
  AutoFirmaPath := trim(StringReplace(AutoFirmaPath, 'autofirma.exe', 'AutoFirmaCommandLine.exe', [rfReplaceAll]));
  if autoFirmaPath='' then  begin
      f.Aviso('error','No Se Encuentra AutoFirma En Registro '+autoFirmaPath);
      exit;
  end;
  rutaAutoFirma:=extractfilePath( autoFirmaPath )+'AutoFirmaCommandLine.exe';
  if not FileExists(rutaAutoFirma) then begin
      f.Aviso('error','No Se Encuentra Ejecutable AutoFirma '+rutaAutoFirma);
      exit;
  end;
  // AutoFirmaPath := 'C:\Program Files\AutoFirma\AutoFirma\AutoFirmaCommandLine.exe'; // path indicado manualmente

  try
    // Verificar que AutoFirma est� instalado
    if not FileExists(AutoFirmaPath) then
    begin
      ShowMessage('AutoFirma no encontrado en: ' + AutoFirmaPath);
      Exit;
    end;

    // Abrir el almac�n de certificados del usuario actual
    CertStore := CoStore.Create;
    CertStore.Open(CAPICOM_CURRENT_USER_STORE, 'My', CAPICOM_STORE_OPEN_READ_ONLY);
    Certs := CertStore.Certificates;

    // Buscar certificado por coincidencia en el SubjectName
    CertBuscar := 'nombreparcial'; // Cambiar por parte del nombre del certificado
    Cert := nil;
    for i := 1 to Certs.Count do
    begin
      TempVar := Certs.Item[i];
      if Supports(TempVar, ICertificate, TempCert) then
      begin
        if Pos(CertBuscar, TempCert.SubjectName) > 0 then
        begin
          Cert := TempCert as ICertificate2;
          AliasCertificado := TempCert.SubjectName;
          f_entrada.Memo1.Lines.Add('Certificado encontrado: ' + AliasCertificado);
          Break;
        end;
      end;
    end;

    if Cert = nil then
    begin
      ShowMessage('Certificado no encontrado con: ' + CertBuscar);
      Exit;
    end;

    AliasCertificado := ExtraerCN(TempCert.SubjectName);

    //AliasCertificado := 'ANTONIO_FLORES_41000000Z'; // SI QUIERES ESPECIFICAR EL NOMBRE DIRECTAMENTE

    // Construir el comando
    RutaAutoFirma := ExtractShortPathName(AutoFirmaPath);
    Comando := Format('%s sign -format xades -i "%s" -o "%s" -store windows -password "" -alias "%s"',
                    [RutaAutoFirma, XMLFileName, SignedXMLFileName, AliasCertificado]);

    // Ejecutar AutoFirma y esperar que termine
    ExecuteAndWait(Comando);


    // Verificar si se gener� el archivo firmado
    if not FileExists(SignedXMLFileName) then
      ShowMessage('Error firmando el XML.')

  except
    on E: Exception do begin
      ShowMessage('Excep: Error al firmar XML: ' + E.Message);
    end;
  end;

end;

procedure ExecuteAndWait(const aCommando: string);
var
  tmpStartupInfo: TStartupInfo;
  tmpProcessInformation: TProcessInformation;
  tmpProgram: String;
begin
  tmpProgram := trim(aCommando);
//  f_entrada.Memo1.Lines.add('Executing: ' + tmpProgram); // Mostrar la instrucción que se ejecuta
  FillChar(tmpStartupInfo, SizeOf(tmpStartupInfo), 0);
  with tmpStartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    wShowWindow := SW_HIDE;
  end;

  if CreateProcess(nil, pchar(tmpProgram), nil, nil, true, CREATE_NO_WINDOW,
    nil, nil, tmpStartupInfo, tmpProcessInformation) then
  begin
    // loop every 10 ms
    while WaitForSingleObject(tmpProcessInformation.hProcess, 10) > 0 do
    begin
      Application.ProcessMessages;
    end;
    CloseHandle(tmpProcessInformation.hProcess);
    CloseHandle(tmpProcessInformation.hThread);
  end
  else
  begin
    RaiseLastOSError;
  end;
end;

Última edición por dec fecha: 25-04-2025 a las 08:25:57. Razón: Poner etiquetas DELPHI
Responder Con Cita