Delphi/Lazarus/Pascal Collection

$> sudo apt-get install freetds-bin

#At Lazarus:
#Put TZConnection component (ZConnection1) and set LibraryLocation as shown:

#  ZConnect1.LibraryLocation:=libsybdb.so.5;

#  and we're done!

procedure TForm1.FormCreate(Sender: TObject);
var
  wplc: TWindowPlacement;
begin
  if not AutoScroll and (WindowState = wsMaximized) then begin
    wplc.length := SizeOf(wplc);
    GetWindowPlacement(Handle, @wplc);
    wplc.rcNormalPosition.Right := wplc.rcNormalPosition.Left + Width;
    wplc.rcNormalPosition.Bottom := wplc.rcNormalPosition.Top + Height;
    wplc.showCmd := SW_MAXIMIZE;
    SetWindowPlacement(Handle, @wplc);
  end;
end;

var
Form1: TForm1;
ms: TMemoryStream;

:

procedure PlayWaveStream(Stream: TMemoryStream);
begin
  if Stream = nil then
    sndPlaySound(nil, SND_ASYNC) //stop sound
  else
    sndPlaySound(Stream.Memory, (SND_ASYNC or SND_MEMORY));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ms.LoadFromFile('c:\Eddie\winner.wav');
  ms.Position := 0;
  PlayWaveStream(ms);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ms := TMemoryStream.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ms.Free;
end;

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdThreadMgr, IdThreadMgrDefault, IdIOHandlerSocket, IdIOHandler,
  IdIOHandlerStream, IdBaseComponent, IdComponent, IdTCPServer,
  IdServerIOHandler, IdServerIOHandlerSocket, StdCtrls, Winsock, ExtCtrls;

type
  PIXEL_FORMAT = packed record
    BitsPerPixel: byte;
    depth: byte;
    BigEndianFlag: byte;
    TrueColourFlag: byte;
    RedMax: Word;
    GreenMax: Word;
    BlueMax: Word;
    RedShift: byte;
    GreenBlue: byte;
    BlueShift: byte;
    Padding: Array[0..2] of byte;
  end;
  
  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    IdIOHandlerStream1: TIdIOHandlerStream;
    IdIOHandlerSocket1: TIdIOHandlerSocket;
    IdThreadMgrDefault1: TIdThreadMgrDefault;
    IdServerIOHandlerSocket1: TIdServerIOHandlerSocket;
    Label1: TLabel;
    Label2: TLabel;
    ListBox1: TListBox;
    Label3: TLabel;
    Image1: TImage;
    procedure IdTCPServer1Connect(AThread: TIdPeerThread);
    procedure IdTCPServer1Execute(AThread: TIdPeerThread);
  private
    { Private declarations }
    ServerPixelFormat: PIXEL_FORMAT;
    ClientPixelFormat: PIXEL_FORMAT;
    procedure writeProtocolVersionMsg(AThread: TIdPeerThread);
    procedure readProtocolVersionMsg(AThread: TIdPeerThread);
    function authenticate(AThread: TIdPeerThread):Boolean;
    procedure readClientInit(AThread: TIdPeerThread);
    procedure initServer(AThread: TIdPeerThread);
    procedure writeServerInit(AThread: TIdPeerThread);

    procedure readSetPixelFormat(AThread: TIdPeerThread);
    procedure readFixColourMapEntries(AThread: TIdPeerThread);
    procedure readSetEncodings(AThread: TIdPeerThread);
    procedure readFrameBufferUpdateRequest(AThread: TIdPeerThread);
    procedure readKeyEvent(AThread: TIdPeerThread);
    procedure readPointerEvent(AThread: TIdPeerThread);
    procedure readClientCutText(AThread: TIdPeerThread);
    procedure doFrameBufferUpdate(AThread: TIdPeerThread);

    procedure processRequest(AThread: TIdPeerThread);

  public
    { Public declarations }
  end;

