CreateOleObject
Création d'une instance d'objet OLE
Syntaxe
function CreateOleObject(ClassName: String): ComVariant
ClassName: nom de la classe de l'instance à créer
Remarques
La classe OLE à utiliser doit être enregistrée dans le registre de la machine qui exécute le script.
Sinon, la fonction génère une exception.
Exemples
uses COM;
// Impression PDF d'un document Excel (Office >2007)
procedure ExcelFileToPDF(xlsxFilePathName, pdfFilePathName : String);
var
excel : ComVariant;
newSession : Boolean;
begin
const XL_TYPE_PDF = 0;
// Test si Excel est déjà ouvert
try
excel := GetActiveOleObject("Excel.Application");
except
excel := CreateOleObject("Excel.Application");
newSession := True;
end;
try
excel.UserControl := False; // objet utilisé par programmation
excel.Interactive := False;
excel.DisplayAlerts := False;
var wkBook := excel.Workbooks.Open(xlsxFilePathName); // Ouverture du fichier
wkBook.ExportAsFixedFormat(XL_TYPE_PDF, pdfFilePathName); // Appel de la publication PDF Excel
wkBook.Close(False); // Fermeture du fichier sans enregistrer
finally
// On quitte Excel uniquement si on avait ouvert une nouvelle session
if newSession then excel.Quit;
excel := Unassigned; // Important pour bien libérer la liaison OLE
end;
end;
uses COM;
// Réutilisation de Word ou démarrage d'une nouvelle instance
var word : COMVariant;
try
word := GetActiveOleObject("Word.Application");
except
word := CreateOleObject("Word.Application");
end;
word.Visible := True;
// On crée un nouveau document
var doc := word.Documents.Add;
// Insère un paragraphe au début du document
var para := doc.Content.Paragraphs.Add;
para.Range.Text := "1er paragraphe";
para.Range.Font.Bold := True;
para.Format.SpaceAfter := 32;
// Définition d'une constante correspondant au saut de page (doit être passé en Int16)
const cWdBreakType_wdPageBreak = OleInt16(7);
// Insertion d'un saut de page
var range := doc.Bookmarks["\endofdoc"].Range;
range.InsertBreak(cWdBreakType_wdPageBreak);
// Nouveau paragraphe
para := doc.Content.Paragraphs.Add(doc.Bookmarks["\endofdoc"].Range);
para.Range.Text := "suite...";
para.Range.InsertParagraphAfter;
// Réutilisation de Word ou démarrage d'une nouvelle instance
var word : COMVariant;
try
word := GetActiveOleObject("Word.Application");
except
word := CreateOleObject("Word.Application");
end;
word.Visible := True;
// On crée un nouveau document
var doc := word.Documents.Add;
// Insère un paragraphe au début du document
var para := doc.Content.Paragraphs.Add;
para.Range.Text := "1er paragraphe";
para.Range.Font.Bold := True;
para.Format.SpaceAfter := 32;
// Définition d'une constante correspondant au saut de page (doit être passé en Int16)
const cWdBreakType_wdPageBreak = OleInt16(7);
// Insertion d'un saut de page
var range := doc.Bookmarks["\endofdoc"].Range;
range.InsertBreak(cWdBreakType_wdPageBreak);
// Nouveau paragraphe
para := doc.Content.Paragraphs.Add(doc.Bookmarks["\endofdoc"].Range);
para.Range.Text := "suite...";
para.Range.InsertParagraphAfter;
uses SysUtils, COM, System.Info;
function RunCmd(const cmd : String ; const timeOutMs : Integer ; exceptOnTimeout : Boolean = False) : String;
require
timeOutMs > 0 : 'Invalid timeout';
begin
var shell := CreateOleObject('WScript.Shell');
var timeOut := SystemMilliseconds + timeOutMs;
var app := shell.Exec(cmd);
try
// wait loop, with timeout
while app.Status = 0 do begin
// I/O buffer has to be emptied regularly, or it could freeze the command
Result += VarToStr(app.StdOut.ReadAll) + VarToStr(app.StdErr.ReadAll);
if SystemMilliseconds >= timeOut then begin
app.Terminate;
timeOut := 0;
end else Sleep(50);
end;
except
if app.Status = 0 then
app.Terminate;
raise;
end;
Result += VarToStr(app.StdOut.ReadAll) + VarToStr(app.StdErr.ReadAll);
if (timeOut = 0) and exceptOnTimeout then
raise Exception.Create('Command timed out' + #13#10 + Result);
end;
// ex : OEM char 'é' is returned by WScript.Shell as '‚' (Single Low-9 Quotation Mark)
// Indeed, legacy MS-DOS apps use OEM charset, i.e. code page 850 (Latin-1) on a french setup.
// In code page 850, 'é' is character 130. But as WScript.Shell use ANSI (code page 1252 on a french setup),
// it returns '‚' (i.e. ANSI character 130), that is then converted in unicode ('‚' is unicode char 8218).
//
// So to convert it back, we have to convert unicode char '‚' (code=8218) into ANSI char (code=130).
// Then we have to convert this char (code=130), viewed as an OEM char, into unicode 'é' (code=233)
//
function ANSItoOEM(const s : String) : String;
begin
var shell := CreateOleObject('WScript.Shell');
var OEM_CP : Integer = shell.RegRead('HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage\OEMCP');
var ANSI_CP : Integer = shell.RegRead('HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage\ACP');
if (OEM_CP <> ANSI_CP) and (OEM_CP > 0) and (ANSI_CP > 0) then
Result := CodePageToString(StringToCodePage(s, ANSI_CP), OEM_CP)
else Result := s;
end;
// launch legacy console apps
// NB : legacy apps outputs use OEM codepage... but Microsoft's WScript.Shell thinks it's ANSI
// so we have to convert back and forth, in order to have correct accented characters
// Another solution could be to use a batch file to launch the legacy app,
// after having called "chcp 1252" to force legacy apps to use ANSI code page.
PrintLn(ANSItoOEM(RunCmd('cmd /c "echo é"', 1000)));
PrintLn(ANSItoOEM(RunCmd('cmd /c "dir C:\"', 1000)));
PrintLn(ANSItoOEM(RunCmd('whoami /priv', 1000)));
PrintLn(ANSItoOEM(RunCmd('getmac', 1000)));
PrintLn(ANSItoOEM(RunCmd('ping -t www.google.fr', 5000))); // infinite ping but 5 seconds timeout
PrintLn(ANSItoOEM(RunCmd('net stop RetailDemo', 5000))); // stop demo service
// Launch app then close it after 5 seconds if it's not done before
PrintLn(RunCmd('mspaint.exe', 5000));
PrintLn(RunCmd('nslookup', 5000));
function RunCmd(const cmd : String ; const timeOutMs : Integer ; exceptOnTimeout : Boolean = False) : String;
require
timeOutMs > 0 : 'Invalid timeout';
begin
var shell := CreateOleObject('WScript.Shell');
var timeOut := SystemMilliseconds + timeOutMs;
var app := shell.Exec(cmd);
try
// wait loop, with timeout
while app.Status = 0 do begin
// I/O buffer has to be emptied regularly, or it could freeze the command
Result += VarToStr(app.StdOut.ReadAll) + VarToStr(app.StdErr.ReadAll);
if SystemMilliseconds >= timeOut then begin
app.Terminate;
timeOut := 0;
end else Sleep(50);
end;
except
if app.Status = 0 then
app.Terminate;
raise;
end;
Result += VarToStr(app.StdOut.ReadAll) + VarToStr(app.StdErr.ReadAll);
if (timeOut = 0) and exceptOnTimeout then
raise Exception.Create('Command timed out' + #13#10 + Result);
end;
// ex : OEM char 'é' is returned by WScript.Shell as '‚' (Single Low-9 Quotation Mark)
// Indeed, legacy MS-DOS apps use OEM charset, i.e. code page 850 (Latin-1) on a french setup.
// In code page 850, 'é' is character 130. But as WScript.Shell use ANSI (code page 1252 on a french setup),
// it returns '‚' (i.e. ANSI character 130), that is then converted in unicode ('‚' is unicode char 8218).
//
// So to convert it back, we have to convert unicode char '‚' (code=8218) into ANSI char (code=130).
// Then we have to convert this char (code=130), viewed as an OEM char, into unicode 'é' (code=233)
//
function ANSItoOEM(const s : String) : String;
begin
var shell := CreateOleObject('WScript.Shell');
var OEM_CP : Integer = shell.RegRead('HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage\OEMCP');
var ANSI_CP : Integer = shell.RegRead('HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage\ACP');
if (OEM_CP <> ANSI_CP) and (OEM_CP > 0) and (ANSI_CP > 0) then
Result := CodePageToString(StringToCodePage(s, ANSI_CP), OEM_CP)
else Result := s;
end;
// launch legacy console apps
// NB : legacy apps outputs use OEM codepage... but Microsoft's WScript.Shell thinks it's ANSI
// so we have to convert back and forth, in order to have correct accented characters
// Another solution could be to use a batch file to launch the legacy app,
// after having called "chcp 1252" to force legacy apps to use ANSI code page.
PrintLn(ANSItoOEM(RunCmd('cmd /c "echo é"', 1000)));
PrintLn(ANSItoOEM(RunCmd('cmd /c "dir C:\"', 1000)));
PrintLn(ANSItoOEM(RunCmd('whoami /priv', 1000)));
PrintLn(ANSItoOEM(RunCmd('getmac', 1000)));
PrintLn(ANSItoOEM(RunCmd('ping -t www.google.fr', 5000))); // infinite ping but 5 seconds timeout
PrintLn(ANSItoOEM(RunCmd('net stop RetailDemo', 5000))); // stop demo service
// Launch app then close it after 5 seconds if it's not done before
PrintLn(RunCmd('mspaint.exe', 5000));
PrintLn(RunCmd('nslookup', 5000));