Convertir de .doc a .pdf
#1
Escrito 21 mayo 2014 - 05:22
¿Cómo hago para convertir un .doc que tengo en un directorio a un .pdf?
Lo quiero de manera nativa, los clientes no quieren usar pdfcreator o parecidos.
¿Algún código que resuelva el problema?
Gracias.
______________
#2
Escrito 21 mayo 2014 - 07:37
Ahí mismo verás componentes para delphi
Saludos
#3
Escrito 21 mayo 2014 - 07:50
Esto:
uses OleAuto; const wdExportFormatPDF = 17; var Word, Doc: OleVariant; begin Word := CreateOLEObject('Word.Application'); Doc := Word.Documents.Open('C:\Document.docx'); Doc.ExportAsFixedFormat('C:\Document.pdf', wdExportFormatPDF); end;
Lo vi aqui: http://stackoverflow...ng-word-activex
Saludos
PD: Etiquetas delphi
#4
Escrito 22 mayo 2014 - 05:53
Hola
Esto:
delphi
uses OleAuto; const wdExportFormatPDF = 17; var Word, Doc: OleVariant; begin Word := CreateOLEObject('Word.Application'); Doc := Word.Documents.Open('C:\Document.docx'); Doc.ExportAsFixedFormat('C:\Document.pdf', wdExportFormatPDF); end;
Lo vi aqui: http://stackoverflow...ng-word-activex
Saludos
PD: Etiquetas delphi
He probado con esta opción y me sale el siguiente error:
"La exportación produjo un error porque esta característica no está instalada"
Lo he probado en W8, 64bits, D7.
También lo he hecho en WXP, 32bits, D7.
En ambos casos me dió el mismo error.
El archivo que usé era .doc y no .docx
¿Cómo arreglo el dilema? La verdad es que está buena la forma de exportación. Tengo instalado Office 2007 en W8 y Office 2003 en WXP.
#5
Escrito 22 mayo 2014 - 05:56
#6
Escrito 22 mayo 2014 - 08:13
Y no será que intentas crearlos en la raíz de "C", ¿ porque no lo agregas en un directorio personal ? Yo usé el disco "F" de mi máquina y funciona sin problemas.
Saludos
#7
Escrito 22 mayo 2014 - 08:17
1) Tener instalada alguna versiónd de Office. En mi caso, tengo Office 2007.
2) Esa instalación debe tener el complemento que le permite a Word salvar archivos como pdf. Eso se consigue en la página de Microsoft.
Con estas dos cositas en su lugar, todo va bien.
Ahora si hace la exportación como lo queremos.
Gracias.
#8
Escrito 22 mayo 2014 - 09:47
Por cierto, creo que este sistema solo funciona a partir de Office 2007, los anteriores creo que no tenían este filtro de exportación, o al menos no de fábrica leí por algún sitio.
#9
Escrito 22 mayo 2014 - 10:16
Santiago.
#10
Escrito 22 mayo 2014 - 10:17
Otra pción es tener instalado OpenOffice o LibreOffice, ambos tienen filtros para exportar a PDF de fábrica, aunque el resultado es el mismo que con MS-Office.
Esto es bueno saberlo, no todos quieren comprar una licencia de Office solamente para poder hacer una exportación desde Delphi de sus archivos .doc o .docx
#11
Escrito 22 mayo 2014 - 10:20
Otra pción es tener instalado OpenOffice o LibreOffice, ambos tienen filtros para exportar a PDF de fábrica, aunque el resultado es el mismo que con MS-Office.
¿Cómo hago para llamar al "Word" (Creo que es Write) de LibreOffice?
Para llamar a Word se hace:
Word := CreateOLEObject('Word.Application');
Gracias.
#12
Escrito 22 mayo 2014 - 11:20
Creo que no incluye el código para exportar a PDF, pero bueno, si acaso eso lo tengo en otra unit que maneja hojas de cálculo: https://github.com/s...hi-SpreadSheets
En ese código tienes la forma de exportar el documento actual de libreoffice a PDF, la funcion en write debería ser idéntica a esta de Calc.
#13
Escrito 22 mayo 2014 - 04:43
En mi máquina pude exportar bien. Pero en otra PC, WXP, D7 salió el siguiente error:
Method 'ExportAsFixedFormat' not supported by automation object.
P/D: Voy a analizar bien lo que mandaste Sergio, la verdad es que está bien interesante.
Santiago.
#14
Escrito 22 mayo 2014 - 05:05
Mira el código "dual" para manejar word o write que puse aquí: http://www.delphiacc...84036/#msg84036
Creo que no incluye el código para exportar a PDF, pero bueno, si acaso eso lo tengo en otra unit que maneja hojas de cálculo: https://github.com/s...hi-SpreadSheets
En ese código tienes la forma de exportar el documento actual de libreoffice a PDF, la funcion en write debería ser idéntica a esta de Calc.
Sergio, estoy intentando compilar la unit uDocumentoTexto que pasaste en uno de los links pero me dice que no puede ubicar a la unit: "Launch"
¿Dónde la consigo?
Santiago.
#15
Escrito 23 mayo 2014 - 02:26
Tal vez Uds. sepan que es esto:
En mi máquina pude exportar bien. Pero en otra PC, WXP, D7 salió el siguiente error:
Method 'ExportAsFixedFormat' not supported by automation object.
P/D: Voy a analizar bien lo que mandaste Sergio, la verdad es que está bien interesante.
Santiago.
La version de Excel creo que va a ser, la función está a partir de Excel2007 (confirmado en msn).
#16
Escrito 23 mayo 2014 - 02:59
Pongo el código de la clase que indicas:
// ********************************************* // ** Object for dual WordProcessing managing ** // ** using Word or OpenOffice automaticaly ** // ** By: Sergio Hernandez ** // ** oficina(at)hcsoft.net, CopyLeft 2004 ** // ** Version 0.3 20-10-2009 (DDMMYYYY) ** // ** Use it freely, change it, etc. ** // ********************************************* {EXAMPLE OF USE //Create object: We have two flavours: //(A) from an existing file... TxtDoc:= TDocumentoTexto.create(OpenDialog.FileName, false); //(B) from a blank document... TxtDoc:= TDocumentoTexto.create(thcOpenOffice, true); //OpenOffice doc if possible, please TxtDoc.FileName:= 'C:\MyNewDoc'; //Needs a file name before you SaveDoc! //--end of creation. //Change a text (search&replace) TxtDoc.ChangeOneValue('<MyClient>', 'Cocoa company, ltd.'); //Preview print... TxtDoc.ShowPrintPreview TxtDoc.PrintDoc; TxtDoc.SaveDoc; TxtDoc.SaveToPDF('C:\MyPDF.pdf'); TxtDoc.Free; } {ABOUT CONVERTING DOC TO PDF: //Force opening the .doc file with OOo like this: TxtDoc:= TDocumentoTexto.create(thcOpenOffice, true); TxtDoc.LoadDoc('C:\MyWord.doc'); //Now that OOo has imported the .doc, convert it: TxtDoc.SaveToPDF('C:\MyPDF.pdf'); TxtDoc.Free; } {HISTORIY: V0.3 - SaveToPDF for OpenOffice added from www.oooforum.org/forum/viewtopic.phtml?t=22344 V0.2 - WaitForIddle added to avoid Word behavior (saving before completing work) V0.1 - Initial version, it works ok. } {TODO LIST: -No functions to add text, change font, bold, etc. -Can I know the OOo writer printing status like in Word? -Can I know if Word/Writer is doing something in background? } unit UDocumentoTexto; interface uses Variants, SysUtils, ComObj, Classes, Launch; //thcError: Tried to open but both failes //thcNone: Haven't tried still to open type TTipoDoc = (thcError, thcNone, thcWord, thcOpenOffice); type TDocumentoTexto = class(TObject) private fVisible: boolean; //Program loaded stuff... procedure LoadProg; procedure CloseProg; function GetProgLoaded: boolean; procedure NewDoc; procedure LoadDoc; procedure CloseDoc; function GetDocLoaded: boolean; function GetIsWord: boolean; function GetIsOpenOffice: boolean; procedure SetVisible(v: boolean); //OpenOffice only stuff... function FileName2URL(FileName: string): string; procedure ooDispatch(ooCommand: string; ooParams: variant); function ooCreateValue(ooName: string; ooData: variant): variant; function isNullEmpty(thisVariant: Variant): Boolean; public Tipo: TTipoDoc; //Witch program was used to manage the doc? FileName: string; //In windows FileName format C:\MyDoc.XXX Programa: variant; //Word or OpenOfice instance created. DeskTop: variant; //OpenOffice desktop reference (not used now). Document: variant; //Document opened. //Object internals... constructor Create(Name: string; MakeVisible: boolean); overload; constructor Create(MyTipo: TTipoDoc; MakeVisible: boolean); overload; destructor Destroy; override; //Program loaded stuff... function SaveDoc: boolean; function SaveToPDF(FileName: string): boolean; function PrintDoc: boolean; procedure ShowPrintPreview; property ProgLoaded: boolean read GetProgLoaded; property DocLoaded: boolean read GetDocLoaded; property IsWord: boolean read GetIsWord; property IsOpenOffice: boolean read GetIsOpenOffice; property Visible: boolean read fVisible write SetVisible; //Special function (Search & Replace) procedure ChangeOneValue(SearchTxt, ReplaceTxt: String; Headers: boolean = true); //Wait until word end doing its things function WaitForIddle(MaxSec: double = 30): double; end; var CoInitFlags: Integer = -1; const SearchAll: integer = 2; //Word search_for_all (0=None, 1=Once, 2=All) implementation // ************************ // ** Create and destroy ** // ************************ //Create with an empty doc of requested type (use thcWord, thcOpenOffice) //Remember to define FileName before calling to SaveDoc constructor TDocumentoTexto.Create(MyTipo: TTipoDoc; MakeVisible: boolean); var i: integer; IsFirstTry: boolean; begin //Close all opened things first... CloseDoc; CloseProg; //I will try to open twice, so if Word fails, OpenOffice is used instead IsFirstTry:= true; for i:= 1 to 2 do begin //Try to open OpenOffice... if (MyTipo = thcOpenOffice) or (MyTipo = thcNone)then begin try Programa:= CreateOleObject('com.sun.star.ServiceManager'); except end; if ProgLoaded then begin Tipo:= thcOpenOffice; break; end else begin if IsFirstTry then begin //Try Excel as my second choice MyTipo:= thcWord; IsFirstTry:= false; end else begin //Both failed! break; end; end; end; //Try to open Word... if (MyTipo = thcWord) or (MyTipo = thcNone) then begin try Programa:= CreateOleObject('Word.Application'); except end; if ProgLoaded then begin Tipo:= thcWord; break; end else begin if IsFirstTry then begin //Try OpenOffice as my second choice MyTipo:= thcOpenOffice; IsFirstTry:= false; end else begin //Both failed! break; end; end; end; end; //Was it able to open any of them? if Tipo = thcNone then begin Tipo:= thcError; raise Exception.Create('TDocumentoTexto.create failed, may be no Office is installed?'); end; //Add a blank document... fVisible:= MakeVisible; NewDoc; end; constructor TDocumentoTexto.Create(Name: string; MakeVisible: boolean); begin //Close all opened things first... CloseDoc; CloseProg; Tipo:= thcNone; //Store values... FileName:= Name; //Open program and document... LoadProg; LoadDoc; //Visible? Visible:= MakeVisible; end; destructor TDocumentoTexto.Destroy; begin CloseProg; inherited; end; // ************************* // ** Loading the program ** // ** Word or OpenOffice ** // ************************* procedure TDocumentoTexto.LoadProg; begin if ProgLoaded then CloseProg; if (UpperCase(ExtractFileExt(FileName))='.DOC') then begin //Word is the primary choice... try Programa:= CreateOleObject('Word.Application'); except end; if ProgLoaded then Tipo:= thcWord; end; //Not lucky with Word? Another filetype? Let's go with OpenOffice... if Tipo = thcNone then begin //Try with OpenOffice... try Programa:= CreateOleObject('com.sun.star.ServiceManager'); except end; if ProgLoaded then Tipo:= thcOpenOffice; end; //Still no program loaded? if not ProgLoaded then begin Tipo:= thcError; raise Exception.Create('TDocumentoTexto.LoadProg failed, may be no Office is installed?'); end; end; procedure TDocumentoTexto.CloseProg; begin if not Visible then CloseDoc; if ProgLoaded then begin try if IsWord then begin Programa.Quit; Programa:= Null; end; if IsOpenOffice then begin Desktop.Dispose; Desktop:= unassigned; Programa.Dispose; end; Programa:= Unassigned; except end; end; Tipo:= thcNone; end; //Is there any prog loaded? Witch one? function TDocumentoTexto.GetProgLoaded: boolean; begin result:= not isNullEmpty(Programa); end; function TDocumentoTexto.GetIsWord: boolean; begin result:= (Tipo=thcWord); end; function TDocumentoTexto.GetIsOpenOffice: boolean; begin result:= (Tipo=thcOpenOffice); end; // ************************ // ** Loading a document ** // ************************ procedure TDocumentoTexto.NewDoc; var ooParams: variant; begin //Is the program running? (Word or OpenOffice) if not ProgLoaded then raise Exception.Create('No program loaded for the new document.'); //Is there a doc already loaded? CloseDoc; DeskTop:= Unassigned; //OK, now try to create the doc... if IsWord then begin Programa.WorkBooks.Add; Programa.Visible:= Visible; Document:= Programa.ActiveWorkBook; end; if IsOpenOffice then begin Desktop:= Programa.CreateInstance('com.sun.star.frame.Desktop'); //Optional parameters (visible)... ooParams:= VarArrayCreate([0, 0], varVariant); ooParams[0]:= ooCreateValue('Hidden', false); // çç not Visible); //Create the document... Document:= Desktop.LoadComponentFromURL('private:factory/swriter', '_blank', 0, ooParams); end; end; procedure TDocumentoTexto.LoadDoc; var ooParams: variant; begin if FileName='' then exit; //Is the program running? (Word or OpenOffice) if not ProgLoaded then LoadProg; //Is there a doc already loaded? CloseDoc; DeskTop:= Unassigned; //OK, now try to open the doc... if IsWord then begin Document:= Programa.Documents.Open(string(FileName),,,,,,,,,,,true); end; if IsOpenOffice then begin Desktop:= Programa.CreateInstance('com.sun.star.frame.Desktop'); //Optional parameters (visible)... ooParams:= VarArrayCreate([0, 0], varVariant); ooParams[0]:= ooCreateValue('Hidden', false); //Should be "not Visible" but didn't work ok //Open the document... Document:= Desktop.LoadComponentFromURL(FileName2URL(FileName), '_blank', 0, ooParams); if isNullEmpty(Document) then raise Exception.Create('Could load the document "'+FileName+'".'); end; if Tipo=thcNone then raise Exception.Create('Could load the document "'+FileName+'". No Word processor installed?.'); end; function TDocumentoTexto.SaveDoc: boolean; begin result:= false; if DocLoaded then begin if IsWord then begin Document.Save; result:= true; end; if IsOpenOffice then begin //There is another method, more powerfull, see SaveToPDF function. Document.Store; result:= true; end; end; end; //If you are using OOo, you can export to PDF directly. //In word, the only choice is to use a PDF printer, out of our scope here! //NOTE: If you open a HTML in OOo, the param 0 need to be diferent as commented //Code refactored from an example by Ryan at: // http://www.oooforum.org/forum/viewtopic.phtml?t=22344 function TDocumentoTexto.SaveToPDF(FileName: string): boolean; var ooParams: variant; begin result:= false; if DocLoaded then begin if IsOpenOffice then begin //Word can't export to PDF! ooParams:= VarArrayCreate([0, 0], varVariant); //If the doc loaded is a HTML, you should use this param[0] instead: //ooParam[0]:= ooCreateValue('FilterName', 'writer_web_pdf_Export') ooParams[0]:= ooCreateValue('FilterName', 'writer_pdf_Export'); Document.StoreToURL(FileName2URL(FileName), ooParams); end; end; end; //Print the Doc... function TDocumentoTexto.PrintDoc: boolean; var ooParams: variant; begin result:= false; if DocLoaded then begin if IsWord then begin Document.PrintOut; while Programa.BackgroundPrintingStatus > 0 do sleep(500); result:= true; end; if IsOpenOffice then begin ooParams:= VarArrayCreate([0, 0], varVariant); ooParams[0]:= ooCreateValue('Wait', true); Document.Print(ooParams); //Can't know printing status (maybe it is possible) //So wait for process to iddle (under 0.5% CPU) WaitForIddle; result:= true; end; end; end; procedure TDocumentoTexto.ShowPrintPreview; begin if DocLoaded then begin //Force visibility of the doc... Visible:= true; if IsWord then Document.PrintOut(,,,true); if IsOpenOffice then ooDispatch('.uno:PrintPreview', Unassigned); end; end; procedure TDocumentoTexto.SetVisible(v: boolean); begin if DocLoaded and (v<>fVisible) then begin if IsWord then Programa.Visible:= v; if IsOpenOffice then begin Document.getCurrentController.getFrame.getContainerWindow.setVisible(v); end; fVisible:= v; end; end; procedure TDocumentoTexto.CloseDoc; begin if DocLoaded then begin //Close it... try if IsOpenOffice then Document.Dispose; if IsWord then Document.close; except end; //Clean up "pointer"... Document:= Null; end; end; function TDocumentoTexto.GetDocLoaded: boolean; begin result:= not isNullEmpty(Document); end; procedure TDocumentoTexto.ChangeOneValue(SearchTxt, ReplaceTxt: String; Headers: boolean = true); var j, Paso: integer; Txt, Busca, Reemp: string; ooBuscador: variant; begin case Tipo of thcWord: begin //Word can't replace with a text longer than 250! if length(ReplaceTxt) < 250 then begin Programa.ActiveDocument.Content.Find.Execute(SearchTxt, true, false, false, false, false,,,, ReplaceTxt, SearchAll); if Headers then begin //Search in page header... Programa.ActiveWindow.ActivePane.View.SeekView:= 9; //9 = wdSeekCurrentPageHeader Programa.Selection.Find.Execute(SearchTxt, true, false, false, false, false,,,,ReplaceTxt,SearchAll); //Search on footer... Programa.ActiveWindow.ActivePane.View.SeekView:= 10; //10 = wdSeekCurrentPageFooter Programa.Selection.Find.Execute(SearchTxt, true, false, false, false, false,,,,ReplaceTxt,SearchAll); end; //You can wait for Word to finish 0.1 secs. uncomenting next line... //sleep(100); //...but calling WaitForIddle after all your replaces is a better choice! end else begin //I have to "chop" the text into pieces of max. 240 chars! //NOTE: Coping from array N[] to D[] can make a DLL run out of memory //and raise rare errors, so I make it char by char! Busca:= ''; for j:= 1 to Length(SearchTxt) do Busca:= Busca+SearchTxt[j]; Reemp:= ''; for j:= 1 to Length(ReplaceTxt) do Reemp:= Reemp+ReplaceTxt[j]; Paso:= 1; repeat Txt:= copy(Reemp,1,240); Reemp:= copy(Reemp,241,9999); if (Reemp<>'') then Txt:= Txt+'[@#@'+IntToStr(Paso)+']'; Programa.ActiveDocument.Content.Find.Execute(Busca,true,false,false,false,false,,,,Txt,SearchAll); Busca:= '[@#@'+IntToStr(Paso)+']'; inc(Paso); //Need to wait for Word to finish before processing the next txt piece sleep(100); until (Reemp=''); end; end; thcOpenOffice: begin if isNullEmpty(Document) then raise Exception.Create('No text document loaded'); ooBuscador:= Document.createReplaceDescriptor; ooBuscador.SearchString:= SearchTxt; ooBuscador.ReplaceString:= ReplaceTxt; Document.ReplaceAll(ooBuscador); end; end; end; //Wait for Word to end up with all instruction we have through at it. //As Word diggest them asincronous, you never know if you are finish //and you can end up saving BEFORE all previous commands are done! //It detects it by measuring the proc %CPU usage until it drops below 0.5% function TDocumentoTexto.WaitForIddle(MaxSec: double = 30): double; var ProcName: string; begin //Process Name... if Tipo=thcWord then ProcName:= 'WINWORD.EXE' else ProcName:= 'swriter.exe'; //Wait for the %CPU to drop below 0.5% result:= WaitExeIddle(ProcName, 1, MaxSec); end; // *************************** // ** OpenOffice only stuff ** // *************************** //Change 'C:\File.txt' into 'file:///c:/File.txt' (for OpenOffice OpenURL) function TDocumentoTexto.FileName2URL(FileName: string): string; begin result:= ''; if LowerCase(copy(FileName,1,8))<>'file:///' then result:= 'file:///'; result:= result + StringReplace(FileName, '\', '/', [rfReplaceAll, rfIgnoreCase]); end; function TDocumentoTexto.ooCreateValue(ooName: string; ooData: variant): variant; var ooReflection: variant; begin if IsOpenOffice then begin ooReflection:= Programa.createInstance('com.sun.star.reflection.CoreReflection'); ooReflection.forName('com.sun.star.beans.PropertyValue').createObject(result); result.Name := ooName; result.Value:= ooData; end else begin raise Exception.Create('ooValue imposible to create, load OpenOffice first!'); end; end; procedure TDocumentoTexto.ooDispatch(ooCommand: string; ooParams: variant); var ooDispatcher, ooFrame: variant; begin if DocLoaded and IsOpenOffice then begin if (VarIsEmpty(ooParams) or VarIsNull(ooParams)) then ooParams:= VarArrayCreate([0, -1], varVariant); ooFrame:= Document.getCurrentController.getFrame; ooDispatcher:= Programa.createInstance('com.sun.star.frame.DispatchHelper'); ooDispatcher.executeDispatch(ooFrame, ooCommand, '', 0, ooParams); end else begin raise Exception.Create('Dispatch imposible, load a OpenOffice doc first!'); end; end; function TDocumentoTexto.isNullEmpty(thisVariant: Variant): Boolean; begin Result:= VarIsEmpty(thisVariant) or VarIsNull(thisVariant) or VarIsClear(thisVariant); end; end.
El problema es aquí:
//... unit UDocumentoTexto; interface uses Variants, SysUtils, ComObj, Classes, Launch; //...
Gracias nuevamente.
Santiago.
#17
Escrito 23 mayo 2014 - 03:27
Está en: http://www.daniweb.c...execute-to-work
Pongo el código para los que no quieren irse "tan lejos":
{************************************************************************} {* *} {* file : Launch.PAS *} {* *} {* type : unit *} {* *} {* location : \QUIRT\SRC\DELPHI *} {* *} {* purpose : Launch external programs *} {* *} {* author : Lennert Ploeger (NKI / AVL) *} {* *} {* date : 19980325 *} {* *} {* portability: 32 bit delphi only (V2.0 up) *} {* *} {* notes : None *} {* *} {************************************************************************} {* Updates: When Who What 19980325 lsp Created 19980331 lsp Search for programs in PATH using SearchPath() 19980609 lsp Allow white-spaces for the program to launch 19980709 lsp Allow 'prog' to be empty in StartProgram 19980731 lsp Enclose both file and directory names in double quotes 19980901 lsp Removed some obsolete functions 19981004 mvh Added RunProgram (waits until ready) 19981005 mvh Renamed to RunProgramBlocking (waits until ready) 19981020 lsp Program launched in RunProgramBlocking() is started minimized and not given focus 19990110 mvh RunProgramBlocking returns value 19990111 lsp Fixed comment about CloseHandle() 19990112 mvh Added RunProgramWaiting, shortened code by reuse 19990425 lsp FileUtil -> QFileUtil 19990609 lsp Removed QFileUtil dependency *} unit Launch; interface //Para pasar de ProcId a THandle type TWindowRec = record Handle: THandle; ProcessId: Cardinal; WindowName: PChar; end; PWindowRec = ^TWindowRec; function LocateProgramInSearchPath(ProgramName: string): string; procedure StartProgram(prog, workdir: string; params: array of string); function RunProgramBlocking(prog, workdir: string; params: array of string): integer; function RunFileBlocking(fichero: string): boolean; function RunProgramWaiting(prog, workdir: string; params: array of string): integer; function ProgramStarter(prog, workdir: string; params: array of string; showmode: integer): integer; //HCSoft... //Localizar Handler de un proceso a partir del filename del ejecutable function GetProcHandle(ExeFileName: string): THandle; //Hacer cosas a partir del THandle... function KillProc(H: THandle): boolean; function WaitProcIddle(H: THandle; MinSeg: double = 1; MaxSeg: double = 30): double; //Hacer cosas a partir del FileName... function WaitExeIddle(ExeFileName: string; MinSeg: double = 0.1; MaxSeg: double = 10): double; function KillTask(ExeFileName: string): boolean; implementation uses SysUtils, Dialogs, Windows, Forms, FileCtrl, ShellAPI, HCBase, Tlhelp32; // Routine to retrieve file information using a file/dirname function FileDirNameWin32FindData(FullPathName: string; var Win32FindData: TWin32FindData): boolean; var Handle: THandle; begin Handle := FindFirstFile(PChar(FullPathName), Win32FindData); if Handle <> INVALID_HANDLE_VALUE then begin Windows.FindClose(Handle); Result := True; end else Result := False; end; // Search for 'ProgramName' in %PATH% using Win API function 'SearchPath' function LocateProgramInSearchPath(ProgramName: string): string; type BufType = array[0..255] of char; var SPPath: BufType; PathPtr: PChar; begin if SearchPath(nil, PChar(ProgramName), nil, 255, SPPath, PathPtr)>0 then Result := StrPas(SPPath) else Result := ProgramName; end; function TestExistence(const Name: string): boolean; begin Result := FileExists(Name) or DirectoryExists(Name); end; // Internal common code for the 3 exported program starters function ProgramStarter(prog, workdir: string; params: array of string; showmode: integer): integer; var StartInf : TStartupInfo; ProcInf : TProcessInformation; args : string; progtmp : string; pAppName : PChar; pworkdir : PChar; i : integer; begin // It appears that it is also possible to call ShellExecute, what seems // to be a bit a higher level function: // ShellExecute(handle, "open", path_to_file, NULL, NULL, SW_SHOWNORMAL); // Another alternative can be calling WinExec, but with the drawback of // not having the possibility to specify the work directory. ZeroMemory(@StartInf, sizeof(TStartupInfo)); ZeroMemory(@ProcInf, sizeof(TProcessInformation)); StartInf.cb := sizeof(TStartupInfo); StartInf.dwFlags := STARTF_USESHOWWINDOW ; StartInf.wShowWindow := showmode; // To call CreateProcess() we should be carefull to enclose files // passed in 'lpCommandLine' in double quotes ('"') to make sure that // it understands where one starts and ends. The pecularity is that the // name of the executable should NOT be enclosed in double quotes. Passing // both the file and the arguments in lpCommandLine and leaving // lpApplicationName empty is no option, since the application and // arguments should be white-space delimited that way. progtmp := prog; if not FileExists(progtmp) then progtmp := LocateProgramInSearchPath(progtmp); if Length(prog)>0 then args := '"' + prog + '"'; for i:=low(params) to high(params) do begin // Enclose file and directory names in double quotes to get them seperated properly if TestExistence(params[i]) then begin if Length(args)>0 then // Try to add spaces only when necessary args := args + ' "' + params[i] + '"' else args := '"' + params[i] + '"' end else if Length(params[i])>0 then begin if Length(args)>0 then // Try to add spaces only when necessary args := args + ' ' + params[i] else args := params[i]; end; end; if Length(workdir)>0 then pworkdir := PChar(workdir) else pworkdir := nil; if Length(progtmp)>0 then pAppName := PChar(progtmp) else pAppName := nil; if not CreateProcess(pAppName, PChar(args), nil, nil, False, 0, nil, pworkdir, StartInf, ProcInf) then MessageDlg('El programa ' + prog + ' no ha podido ser ejecutado', mtError, [mbOk], 0); // The handles for both the process and the main thread must be closed through // calls to CloseHandle. These handles are not needed, so it is best to close // them immediately after the process is created. result := ProcInf.hProcess; CloseHandle(ProcInf.hThread); end; // routine to start program 'prog' using the file-parameters in 'params'. // Be carefull with passing [] for the params, since the stackpointer seems // to get corrupt. However, starting a program with no arguments can be done // using StartProgram(program, workdir, [ ' ' ]). procedure StartProgram(prog, workdir: string; params: array of string); var hProcess: integer; begin hProcess := ProgramStarter(prog, workdir, params, SW_SHOWDEFAULT); CloseHandle(hProcess); end; // routine to run program 'prog' using the file-parameters in 'params'. // and wait until it is finished // Be careful with passing [] for the params, since the stackpointer seems // to get corrupt. However, starting a program with no arguments can be done // using StartProgram(program, workdir, [ ' ' ]). function RunProgramBlocking(prog, workdir: string; params: array of string): integer; var hProcess: integer; j : Cardinal; begin hProcess := ProgramStarter(prog, workdir, params, SW_SHOWMINNOACTIVE); WaitForSingleObject(hProcess, INFINITE); GetExitCodeProcess(hProcess, j); result := integer(j); CloseHandle(hProcess); end; function RunFileBlocking(fichero: string): boolean; var SEI: TShellExecuteInfo; begin //Ejecuto el fichero con el programa adecuado... FillChar(SEI, SizeOf(SEI), 0); // Wipe the record to start with Result:= true; with SEI do begin cbSize := SizeOf(SEI); fMask := see_Mask_NoCloseProcess; Wnd := Application.MainForm.Handle; lpVerb := 'open'; lpFile := PAnsiChar(fichero); lpDirectory := PChar(ExtractFilePath(fichero)); nShow := sw_ShowNormal; if not ShellExecuteEx(@SEI) then Result:= False; end; //Espero a que liberen el fichero... //WaitForSingleObjet no se debe usar si se va a abrir una ventana porque //el proceso que llama deja de procesar mensajes y la ventana nueva cuelga: //http://msdn.microsoft.com/en-us/library/ms687032%28VS.85%29.aspx while WaitForSingleObject(SEI.hProcess, 100) = WAIT_TIMEOUT do Application.ProcessMessages; end; // routine to run program 'prog' using the file-parameters in 'params'. // and wait until it is finished. During the wait, however, messages are // processed so that the user interface remains 'live'. function RunProgramWaiting(prog, workdir: string; params: array of string): integer; var hProcess: integer; j : Cardinal; begin hProcess := ProgramStarter(prog, workdir, params, SW_SHOWMINNOACTIVE); while WaitForSingleObject(hProcess, 10) = WAIT_TIMEOUT do Application.ProcessMessages; GetExitCodeProcess(hProcess, j); result := integer(j); CloseHandle(hProcess); end; // ************************************************************************** // ** AÑADIDO SERGIO PARA MENEJAR PROCESOS POR SU HANDLE O SU EXE FILENAME ** // ************************************************************************** function FileTime2Milliseconds(FileTime: TFileTime): integer; var ST: TSystemTime; begin FileTimeToSystemTime(FileTime, ST); result:= ST.wMilliseconds + 1000 * (ST.wSecond + 60 * (ST.wMinute + 60 * ST.wHour)) ; end; //Sabemos 'WINWORD.EXE', dame un THandle del proceso para hacerle putadillas function GetProcHandle(ExeFileName: string): THandle; var ContinueLoop: BOOL; FSnapshotHandle: THandle; FProcessEntry32: TProcessEntry32; begin result:= 0; FSnapshotHandle:= CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); FProcessEntry32.dwSize:= Sizeof(FProcessEntry32); ContinueLoop:= Process32First(FSnapshotHandle, FProcessEntry32); while integer(ContinueLoop) <> 0 do begin if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) then begin result:= OpenProcess(PROCESS_ALL_ACCESS, FALSE, FProcessEntry32.th32ProcessID); break; end; ContinueLoop:= Process32Next(FSnapshotHandle, FProcessEntry32); end; CloseHandle(FSnapshotHandle); end; //Mata este proceso! function KillProc(H: THandle): boolean; const PROCESS_TERMINATE=$0001; begin result:= (Integer(TerminateProcess(H, 0))<>0); end; //Espera a que un Proceso use menos del 1% de la CPU. //Si no encuentra el proceso, esperara MinSeg, y si lo encuentra pero no baja //del 1%, se esperara un maximo de MaxSeg. function WaitProcIddle(H: THandle; MinSeg: double = 1; MaxSeg: double = 30): double; var LastProcTime, NewProcTime, UsedTime: integer; //Milisegundos todo CreaTime, ExitTime, UserTime, KernelTime: TFileTime; const WAIT_FOR_MS: integer = 1000; //Cada 1 segundo (1000 ms) vuelves a mirar IDDLE_LOWER: integer = 5; //Usados < 5 ms = (%CPU<0.5) salimos begin //Llevo esperando 0 segundos... result:= 0; //Igual no lo encuentro... if (H=0) then begin //Pues no esta, espero algo y me voy... sleep(round(MinSeg*1000)); end else begin //Proceso encontrado, a esperar... if GetProcessTimes(H, CreaTime, ExitTime, KernelTime, UserTime)=BOOL(0) then exit; LastProcTime:= FileTime2Milliseconds(KernelTime) + FileTime2Milliseconds(UserTime); //Cada decima de segundo, recalculo... repeat sleep(WAIT_FOR_MS); result:= result + (WAIT_FOR_MS/1000); //Rescato tiempo dle proceso actualizado... if GetProcessTimes(H, CreaTime, ExitTime, KernelTime, UserTime)=BOOL(0) then exit; NewProcTime:= FileTime2Milliseconds(KernelTime) + FileTime2Milliseconds(UserTime); UsedTime:= (NewProcTime - LastProcTime); if (UsedTime) < IDDLE_LOWER then break; LastProcTime:= NewProcTime; until (result >= MaxSeg); end; end; // *************************************************** // ** MANEJO PROCESOS SABIENDO SU NOMBRE DE FICHERO ** // *************************************************** //Espera a que una tarea baje del 1%CPU usando su filename function WaitExeIddle(ExeFileName: string; MinSeg: double = 0.1; MaxSeg: double = 10): double; begin result:= WaitProcIddle(GetProcHandle(ExeFileName), MinSeg, MaxSeg); end; //Mata programa por su nombre... function KillTask(ExeFileName: string): boolean; begin result:= KillProc(GetProcHandle(ExeFileName)); end; end.
Nota: La unit "HCBase" no tiene uso, se puede sacar sin problemas. De hecho si no la sacamos no permite la compilación.
Ya me dirá Sergio si estoy en lo cierto.
Gracias.
#18
Escrito 23 mayo 2014 - 04:04
Justo encima del método SaveToPDF dice:
If you are using OOo, you can export to PDF directly.
In word, the only choice is to use a PDF printer, out of our scope here!
NOTE: If you open a HTML in OOo, the param 0 need to be diferent as commented
Code refactored from an example by Ryan at: http://www.oooforum....c.phtml?t=22344
De igual manera, no deja de estar bueno.
Una vuelta de tuerca mas y podemos tener un exportador PDF que lo haga desde OpenOffice y Office.
Saludos.
#19
Escrito 24 mayo 2014 - 06:37
Ohh, el código está bastante bueno.
Justo encima del método SaveToPDF dice:
If you are using OOo, you can export to PDF directly.
In word, the only choice is to use a PDF printer, out of our scope here!
NOTE: If you open a HTML in OOo, the param 0 need to be diferent as commented
Code refactored from an example by Ryan at: http://www.oooforum....c.phtml?t=22344
De igual manera, no deja de estar bueno.
Una vuelta de tuerca mas y podemos tener un exportador PDF que lo haga desde OpenOffice y Office.
Saludos.
#20
Escrito 26 mayo 2014 - 05:23
El launch.pas que uso es el que has encontrado, solo le añadi en mi caso 3 o 4 funciones extras para "cosas raras" que no se usan en esta unit, así que la que has encontrado es la correcta.
HCBase es una unit que metemos siempre con funciones nuestras se usen o no, por si acaso.
Y lo del mensaje sobre convertir a PDF en MS-Office, bueno, nuestras apps corren en sistemas que escapan de nuestro control, y nunca sabemos si usan Word 97, 2007, OpenOffice, LibreOffice, o lo que sea, ni si tienen o no instalado tal o cual añadido, así que realmente nuestras apps siempre usan una impresora PDF para convertir, sea el tipo de fichero que sea, a PDF (aunque sea con LibreOffice).
Si fuerzas el uso por defecto de una impresora PDF y sobre el fichero haces click derecho, Imprimir, obtienes un PDF, así que si automatizas esto, puedes convertir de autocad a pdf de forma automatica, por eso no nos complicamos la vida.