const
	// Messages from client to server
  SetPixelFormat = 0;
	FixColourMapEntries = 1;
	SetEncodings = 2;
	FrameBufferUpdateRequest = 3;
	KeyEvent = 4;
	PointerEvent = 5;
	ClientCutText = 6;
var
  Form1: TForm1;

  updateIsAvailable: Boolean = False;

	// Authentication
	ConnFailed: byte = 0;
	NoAuth: byte = 1;
	VncAuth: byte = 2;
	VncAuthOK: Cardinal = 0;
	VncAuthFailed: Cardinal = 1;

	// Messages from server to client
	FrameBufferUpdate: byte = 0;
	SetColourMapEntries: byte = 1;
	Bell: byte = 2;
	ServerCutText: byte = 3;

  protocolVersion: String = 'RFB 003.008'+#10;
  
implementation

{$R *.dfm}

function Swap16(ASmallInt: Word): Word  ;
asm
  xchg al,ah
end;

function Swap32(value: Integer{dword}): Integer{dword} ; assembler ;
asm
  bswap eax
end;


procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
  // 
end;

procedure TForm1.writeProtocolVersionMsg(AThread: TIdPeerThread);
begin
  AThread.Connection.Write(protocolVersion);
end;

procedure TForm1.readProtocolVersionMsg(AThread: TIdPeerThread);
var
  protocolVersionMsg: String;
begin
  protocolVersionMsg := AThread.Connection.ReadLn;
  Label2.Caption := protocolVersionMsg;
end;

procedure TForm1.readClientInit(AThread: TIdPeerThread);
var
isShared: Byte;
begin
  AThread.Connection.ReadBuffer(isShared,1);
end;

procedure TForm1.initServer(AThread: TIdPeerThread);
begin
        // We may already have a shared server
end;

procedure TForm1.readSetPixelFormat(AThread: TIdPeerThread);
var
  padding: byte;
begin
  AThread.Connection.ReadBuffer(padding,3);
  AThread.Connection.ReadBuffer(ClientPixelFormat,16);
end;

procedure TForm1.readFixColourMapEntries(AThread: TIdPeerThread);

begin
end;

procedure TForm1.readSetEncodings(AThread: TIdPeerThread);
var
  padding: byte;
  i, numEncodings: Word;
  encType: Longint;
begin
  AThread.Connection.ReadBuffer(padding,1);
  AThread.Connection.ReadBuffer( {U16} numEncodings,2);
  numEncodings := Swap(numEncodings);
  Listbox1.Items.Add('Sum of Encodings: '+IntToStr(numEncodings));
  for i := 1 to numEncodings do begin
    AThread.Connection.ReadBuffer(encType,4);
    //encType := ntohl(encType);
    encType := Swap32(encType);
    Listbox1.Items.Add('Read Encoding: '+IntToStr(encType));
  end;

//{ numEncodings *  AThread.Connection.ReadBuffer( S32 encType,4); }
end;

procedure TForm1.readFrameBufferUpdateRequest(AThread: TIdPeerThread);
var
  incremental: byte;
  xpos, ypos, width, height: Word;
begin
  AThread.Connection.ReadBuffer( {U8} incremental,1);
  AThread.Connection.ReadBuffer( {U16} xpos,2);
  AThread.Connection.ReadBuffer( {U16} ypos,2);
  AThread.Connection.ReadBuffer( {U16} width,2);
  AThread.Connection.ReadBuffer( {U16} height,2);
  xpos := Swap16(xpos);
  ypos := Swap16(ypos);
  width := Swap16(width);
  height := Swap16(height);
  Listbox1.Items.Add(IntToStr(xpos)+' '+IntToStr(ypos)+' '+IntToStr(width)+''+IntToStr(height));
  processRequest(AThread);
end;

procedure TForm1.processRequest(AThread: TIdPeerThread);
// take a screenshot
// (while testing, put it into Image1)
var
  Width,Height : Word;
  SrcWindow: THandle;
  SrcDC: HDC;
  Bitmap: TBitmap;
