Delphi: Windows service app.

PHOTO

Thu Jan 26 2023 15:42:04 GMT+0000 (Coordinated Universal Time)

Saved by @marcopinero #delphi

procedure TService1.Service1Execute(Sender: TService);
 begin
   Stream := TMemoryStream.Create;
   try
     ServerSocket1.Port := 80; // WWW port
     ServerSocket1.Active := True;
     while not Terminated do begin
       ServiceThread.ProcessRequests(True);
     end;
     ServerSocket1.Active := False;
   finally
     Stream.Free;
   end;
 end;

procedure TMyTestServiceApp.ServiceAfterInstall(Sender: TService);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create(KEY_READ or KEY_WRITE);
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey('\SYSTEM\CurrentControlSet\Services\' + Name, false) then
    begin
      Reg.WriteString('Description', 'This is a description for my fine Service Application.');
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
end;

OnExecute Events for delphi service app

Save snippets that work from anywhere online with our extensions

Available in the Chrome Web Store

Get Firefox Add-on

Get VS Code extension

Comments

More like this

Delphi/Lazarus/Pascal Collection

@marcopinero

Lazarus/Linux: Connect to SQLServer using ZeosLib component TZConnection Delphi: My window does not maximize! A fast solution. Delphi: Play sound contained in memorystream Delphi: Small VNC Server Delphi: Get FastReport (fr3) by TFileStream and fix inheritance. Delphi: Json to Dataset and viceversa Delphi: Convert string into escaped json string Lazarus: Run command and get output Lazarus/MacOSX: Detect theme dark mode Lazarus (and Delphi?): Customizing MessageDlg buttons and caption linux/dfm-to-json/docker Delphi: Detect if ComboBox is dropped down Delphi: Register custom URI Scheme at Windows Delphi/FastReport: Big paged RTF content Lazarus/Fastreport: Install on Linux Delphi: Percentage top and bottom on graphic Delphi/Android: Enable TWebbrowser navigation to http:// Delphi/UniGUI: Disable load animation Delphi: Post JSON to API Delphi/Windows: List all available web browsers on system Delphi: Windows service app.

Delphi: Convert string into escaped json string

function EscapeString(const AValue: string): string;
const
  ESCAPE = '\';
  QUOTATION_MARK = '"';
  REVERSE_SOLIDUS = '\';
  SOLIDUS = '/';
  BACKSPACE = #8;
  FORM_FEED = #12;
  NEW_LINE = #10;
  CARRIAGE_RETURN = #13;
  HORIZONTAL_TAB = #9;
var
  AChar: Char;
begin
  Result := '';
  for AChar in AValue do
  begin
    case AChar of
      QUOTATION_MARK: Result := Result + ESCAPE + QUOTATION_MARK;
      REVERSE_SOLIDUS: Result := Result + ESCAPE + REVERSE_SOLIDUS;
      SOLIDUS: Result := Result + ESCAPE + SOLIDUS;
      BACKSPACE: Result := Result + ESCAPE + 'b';
      FORM_FEED: Result := Result + ESCAPE + 'f';
      NEW_LINE: Result := Result + ESCAPE + 'n';
      CARRIAGE_RETURN: Result := Result + ESCAPE + 'r';
      HORIZONTAL_TAB: Result := Result + ESCAPE + 't';
      else
      begin
        if (Integer(AChar) < 32) or (Integer(AChar) > 126) then
          Result := Result + ESCAPE + 'u' + IntToHex(Integer(AChar), 4)
        else
          Result := Result + AChar;
      end;
    end;
  end;
end;

#bash #docker #delphi

linux/dfm-to-json/docker

$> docker pull haskell
$> docker run -it haskell stack <parameters>


$> git clone https://github.com/jean-lopes/dfm-to-json.git

$> cd dfm-to-json

$> stack setup
$> stack install
$> dfm-to-json --version

Delphi: Detect if ComboBox is dropped down

Function DetectIsOpen(Cb: TCombobox): Boolean;
Begin
  Result := SendMessage(ComboBox1.Handle,CB_GETDROPPEDSTATE,0,0)=1;
End;

Delphi: Register custom URI Scheme at Windows

unit RegURI;

interface

type
  TUriRecord = record
    Descrip: String;
    Protocol: String; // only letters or nombers .. no spaces ..
    Path: String; // complete path for application to be opened
                     //when appuri:// is called
    Icon: string; // icon file or executable file with icon
  end;

  function RegisterAppURI(URIReg: TUriRecord): boolean;

implementation

uses Registry, windows, ShlObj, dialogs;

function RegisterAppURI(URIReg: TUriRecord): boolean;
const
  root = '\Software\Classes\';
var
  Reg : TRegistry;
begin
  result := false;
  reg := TRegistry.Create;

  try
    try
      reg.RootKey := HKEY_CURRENT_USER;
      if reg.Openkey(root + URIReg.Protocol, True) then
      begin
        reg.WriteString('', 'URL:'+URIReg.Descrip);
        reg.WriteString('URL Protocol', '');

        if reg.Openkey(root + URIReg.Protocol + '\DefaultIcon', True) then
          reg.WriteString('', URIReg.Icon);

        if reg.Openkey(root + URIReg.Protocol + '\shell', True) and
          reg.Openkey(root + URIReg.Protocol + '\shell\open', True) and
          reg.Openkey(root + URIReg.Protocol + '\shell\open\command', True) then
          reg.WriteString('', '"'+URIReg.Path + '" "%1" "%2" "%3" "%4" "%5" "%6" "%7" "%8" "%9"');
      end;
      reg.CloseKey;

      reg.RootKey := HKEY_CURRENT_USER;
      if reg.Openkey('\Software\Microsoft\Internet Explorer\ProtocolExecute\' + URIReg.Protocol, True) then
      begin
        reg.WriteInteger('WarnOnOpen', 0);
      end;
      reg.CloseKey;

    //can cause problems…
      SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
      result := true;
    except
      showmessage('No se pudo realizar el registro.'#13'Asegurese de ejecutar la aplicación con permisos de Administrador');
      result := false;
    end;
  finally
    reg.free;
  end;
end;

function UnRegisterAppURI(protocol: string): boolean;
const
  root = '\Software\Classes\';
var
  Reg : TRegistry;
begin
  result := false;
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CLASSES_ROOT;
    result := reg.DeleteKey(root+protocol);

    reg.RootKey := HKEY_CURRENT_USER;
    reg.DeleteKey('\Software\Microsoft\Internet Explorer\ProtocolExecute\' + Protocol);
  finally
    reg.Free;
  end;
end;

Delphi/FastReport: Big paged RTF content

(*
  - Put TfrxRichView object into a MasterData (if not dataset set Record Count=1) 
  - Set MasterData.Stretched = true
  - Set TfrxRichView.StretchMode to smActualHeight or smMaxHeight
*)

Delphi: Percentage top and bottom on graphic

Chart.LeftAxis.StartPosition := 1; //1% top
Chart.LeftAxis.EndPosition := 99; //1% bottom

#delphi #android

Delphi/Android: Enable TWebbrowser navigation to http://

Open [yourappfolder]/AndroidManifest.template.xml file
and add the following property:

<application android:persistent="%persistent%" ...
    :
    android:usesCleartextTraffic="true">
    
</application>

Delphi/UniGUI: Disable load animation

/*-- put this on ServerModule.CustomCSS property --*/

#loading-mask, #loading-indicator, #loading {
  display: none;
}

Delphi: Post JSON to API

program JSONPostExample;

{$APPTYPE CONSOLE}

uses
  IdHTTP, IdGlobal, SysUtils, Classes;

var
  HTTP: TIdHTTP;
  RequestBody: TStream;
  ResponseBody: string;
begin
  HTTP := TIdHTTP.Create;
  try
    try
      RequestBody := TStringStream.Create('{"code":42}',
        TEncoding.UTF8);
      try
        HTTP.Request.Accept := 'application/json';
        HTTP.Request.ContentType := 'application/json';
        ResponseBody := HTTP.Post('https://httpbin.org/post',
          RequestBody);
        WriteLn(ResponseBody);
        WriteLn(HTTP.ResponseText);
      finally
        RequestBody.Free;
      end;
    except
      on E: EIdHTTPProtocolException do
      begin
        WriteLn(E.Message);
        WriteLn(E.ErrorMessage);
      end;
      on E: Exception do
      begin
        WriteLn(E.Message);
      end;
    end;
  finally
    HTTP.Free;
  end;
  ReadLn;
end.

Delphi/Windows: List all available web browsers on system

procedure ListRegisteredBrowsers(List: TStrings);
var
  reg: TRegistry;
  ki: TRegKeyInfo;
  i: Integer;
  keyname: string;
  len: DWORD;
  path: string;
  appName: string;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if not Reg.KeyExists('\SOFTWARE\Clients\StartMenuInternet') then Exit;
    if not Reg.OpenKey('\SOFTWARE\Clients\StartMenuInternet', false) then
      raise Exception.Create('ListRegisteredBrowsers: Could not open registry key.');
    if not reg.GetKeyInfo(ki) then
      raise Exception.Create('ListRegisteredBrowsers: Could not obtain registry key information.');
    List.Clear;
    SetLength(keyname, len);
    for i := 0 to ki.NumSubKeys - 1 do
    begin
      len := ki.MaxSubKeyLen + 1;
      if RegEnumKeyEx(reg.CurrentKey, i, PChar(keyname), len, nil, nil, nil, nil) <> ERROR_SUCCESS then
        RaiseLastOSError;
      if reg.OpenKey('\SOFTWARE\Clients\StartMenuInternet\' + keyname, false) then
        appName := reg.ReadString('');
      path := '\SOFTWARE\Clients\StartMenuInternet\' + copy(keyname,1,len) + '\shell\open\command';
      if reg.OpenKey(path, false) then
        appName := appName + ' ('+reg.ReadString('')+')';
      if appName <> '' then
        list.add(appName);
      Reg.OpenKey('\SOFTWARE\Clients\StartMenuInternet', true);
    end;
  finally
    reg.Free;
  end;
end;

//and

function GetDefaultBrowser: string;
var
  reg: TRegistry;
  path: string;
begin
  result := '';
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\SOFTWARE\Clients\StartMenuInternet', false) then
    begin
      result := reg.ReadString('');
      path := '\SOFTWARE\Clients\StartMenuInternet\' + result + '\shell\open\command';
      if reg.OpenKey(path, false) then
        result := result + ' ('+reg.ReadString('')+')';
    end
    else
    begin
      reg.RootKey := HKEY_LOCAL_MACHINE;
      if Reg.OpenKey('\SOFTWARE\Clients\StartMenuInternet', false) then
      begin
        result := reg.ReadString('');
        path := '\SOFTWARE\Clients\StartMenuInternet\' + result + '\shell\open\command';
        if reg.OpenKey(path, false) then
          result := result + ' ('+reg.ReadString('')+')';
      end;
    end;
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey('\SOFTWARE\Clients\StartMenuInternet\' + result, false) then
    begin
      result := reg.ReadString('');
      path := '\SOFTWARE\Clients\StartMenuInternet\' + result + '\shell\open\command';
      if reg.OpenKey(path, false) then
        result := result + ' ('+reg.ReadString('')+')';
    end;
  finally
    reg.Free;
  end;
end;

//Test it:

procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStringList;
  i: Integer;
  DefBrw: string;
begin
  DefBrw := GetDefaultBrowser;
  sl := TStringList.Create;
  try
    ListRegisteredBrowsers(sl);
    Memo1.Lines.BeginUpdate;
    for i := 0 to sl.Count - 1 do
      if SameText(sl[i], DefBrw) then
        Memo1.Lines.Add(sl[i] + ' (Default)')
      else
        Memo1.Lines.Add(sl[i]);
    Memo1.Lines.EndUpdate;
  finally
    sl.Free;
  end;
end;

Delphi: Windows service app.

procedure TService1.Service1Execute(Sender: TService);
 begin
   Stream := TMemoryStream.Create;
   try
     ServerSocket1.Port := 80; // WWW port
     ServerSocket1.Active := True;
     while not Terminated do begin
       ServiceThread.ProcessRequests(True);
     end;
     ServerSocket1.Active := False;
   finally
     Stream.Free;
   end;
 end;

procedure TMyTestServiceApp.ServiceAfterInstall(Sender: TService);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create(KEY_READ or KEY_WRITE);
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey('\SYSTEM\CurrentControlSet\Services\' + Name, false) then
    begin
      Reg.WriteString('Description', 'This is a description for my fine Service Application.');
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
end;

Browse more snippets >>