I have the following problem:
I have a table with 5000 random generated demo data sets
I would now like to export this one line at a Xliff file.
So the end result should look like. Small example
<?xml version='1.0' encoding='utf-8'?>
<xliff version="1.1">
<file original="source\simple.htm" source-language="EN" target-language="DE" datatype="html">
<header>
<skl>
<external-file uid="017dbcf0-c82c-11e2-ba2b-005056c00008" href="skl\simple.htm.skl"/>
</skl>
</header>
<body>
<trans-unit id="00QlKZsL6GyW6B92Ev81Fb2HP3Z0ma">
<source xml:lang="EN">2hH3khJvy1gmFNTLSB0Crka0A8TTKReuYxbV2hI9E8AjXwCV3F</source>
<target xml:lang="DE">3ydQZWavaKvxrlbh1ewXZakLL00LEPG6zVTyty6fiLrPdx9UE4</target>
<note/></trans-unit>
<trans-unit id="016ynILnditynwtYwcl6vJPTLCzvo7">
<source xml:lang="EN">dyC28VRCI9O37PTHENinp4sgMkr5R0HO1Yo53hUQKNr4GoLFG4</source>
<target xml:lang="DE">sEkgstffmS4k5KB1JZkNSYbUnzzlFBNT30oYmtfId8dnspG3No</target>
<note>Testnotiz</note></trans-unit>
<trans-unit id="03YNBAZ1YWvkqaG4PRxKSiWENOCXuB">
<source xml:lang="EN">BHpY8LDs8oJAr8I1EfZzeJX24GZ3TLIr9GUAYcnSPYHjDfKRqk</source>
<target xml:lang="DE">7Rd7bW2lg2Uc4uStCoosZuNgOzA9qWN7OsvW2gBcHa3ctnmF3Q</target>
<note/></trans-unit>
</body>
</file>
</xliff>
As a component of the Edit / Paste Xliff the file I wanted to grab my XMLDocument. I already had a few days ago wrote a demo program where I upload a file using XMLDocument and then Xliff purely write something again. So these routines at least for the targets I already have.
I feel now more that I still have no real idea how all the data from the MySQL table as the best piece of land in a Xliff file pack.
First thought was possible for me to go through the entire table line by line, then save it into an array and then write my loop over the array and in the file.
Would appreciate some other suggestions / concepts. Since it is a test of the speed of the XMLDocument component in the end I would concepts / ideas that lead to a rapid course prefer.
Here a solution using the Strategy Design Pattern to have an easy extendable solution for various export strategies (XML Plain or XmlDoc, CSV, ...)
Base Document
unit Document;
interface
type
TDocument = class;
IDocumentExportFileStrategy = interface
['{787B60E5-A3CA-485C-A46E-248A43D7175C}']
procedure ExportDoc( AContext : TDocument; const AFileName : string );
end;
TDocument = class
private
FExportFileStrategy : IDocumentExportFileStrategy;
protected
function GetValue( const Name : string ) : Variant; virtual; abstract;
public
procedure First; virtual; abstract;
procedure Next; virtual; abstract;
function Eof : Boolean; virtual; abstract;
property Value[const Name : string] : Variant read GetValue;
property ExportFileStrategy : IDocumentExportFileStrategy read FExportFileStrategy write FExportFileStrategy;
procedure ExportTo( const AFileName : string );
end;
implementation
{ TDocument }
procedure TDocument.ExportTo( const AFileName : string );
begin
FExportFileStrategy.ExportDoc( Self, AFileName );
end;
end.
An Xliff export strategy writing plain text for fast execution
unit XliffPlainExporter;
interface
uses
Document,
SysUtils, Variants,
Classes;
type
TXliffPlainExporter = class( TInterfacedObject, IDocumentExportFileStrategy )
private
procedure WriteLine( AStream : TStream; ALine : string );
protected
procedure WriteHead( AContext : TDocument; AStream : TStream );
procedure WriteDetails( AContext : TDocument; AStream : TStream );
procedure WriteFoot( AContext : TDocument; AStream : TStream );
public
procedure ExportDoc( AContext : TDocument; const AFileName : string );
end;
implementation
{ TXliffPlainExporter }
procedure TXliffPlainExporter.ExportDoc( AContext : TDocument; const AFileName : string );
var
LStream : TStream;
LFileName : string;
begin
AContext.First;
if not AContext.Eof
then
begin
LFileName := AFileName;
if ExtractFileExt( LFileName ) = ''
then
LFileName := ChangeFileExt( LFileName, '.xml' );
LStream := TFileStream.Create( LFileName, fmCreate );
try
WriteHead( AContext, LStream );
WriteDetails( AContext, LStream );
WriteFoot( AContext, LStream );
finally
LStream.Free;
end;
end;
end;
procedure TXliffPlainExporter.WriteHead( AContext : TDocument; AStream : TStream );
begin
WriteLine( AStream, '<?xml version=''1.0'' encoding=''utf-8''?>' );
WriteLine( AStream, '<xliff version="1.1">' );
WriteLine( AStream, ' <file original="source\simple.htm" source-language="EN" target-language="DE" datatype="html">' );
WriteLine( AStream, ' <header>' );
WriteLine( AStream, ' <skl>' );
WriteLine( AStream, ' <external-file uid="017dbcf0-c82c-11e2-ba2b-005056c00008" href="skl\simple.htm.skl"/>' );
WriteLine( AStream, ' </skl>' );
WriteLine( AStream, ' </header>' );
WriteLine( AStream, ' <body>' );
end;
procedure TXliffPlainExporter.WriteDetails( AContext : TDocument; AStream : TStream );
begin
while not AContext.Eof do
begin
WriteLine( AStream, Format( ' <trans-unit id="%s">', [VarToStr( AContext.Value['id'] )] ) );
WriteLine( AStream, Format( ' <source xml:lang="EN">%s</source>', [VarToStr( AContext.Value['src'] )] ) );
WriteLine( AStream, Format( ' <target xml:lang="DE">%s</target>', [VarToStr( AContext.Value['dst'] )] ) );
WriteLine( AStream, ' <note/></trans-unit>' );
AContext.Next;
end;
end;
procedure TXliffPlainExporter.WriteFoot( AContext : TDocument; AStream : TStream );
begin
WriteLine( AStream, ' </body>' );
WriteLine( AStream, ' </file>' );
WriteLine( AStream, '</xliff>' );
end;
procedure TXliffPlainExporter.WriteLine( AStream : TStream; ALine : string );
var
LLine : TStream;
begin
LLine := TStringStream.Create( ALine + sLineBreak, TEncoding.UTF8 );
try
LLine.Position := 0;
AStream.CopyFrom( LLine, LLine.Size );
finally
LLine.Free;
end;
end;
end.
Simple Test-Document just for testing purpose
unit TestDocument;
interface
uses
Document;
type
TTestDocument = class( TDocument )
private
FIndex : Integer;
protected
function GetValue( const Name : string ) : Variant; override;
public
function Eof : Boolean; override;
procedure First; override;
procedure Next; override;
end;
implementation
uses
SysUtils,
StrUtils;
{ TTestDocument }
function TTestDocument.Eof : Boolean;
begin
Result := FIndex >= 100;
end;
procedure TTestDocument.First;
begin
inherited;
FIndex := 0;
end;
function TTestDocument.GetValue( const Name : string ) : Variant;
begin
case IndexText( Name, ['id', 'src', 'dst'] ) of
0 :
Result := Format( 'id%8.8d', [FIndex + 1] );
1 :
Result := Format( 'src%8.8d', [FIndex + 1] );
2 :
Result := Format( 'dst%8.8d', [FIndex + 1] );
end;
end;
procedure TTestDocument.Next;
begin
inherited;
Inc( FIndex );
end;
end.
And putting the pieces together
program DataExportStrategy;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
Document in 'Document.pas',
TestDocument in 'TestDocument.pas',
XliffPlainExporter in 'XliffPlainExporter.pas';
procedure Test;
var
LDoc : TDocument;
begin
LDoc := TTestDocument.Create;
try
LDoc.ExportFileStrategy := TXliffPlainExporter.Create;
LDoc.ExportTo( 'test' );
finally
LDoc.Free;
end;
WriteLn( 'Export finished' );
end;
begin
try
Test;
except
on E : Exception do
WriteLn( E.ClassName, ': ', E.Message );
end;
ReadLn;
end.
In your case, you would like to have a document based on a DataSet so you implement a TDataSetDocument
unit DataSetDocument;
interface
uses
Document,
Data.DB;
type
TDataSetDocument = class( TDocument )
private
FDataSet : TDataSet;
protected
function GetValue( const Name : string ) : Variant; override;
public
constructor Create( ADataSet : TDataSet );
function Eof : Boolean; override;
procedure Next; override;
procedure First; override;
end;
implementation
{ TDataSetDocument }
constructor TDataSetDocument.Create( ADataSet : TDataSet );
begin
inherited Create;
FDataSet := ADataSet;
end;
function TDataSetDocument.Eof : Boolean;
begin
Result := FDataSet.Eof;
end;
procedure TDataSetDocument.First;
begin
inherited;
FDataSet.First;
end;
function TDataSetDocument.GetValue( const Name : string ) : Variant;
begin
Result := FDataSet.FieldByName( Name ).Value;
end;
procedure TDataSetDocument.Next;
begin
inherited;
FDataSet.Next;
end;
end.
and use it
var
LDoc : TDocument;
LDoc := TDataSetDocument.Create( MyQuery );
try
LDoc.ExportStrategy := TXliffPlainExporter.Create;
LDoc.ExportTo( 'test' );
finally
LDoc.Free;
end;
Related
When I try to run the program I'm getting an error stating "end Animals;" is expected where I end the function 'Init'. I'm quite new to programming and I just can't figure out what the problem is. It's trying to get me to change it to 'end Animals;' but then that will end the package there and not run the rest of it.
package body Animals is
function Init(
Name : in String;
Legs : in Natural;
WeightInGrams : in Positive;
HeightInCm : in Positive)
return Creature;
TempCreature : Creature;
begin
TempCreature.Name := To_Unbounded_String(Name);
TempCreature.Legs := Legs;
TempCreature.WeightInGrams := WeightInGrams;
TempCreature.HeightInCm := HeightInCm;
return TempCreature;
end Init; ***--"end Animals;" expected***
function Init return Creature is
TempCreature : Creature;
begin
TempCreature.Name := To_Unbounded_String("Dog");
TempCreature.Legs := 4;
TempCreature.WeightInGrams := 3000;
TempCreature.HeightInCm := 40;
return TempCreature;
end Init;
procedure Set_Legs(
Creat : in out Creature;
Legs : in Natural) is
begin
Creat.Legs := Legs;
end Set_Legs;
procedure Set_Weight(
Creat : in out Creature;
WeightInGrams : in Positive) is
begin
Creat.WeightInGrams := WeightInGrams;
end Set_Weight;
procedure Set_Height(
Creat : in out Creature;
HeightInCm : in Positive) is
begin
Creat.HeightInCm := HeightInCm;
end Set_Height;
function Get_Legs(
Creat : in out Creature)
return Natural is
begin
return Creat.Legs;
end Get_Legs;
function Get_Weight(
Creat : in out Creature)
return Positive is
begin
return Creat.WeightInGrams;
end Get_Weight;
function Get_Height(
Creat : in out Creature)
return Positive is
begin
return Creat.HeightInCm;
end Get_Height;
overriding procedure Finalize(
Creat : in out Creature) is
begin
Put_Line("Resetting values of Creat to defaults.");
Creat.Name := Null_Unbounded_String;
Creat.Legs := 0;
Creat.WeightInGrams := 1;
Creat.HeightIncm := 1;
end Finalize;
procedure Print_Record(Creat : in out Creature) is
begin
Private_Print_Record(Creat);
end Print_Record;
procedure Private_Print_Record(Creat : in out Creature) is
begin
Put_Line("The animal: ");
Put_Line("The name: " & To_String(Creat.Name));
Put_Line("Number of legs: " & Natural'Image(Creat'Legs));
Put_Line("Weight in grams: " & Positive'Image(Creat.WeightInGrams));
Put_Line("Height in cm: " & Positive'image(Creat.HeightInCm));
end Private_Print_Record;
end Animals;
It seems that you made typo at the end of the function declaration.
function Init(
Name : in String;
Legs : in Natural;
WeightInGrams : in Positive;
HeightInCm : in Positive)
return Creature; -- remove ";" add "is"
TempCreature : Creature;
begin
-- ...
end Init;
should be
function Init
(Name : in String;
Legs : in Natural;
WeightInGrams : in Positive;
HeightInCm : in Positive) return Creature
is
TempCreature : Creature;
begin
-- ...
end Init;
I'm working to create an installer and I need to edit and retrieve values from the JSON file.
To retrieve and edit the values from the Section_2 works fine. The problem is to edit and retrieve values from the children sections of Section_1. Bellow we can see an example:
{
"Section_1": {
"children_1": {
"children_1_1": "value_1",
"children_1_2": "value_2"
},
"children_2": "blablabla"
},
"Section_2": {
"children_2_1": "value_1",
"children_2_2": "value_2"
}
}
[Files]
Source: "{#ProjectUrl}\JSONConfig.dll"; Flags: dontcopy
[Code]
var
FileName: WideString;
StrValue: WideString;
StrLength: Integer;
function JSONQueryString(FileName, Section, Key, Default: WideString;
var Value: WideString; var ValueLength: Integer): Boolean;
external 'JSONQueryString#files:jsonconfig.dll stdcall';
function JSONWriteString(FileName, Section, Key,
Value: WideString): Boolean;
external 'JSONWriteString#files:jsonconfig.dll stdcall';
function editAppSettingsJson(Section_1: String; Section_2:String): Boolean;
begin
FileName := '{#AppSettingsJsonFile}';
SetLength(StrValue, 16);
StrLength := Length(StrValue);
Result := True;
{ Does not work. How can I edit it? }
if not JSONWriteString(FileName, 'children_1', 'children_1_1',
Section_1) then
begin
MsgBox('JSONWriteString Section_1:children_1:children_1_1 failed!',
mbError, MB_OK);
Result := False;
end;
{ Works fine. }
if not JSONWriteString(FileName, 'Section_2', 'children_2_1', Section_2)
then
begin
MsgBox('JSONWriteString Section_2:children_2_1 failed!', mbError,
MB_OK);
Result := False;
end;
end;
procedure InitializeWizard;
var
value_1: String;
value_2: String;
begin
value_1:= 'value_2';
value_2:= 'value_3';
editAppSettingsJson(value_1, value_2);
end;
In advance thank you very much for your support.
Regards, Diego Via
I do not think that JSONConfig.dll supports nested structures.
You can use JsonParser library instead. It can parse nested structures. Though it's not as easy to use as JSONConfig.dll – well, because it's more versatile.
The following code will do:
var
JsonLines: TStringList;
JsonParser: TJsonParser;
JsonRoot, Section1Object, Children1Object: TJsonObject;
Child11Value: TJsonValue;
begin
JsonLines := TStringList.Create;
JsonLines.LoadFromFile(FileName);
if ParseJsonAndLogErrors(JsonParser, JsonLines.Text) then
begin
JsonRoot := GetJsonRoot(JsonParser.Output);
if FindJsonObject(JsonParser.Output, JsonRoot, 'Section_1', Section1Object) and
FindJsonObject(JsonParser.Output, Section1Object, 'children_1', Children1Object) and
FindJsonValue(JsonParser.Output, Children1Object, 'children_1_1', Child11Value) and
(Child11Value.Kind = JVKString) then
begin
Log(Format('children_1_1 previous value %s', [
JsonParser.Output.Strings[Child11Value.Index]]));
JsonParser.Output.Strings[Child11Value.Index] := 'new value';
JsonLines.Clear;
PrintJsonParserOutput(JsonParser.Output, JsonLines);
JsonLines.SaveToFile(FileName);
end;
end;
end;
The code uses functions from my answer to How to parse a JSON string in Inno Setup?
I created a function to Refresh a Query with Parameters, and then Locate a Specific field .
function RefreshQuery(AQuery : TADOQuery; AField : string; AValue : integer; AParam : string; AParamValue : Variant) : boolean; overload;
When the AValue is integer it works , when I change it to Variant
I get a List Index Out of Bounds 1699364 error .
The Function itself looks like this :
function RefreshQuery(AQuery : TADOQuery; AField : string; AValue : integer; AParam : string; AParamValue : Variant) : boolean; overload;
var AfterOpen,AfterScroll,BeforeOpen : TDataSetNotifyEvent;
AList : TStringList;
i : integer;
begin
result:=false;
AfterOpen := AQuery.AfterOpen;
AfterScroll := AQuery.AfterScroll;
BeforeOpen := AQuery.BeforeOpen;
AQuery.AfterOpen:=nil;
AQuery.AfterScroll:=nil;
AQuery.BeforeOpen:=nil;
AList := TStringList.Create;
AList.Delimiter:=';';
AList.DelimitedText:=AParam;
if AQuery.Active then AQuery.Close;
if AList.Count = 1 then
AQuery.Parameters.ParamByName(AList[i]).Value:=AParamValue // the error happens here
else
for i := 0 to AList.Count-1 do
AQuery.Parameters.ParamByName(AList[i]).Value:=AParamValue[i];
AQuery.Open;
if not AQuery.Locate(AField, AValue, []) then
result:=false
else
result:=true;
AQuery.AfterOpen:=AfterOpen;
AQuery.AfterScroll:=AfterScroll;
AQuery.BeforeOpen:=BeforeOpen;
if Assigned(AQuery.AfterScroll) then
AQuery.AfterScroll(AQuery);
AList.Free;
end;
I use it like this :
if RefreshQuery(CityQuery,'id',CityQueryID.Value,'Active',not(CheckBox1.Checked).ToInteger+2) = false then
begin
MessageDlg('blabla!',mtWarning, [mbOK], 0);
Exit;
end;
In the Above example CityQueryID.Value is of Integer Type . But Sometimes I would like to use String . So I would like to change the Function to work with Variants.
The error happens because at the statement
if AList.Count = 1 then
AQuery.Parameters.ParamByName(AList[i]).Value:=AParamValue // the error happens here
you have not yet assigned a value to i and as it is a local variable, it will have a random value, depending on what's been on the stack before RefreshQuery is called.
Changing the statement to
if AList.Count = 1 then
AQuery.Parameters.ParamByName(AList[0]).Value:=AParamValue
should fix the problem.
Once you have done that, you should find that you can change the parameter type of AValue to variant without problem.
I have a "parent" class which has a generic function to load a JSON string into the instance's properties called loadVals. I have two children with their own properties, and one of these props is a record.
The function sets successfully all the props of the main instance, but fails on setting the values on the record's props, no errors, I can see it loops successfully through the record's props but doesn't set the values.
wrote a small test console app, where you can see the behavior.
uses
System.SysUtils, System.TypInfo, RTTI, Data.DBXJSON;
type
TFieldValLoader = reference to procedure (const new_val: TValue);
tRec1 = record
x: integer;
y: String;
end;
tRec2 = record
a: integer;
b: String;
c: integer;
end;
TMyParent = class(TObject)
procedure loadVals(json_obj: TJSONObject);
end;
TMyChild1 = class(TMyParent)
h: integer;
my_rec: tRec1;
end;
TMyChild2 = class(TMyParent)
j: string;
my_rec: tRec2;
end;
{ TMyParent }
procedure TMyParent.loadVals(json_obj: TJSONObject);
procedure loadObj(Obj : TObject; my_json_obj: TJSONObject); forward;
procedure loadRecord(Obj : TValue; my_json_obj: TJSONObject);forward;
Procedure loadField( my_json_val: TJSONPair; _val: TValue; _loader: TFieldValLoader );
Begin
case _val.TypeInfo.Kind of
tkInteger:
_loader( TValue.From<integer>(StrToInt(my_json_val.JsonValue.Value)));
tkWChar, tkUString, tkVariant:
_loader( TValue.From(my_json_val.JsonValue.Value));
tkRecord:
loadRecord(_val, my_json_val.JsonValue as TJSONObject);
end;
End;
procedure loadRecord(obj : TValue; my_json_obj: TJSONObject);
var
i: Integer;
json_pair: TJSONPair;
ctx: TRttiContext;
obj_type: TRttiType;
my_field: TRttiField;
begin
ctx := TRttiContext.Create;
obj_type := ctx.GetType(obj.TypeInfo);
for I := 0 to my_json_obj.Size - 1 do
Begin
json_pair := my_json_obj.get(i);
my_field := obj_type.GetField(json_pair.JsonString.value);
WriteLn(' - '+ my_field.Name);
loadField(json_pair, my_field.GetValue(obj.GetReferenceToRawData),
procedure( const new_val: TValue )
Begin
// This does not work. (no feedback)!!!!
my_field.SetValue(obj.GetReferenceToRawData, new_val);
End
);
End;
End;
procedure loadObj(Obj : TObject; my_json_obj: TJSONObject);
var
i: Integer;
json_pair: TJSONPair;
ctx: TRttiContext;
obj_type: TRttiType;
my_field: TRttiField;
begin
ctx := TRttiContext.Create;
obj_type := ctx.GetType(obj.ClassInfo);
for I := 0 to my_json_obj.Size - 1 do
Begin
json_pair := my_json_obj.get(i);
my_field := obj_type.GetField(json_pair.JsonString.value);
WriteLn('* '+ my_field.Name);
loadField(json_pair, my_field.GetValue(obj),
procedure( const new_val: TValue )
Begin
// This does work
my_field.SetValue(obj, new_val);
End
);
End;
End;
begin
WriteLn('Loading '+ self.ClassName);
loadObj(self, json_obj);
end;
{ main Test Procedure }
var
my_child1: TMyChild1;
my_child2: TMyChild2;
begin
try
my_child1:= TMyChild1.Create;
my_child2:= TMyChild2.Create;
try
// load the json objs
my_child1.loadVals(TJSONObject.ParseJSONValue('{"h": 2, "my_rec": {"x": 4, "y": "test"}}') as TJSONObject);
my_child2.loadVals(TJSONObject.ParseJSONValue('{"j": "some", "my_rec": {"a": 8, "b": "any", "c": 9}}') as TJSONObject);
// print the loaded values
WriteLn('child 1 vals are: h: '+ intToStr(my_child1.h) +' my_rec.y= "'+ my_child1.my_rec.y +'" should equal to "test"');
WriteLn('child 2 vals are: j: '+ my_child2.j +' my_rec.b= "'+ my_child2.my_rec.b +'" should equal to "any"');
finally
my_child1.Free;
my_child2.Free;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
// don't close the window, wait for [Enter]
Readln;
end.
I know records are different than classes, and I cannot find a way of getting this function to work; I really appreciate any help. Thanks
Your problem is that a record is a value type.
This line
loadField(json_pair, my_field.GetValue(obj),
gets the value of the record field. Keep in mind, its a value type so we get a copy of it.
Now you are setting the properties/fields on that copy which works. But then you never assign that back to the fields of your object.
So what you are doing here is basically like this:
my_child1:= TMyChild1.Create;
my_rec1 := my_child1.my_rec;
my_rec1.x := 4;
my_rec1.y := 'test';
So you can see that my_child1.my_rec never gets the values set to my_rec1.
You need to fix loadField as follows:
procedure loadField( my_json_val: TJSONPair; _val: TValue; _loader: TFieldValLoader );
begin
case _val.TypeInfo.Kind of
tkInteger:
_loader( TValue.From<integer>(StrToInt(my_json_val.JsonValue.Value)));
tkWChar, tkUString, tkVariant:
_loader( TValue.From(my_json_val.JsonValue.Value));
tkRecord:
begin
loadRecord(_val, my_json_val.JsonValue as TJSONObject);
_loader( _val); // <- set the record back to the field
end;
end;
end;
Can you advice me how to get "Log On As" parameter of specific windows service?
I need to re-register service in our upgrade project and it needs to be run under the same account as it was set up originally.
I've found QueryServiceConfig in advapi32.dll with lpServiceStartName in returned structure but I am not able to make it work from Inno Setup.
You cannot use QueryServiceConfig function from InnoSetup script. To use this function, you would have to allocate buffer from heap and that's impossible in InnoSetup. Instead you can use WMI, or to be more specific, the Win32_Service WMI class, which contains the StartName property, that you've asked for. In InnoSetup script it might look like this:
[Setup]
AppName=My Program
AppVersion=1.5
DefaultDirName={pf}\My Program
[Code]
function GetServiceStartName(const AServiceName: string): string;
var
WbemLocator: Variant;
WbemServices: Variant;
WbemObject: Variant;
WbemObjectSet: Variant;
begin;
Result := '';
WbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
WbemServices := WbemLocator.ConnectServer('localhost', 'root\CIMV2');
WbemObjectSet := WbemServices.ExecQuery('SELECT * FROM Win32_Service ' +
'WHERE Name = "' + AServiceName + '"');
if not VarIsNull(WbemObjectSet) and (WbemObjectSet.Count > 0) then
begin
WbemObject := WbemObjectSet.Item('Win32_Service.Name="' +
AServiceName + '"');
if not VarIsNull(WbemObject) then
Result := WbemObject.StartName;
end;
end;
procedure SvcStartNameTestButtonClick(Sender: TObject);
begin
MsgBox(GetServiceStartName('Netlogon'), mbInformation, MB_OK);
end;
procedure InitializeWizard;
var
SvcStartNameTestButton: TNewButton;
begin
SvcStartNameTestButton := TNewButton.Create(WizardForm);
SvcStartNameTestButton.Parent := WizardForm;
SvcStartNameTestButton.Left := 8;
SvcStartNameTestButton.Top := WizardForm.ClientHeight -
SvcStartNameTestButton.Height - 8;
SvcStartNameTestButton.Width := 175;
SvcStartNameTestButton.Caption := 'Get service start name...';
SvcStartNameTestButton.OnClick := #SvcStartNameTestButtonClick;
end;
Quite easier (and probably faster) would be to make an external library and call it from the script. If you have Delphi or Lazarus, you can use the following function, which uses the QueryServiceConfig function to get the lpServiceStartName member, that you asked for:
function GetServiceStartName(const AServiceName: string): string;
var
BufferSize: DWORD;
BytesNeeded: DWORD;
ServiceHandle: SC_HANDLE;
ServiceManager: SC_HANDLE;
ServiceConfig: PQueryServiceConfig;
begin
Result := '';
ServiceManager := OpenSCManager(nil, nil, SC_MANAGER_CONNECT);
if ServiceManager <> 0 then
try
ServiceHandle := OpenService(ServiceManager, PChar(AServiceName),
SERVICE_QUERY_CONFIG);
if ServiceHandle <> 0 then
try
if not QueryServiceConfig(ServiceHandle, nil, 0, BufferSize) and
(GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
ServiceConfig := AllocMem(BufferSize);
try
if QueryServiceConfig(ServiceHandle, ServiceConfig, BufferSize,
BytesNeeded)
then
Result := ServiceConfig^.lpServiceStartName;
finally
FreeMem(ServiceConfig);
end;
end;
finally
CloseServiceHandle(ServiceHandle);
end;
finally
CloseServiceHandle(ServiceManager);
end;
end;
I didn't liked the idea of linking external library so I finally solved the problem this way:
function GetServiceLogonAs():string;
var
res : Integer;
TmpFileName, FileContent: String;
begin
TmpFileName := ExpandConstant('{tmp}') + '\Service_Info.txt';
Exec('cmd.exe', '/C sc qc "MyServiceName" > "' + TmpFileName + '"', '', SW_HIDE, ewWaitUntilTerminated, res);
if LoadStringFromFile(TmpFileName, FileContent) then
begin
Result := Trim(Copy(FileContent,Pos('SERVICE_START_NAME', FileContent)+20,Length(FileContent)-(Pos('SERVICE_START_NAME', FileContent)+21)));
DeleteFile(TmpFileName);
end
else
begin
ShowErrorMsg('Error calling: GetServiceLogonAs(" + MYSERVICE + ")', res);
Result := '';
end;
end;