begin
  SrcWindow:= GetDesktopWindow;
  if SrcWindow <> 0 then
  begin
    SrcDC:= GetDC(SrcWindow);
    if SrcDC <> 0 then
    begin
      Bitmap:= TBitmap.Create;
      Width := GetSystemMetrics(SM_CXSCREEN);
      Height := GetSystemMetrics(SM_CYSCREEN);
      Bitmap.Width:= Width div 4;
      Bitmap.Height:= Height div 4;
      StretchBlt(Image1.Canvas.Handle,0,0,Bitmap.Width,Bitmap.Height,
        SrcDC,0,0,Width,Height,SRCCOPY);
    end;
    ReleaseDC(SrcWindow,SrcDC);
    updateIsAvailable := True;
  end;
end;

procedure TForm1.readKeyEvent(AThread: TIdPeerThread);
var
  downFlag: byte;
  padding: byte;
  keyCode: Cardinal;
begin
  AThread.Connection.ReadBuffer(downFlag,1);
  AThread.Connection.ReadBuffer(padding,2);
  AThread.Connection.ReadBuffer(keyCode,4);
end;

procedure TForm1.readPointerEvent(AThread: TIdPeerThread);
var
  buttonMask: byte;
  xpos, ypos: Word;
begin
  AThread.Connection.ReadBuffer(buttonMask,1);
  AThread.Connection.ReadBuffer(xpos,2);
  AThread.Connection.ReadBuffer(ypos,2);
  // swap bytes
  xpos := Swap16(xpos);
  ypos := Swap16(ypos);
  Listbox1.Items.Add('x:'+IntToStr(xpos)+' y:'+IntToStr(ypos))
end;

procedure TForm1.readClientCutText(AThread: TIdPeerThread);
var
  padding: byte;
  txtLength: Cardinal;
  text: String;
begin
  AThread.Connection.ReadBuffer(padding,3);
  AThread.Connection.ReadBuffer(txtLength,4);
  AThread.Connection.ReadBuffer( {U8Array} text,1);
end;

procedure TForm1.writeServerInit(AThread: TIdPeerThread);
var
  desktopName : String;
  var x,y : Word;
begin
  desktopName := 'Hello World';

  // get screen dimension and swap bytes, because client expect high byte first
  x := GetSystemMetrics(SM_CXSCREEN);
  y := GetSystemMetrics(SM_CYSCREEN);
  //  x := Swap(x);
  //  y := Swap(y);
  x := Swap16(x);
  y := Swap16(y);

  // send framebuffer dimensions
  AThread.Connection.WriteBuffer(x, 2, True);
  AThread.Connection.WriteBuffer(y, 2, True);

  // PreferredPixelFormat
  ServerPixelFormat.BitsPerPixel := 16;
  ServerPixelFormat.depth := 16;
  ServerPixelFormat.BigEndianFlag := 0;
  ServerPixelFormat.TrueColourFlag := 1;
  AThread.Connection.WriteBuffer(ServerPixelFormat, 16, True);

  // Desktopname Length
  AThread.Connection.WriteCardinal(length(desktopName));

  // Desktop Name
  AThread.Connection.Write(desktopName);
end;

function TForm1.authenticate(AThread: TIdPeerThread):Boolean;
var AUTH_NUM, ClientAuth: Byte;
challengeQuestion: array[1..16] of Byte;
challengeAnswer: array[1..16] of Byte;
begin
  // send 1 authentication (Version 3.8)
  AUTH_NUM := 1;
  AThread.Connection.WriteBuffer(AUTH_NUM,1, True);
  AThread.Connection.WriteBuffer(VncAuth,1, True);
  AThread.Connection.ReadBuffer(ClientAuth,1);
  Label1.Caption := 'VNC auth: ' + IntToStr(ClientAuth);
  If ClientAuth = 2 then
  begin
    AThread.Connection.WriteBuffer(challengeQuestion,16, True);
    AThread.Connection.ReadBuffer(challengeAnswer,16);
    // for now, we do not check
    AThread.Connection.WriteBuffer(VncAuthOK,4, True);
  end;
  Result := true;
end;

procedure TForm1.doFrameBufferUpdate(AThread: TIdPeerThread);
// we still have framebuffer data to send to a client...
// (to be implemented...)
//
begin
  Listbox1.Items.Add('have FrameBuffer ready here...');
// all data sent? then updateIsAvailable := False;
end;

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
input: Byte;
msgStr: String;
begin
  // Loop
  writeProtocolVersionMsg(AThread);
  readProtocolVersionMsg(AThread);
  if (authenticate(AThread)) then begin {} end;
  readClientInit(AThread);
  initServer(AThread);
  writeServerInit(AThread);
  // start loop while client connected
  while not AThread.Terminated do
  begin
    if updateIsAvailable then doFrameBufferUpdate(AThread);
    //
    AThread.Connection.ReadBuffer(input,1);
    case input of
    SetPixelFormat:
      begin
      msgStr := 'SetPixelFormat';
      readSetPixelFormat(AThread);
      end;

    FixColourMapEntries:
      begin
      msgStr := 'FixColourMapEntries';
      readFixColourMapEntries(AThread);
      end;

    SetEncodings:
      begin
      msgStr := 'SetEncodings';
      readSetEncodings(AThread);
      end;

    FrameBufferUpdateRequest:
      begin
      msgStr := 'FrameBufferUpdateRequest';
      readFrameBufferUpdateRequest(AThread);
      end;

    KeyEvent:
      begin
      msgStr := 'KeyEvent';
      readKeyEvent(AThread);
      end;

    PointerEvent:
      begin
      msgStr := 'PointerEvent';
      readPointerEvent(AThread);
      end;

    ClientCutText:
      begin
      msgStr := 'ClientCutText';
      readClientCutText(AThread);
      end;
      
    else
      msgStr := 'unknown message type'+IntToStr(input);
    end;

    Listbox1.Items.Add(msgStr);
  end;
end;

end.

procedure TForm1.Button1Click(Sender: TObject);
var
  fs: TFileStream;
  fn : string;
begin
  //frxReport1.LoadFromFile('c:\Proyectos\rep\reporte.fr3');

  fn := 'c:\Proyectos\reporte.fr3';
  frxReport1.Clear;
  fs := TFileStream.Create(fn, fmOpenReadWrite);
  try
    fs.Position := 0;

    frxReport1.FileName := fn; {<-- The trick using "filename path" }
    frxReport1.LoadFromStream(fs);

  finally
    fs.Free;
  end;
  frxReport1.PrepareReport;
  frxReport1.ShowPreparedReport;
end;

function DataRowToJSONObject(const AValue : TDataSet): TJSONObject;
var
  I: Integer;
  AString : String;
begin
  Result := TJSONObject.Create();
  for I := 0 to AValue.FieldDefs.Count-1 do
  begin
    case AValue.FieldDefs[I].DataType of
      ftString, ftWideString, ftMemo :
        begin
          if AValue.FieldByName(AValue.FieldDefs[I].Name).AsString <> '' then
            Result.AddPair(AValue.FieldDefs[I].Name, AValue.FieldByName(AValue.FieldDefs[I].Name).AsString)
          else
            Result.AddPair(AValue.FieldDefs[I].Name, ' ');
        end;
      ftSmallint, ftInteger, ftWord, ftLongWord, ftShortint :
        begin
          Result.AddPair(AValue.FieldDefs[I].Name, TJSONNumber.Create(AValue.FieldByName(AValue.FieldDefs[I].Name).AsInteger));
        end;
      ftFloat, ftCurrency :
        begin
          Result.AddPair(AValue.FieldDefs[I].Name, TJSONNumber.Create(AValue.FieldByName(AValue.FieldDefs[I].Name).AsFloat));
        end;
      ftBoolean :
        begin
          Result.AddPair(AValue.FieldDefs[I].Name, AValue.FieldByName(AValue.FieldDefs[I].Name).AsString)
        end;
    end;
  end;
end;
 
function JSONObjectToDataRow(const AJson : TJSONObject; const AValue : TDataSet): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to AValue.FieldDefs.Count - 1 do
  begin
    case AValue.FieldDefs[I].DataType of
      ftString, ftWideString, ftMemo :
        begin
          AValue.FieldByName(AValue.FieldDefs[I].Name).AsString :=
            AJson.Get(AValue.FieldDefs[I].Name).JsonValue.Value;
        end;
      ftSmallint, ftInteger, ftWord, ftLongWord, ftShortint :
        begin
          AValue.FieldByName(AValue.FieldDefs[I].Name).AsInteger :=
            (AJson.Get(AValue.FieldDefs[I].Name).JsonValue as TJsonNumber).AsInt;
        end;
      ftFloat, ftCurrency :
        begin
          AValue.FieldByName(AValue.FieldDefs[I].Name).AsFloat :=
            (AJson.Get(AValue.FieldDefs[I].Name).JsonValue as TJsonNumber).AsDouble;
        end;
      ftBoolean :
        begin
          AValue.FieldByName(AValue.FieldDefs[I].Name).AsBoolean :=
            StrToBool(AJson.Get(AValue.FieldDefs[I].Name).JsonValue.Value);
        end;
    end;
  end;
end;

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;

(* in form: Process, Memo, Button, Edit *)

procedure TForm1.Button1Click(Sender: TObject);
begin
  Process1.CommandLine:= Edit1.Text;
  Process1.Execute;
  Memo1.Lines.LoadFromStream(Process1.Output);
end;

//Uses Process,...

function isMacDarkMode: Boolean;
var s:ansistring;
begin
  RunCommand('/usr/bin/defaults',['read','-g','AppleInterfaceStyle'],s);
  Result:=(pos('Dark',s)>0);
end; 

function MessageDlg2(capt: string; Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; Captions: array of string): Integer;
var
  aMsgDlg: TForm;
  i: Integer;
  dlgButton: TBitBtn;
  CaptionIndex: Integer;
begin

  { Create the Dialog }
  { Dialog erzeugen }
  
  aMsgDlg := CreateMessageDialog(Msg, DlgType, Buttons);
  try
    aMsgDlg.Caption:=capt;
    captionIndex := 0;

    { Loop through Objects in Dialog }
    { Über alle Objekte auf dem Dialog iterieren}

    for i := 0 to aMsgDlg.ComponentCount - 1 do
    begin

     { If the object is of type TButton, then }
     { Wenn es ein Button ist, dann...}

      if (aMsgDlg.Components[i] is TBitBtn) then
      begin
        dlgButton := TBitBtn(aMsgDlg.Components[i]);
        if CaptionIndex > High(Captions) then Break;

        { Give a new caption from our Captions array}
        { Schreibe Beschriftung entsprechend Captions array}

        dlgButton.Caption := Captions[CaptionIndex];
        Inc(CaptionIndex);
      end;
    end;
    Result := aMsgDlg.ShowModal;
  finally
    aMsgDlg.Free;
  end;
end;

$> 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

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

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;

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

1) instala lazarus normal

2) instala estas dependencias:

sudo apt-get install msttcorefonts
sudo apt-get install gsfonts
sudo apt-get install sqlite3 libsqlite3-dev
sudo apt-get install libcanberra-gtk-module

3) abre lazarus

4) ve a "packages=> open package file .lpk"

5) en la ventana de busqueda ubica la carpeta donde tienes los fuentes de fast report, yo lo hice con el 6.6

6) vas a buscar el archivo fs_lazarus.lpk y le vas a dar a open

7) en la ventana nueva dale a "compile" y cuando termine vas a "use=>install" en la misma ventanita

8) vas a repetir el mismo proceso del 4 al 7 para estos otros archivo:
fr6_lazarus.lpk
frxchartlazarus.lpk
frxlazdbf.lpk
frxe6_lazarus.lpk
frxlazsqlite.lpk 

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

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

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

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

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

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.

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;

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;