-> how to get rid of kylix open edition compiled program gpl window

------------------------
for console application

comment

//{$APPTYPE CONSOLE}

for GUI application jjust run it as

#./Project1 -ns

which means no splash :)

there are some code patterns for that

program loadmyapp;
 
{$APPTYPE CONSOLE}
 
uses
  Libc,
  SysUtils;
 
var
  sEnv : String;
begin
  sEnv := GetEnvironmentVariable('LD_LIBRARY_PATH');
  sEnv := Format('LD_LIBRARY_PATH=.:%s', [sEnv]);
  putenv(PChar(sEnv));
  execv('./myapp', ArgValues);
end.

-------------------------------

 -> how to run kylix app with libborqt in the sam directory 

----------------------------
export LD_LIBRARY_PATH=/.:

./Project1

-------------------





 -> chmod implementation

<-----------------------------------

function setpermission(file: string): boolean;                          
   var                                                                     
     perms: Cardinal;                                                      
     ret: Integer;                                                         
   begin                                                                   
     result := True;                                                       
     perms := S_IRUSR or S_IWUSR or S_IXUSR or                             
              S_IRGRP or S_IWGRP or S_IROTH;                               
                                                                           
     ret := chmod(PChar(file),perms);                                      
     if (ret = -1) then begin                                              
       result := False;                                                    
     end;                                                                  
   end;                                                                    
------------------------------------

 -> copy file

------------------------------------------------------------------------------
   function CopyFile(src: string; dst:string; faillExists: boolean): boolean;
   const                                                                     
     BufSize = 8192;                                                         
   var                                                                       
     nBytes: Integer;                                                        
     pBuf: Pointer;                                                          
     SrcStm, DstStm: TFileStream;                                            
   begin                                                                     
     Result := True;                                                         
     SrcStm := nil;                                                          
     DstStm := nil;                                                          
     if (faillExists) then begin                                             
       if (FileExists(dst)) then begin                                       
         Result := False;                                                    
         Exit;                                                               
       end;                                                                  
     end;                                                                    
     try                                                                     
       try                                                                   
         SrcStm := TFileStream.Create(src, fmOpenRead);                      
         DstStm := TFileStream.Create(dst, fmCreate or fmShareExclusive);    
         GetMem(pBuf, BufSize);                      
        try                                                                 
           Repeat                                                           
             nBytes := SrcStm.Read(pBuf^, BufSize);                         
             if (nBytes > 0) then                                           
               DstStm.Write(pBuf^, nBytes);                                 
           Until nBytes = 0;                                                
       finally                                                              
           FreeMem(pBuf);                                                   
         end;                                                               
       except                                                                
         Result := False;                                                    
       end;                                                                  
     finally                                                                 
       SrcStm.Free;                                                          
       DstStm.Free;                                                          
     end;                                                                    
   end;                             
------------------------------------------------------------------------------->

 -> current directory
---------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := SetCurrentDir();
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  SetCurrentDir(Edit2.Text);
end;
--------------------------

 -> howto create desktop icon
--------------------------------------

type
  TDesktopShortCut = record
    Name: TFileName; 
    Comment: string; 
    Exec: TFileName; 
    Icon: TFileName;
    MiniIcon: TFileName;
end;

function CreateShortcut(path: string; const Sc :TDesktopShortCut): 
boolean;
var
  Ini: TInifile;
  fname: string;
begin
  Result := False;  
  fname := ChangeFileExt(Sc.Name, '.desktop');
  fname := IncludeTrailingPathDelimiter(path) + fname;
  try
    Ini := TInifile.Create(fname);
    Ini.WriteString('Desktop Entry', 'Name', Sc.Name);
    Ini.WriteString('Desktop Entry', 'Comment', Sc.Comment);
    Ini.WriteString('Desktop Entry', 'Exec', Sc.Exec);
    Ini.WriteString('Desktop Entry', 'Icon', Sc.Icon);
    Ini.WriteString('Desktop Entry', 'MiniIcon', Sc.MiniIcon);
    Ini.WriteInteger('Desktop Entry', 'Terminal', 0);
    Ini.WriteString('Desktop Entry', 'Type', 'Application');
    Ini.UpdateFile;
    Result := True;   
  finally
    Ini.Free;
  end;
end;

and now

procedure TForm1.Button1Click(Sender: TObject);
var
  Sc: TDesktopShortCut;
begin
  Sc.Name := 'Project1';
  Sc.Comment := 'Project Comment';
  Sc.Exec := '/home/roni/kylix/Project1';
  Sc.Icon := '/home/roni/kylix/project_icon.xpm';
  Sc.MiniIcon := '/home/roni/kylix/project_mini_icon.xpm';
  CreateShortCut('/home/roni/Desktop/', Sc);
end;

---------------------------------------

 -> Disk Free

----------------------------------
function GetDiskFree(const mntdir: string; var AllBytes, FreeBytes: 
int64): boolean;
var
  fs: TStatfs;
begin
  Result := False;
  if statfs(mntdir,fs) = 0 then begin
    if fs.f_blocks > 0 then begin
      AllBytes := fs.f_blocks * Int64(fs.f_bsize); 
      FreeBytes := fs.f_bavail * Int64(fs.f_bsize); 
      Result := True;
    end;
  end;
end;;

procedure TForm1.Button1Click(Sender: TObject); 
var
  allbyte, freebyte: int64; 
begin
  GetDiskFree('/', allbyte, freebyte);
  Label1.Caption := Format('Allbytes:%d FreeBytes:%d', [allbyte, freebyte]);
end;

-------------------------------------------

 -> Draw Desktop

---------------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
var
  d: QWidgetH;
  QC: QColorH;
begin
  d := Application.desktop;
  QC := QColor(clBlack);
  try
    QWidget_setBackgroundColor(d, QC);
  finally
    QColor_destroy(QC);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  d: QWidgetH;
begin
  d := Application.desktop;
  QWidget_setBackgroundPixmap(d, Image1.Picture.Bitmap.Handle);
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  d: QWidgetH;
  QP: QPainterH;
  VCanvas: TCanvas;
  R: TRect;
begin
  d := Application.desktop;
  QP := QPainter_create(QWidget_to_QPaintDevice(d));
  try
    VCanvas := TCanvas.Create;
    try
      VCanvas.Start(False);
      VCanvas.Handle := QP;
      R := Rect(100, 100, 200, 200);
      VCanvas.Brush.Color := clBlack;
      VCanvas.Rectangle(R);
      VCanvas.Stop;
      VCanvas.ReleaseHandle;
    finally
      VCanvas.Free;
    end;
  finally
    QPainter_destroy(QP);
  end;
end;

------------------------------------------------------

 -> SetFocusWindow

-----------------------------------
procedure SetForegroundXWindow(Wnd: WIndow);
begin
  XRaiseWindow(QtDisplay, Wnd);

  XSetInputFocus(QtDisplay, Wnd, RevertToParent, CurrentTime); 
end;

procedure TForm1.Button1Click();
var
  Wnd: TWindow;
begin

  Wnd := FindXWindow('Procect1', 'title'); 
  if (Wnd <> 0) then begin
    SetForegroundXWindow(Wnd);
  end;
end;

----------------------------------

 -> application style

--------------------------------
// Windows
procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.Style.DefaultStyle := dsWindows;
end;

// X(Motif)
procedure TForm1.Button2Click(Sender: TObject);
begin
  Application.Style.DefaultStyle := dsMotif;
end;

// Mac
procedure TForm1.Button3Click(Sender: TObject);
begin
  Application.Style.DefaultStyle := dsPlatinum;
end;

----------------

 -> Ini File
------------------------
procedure TForm1.Button1Click(Sender: TObject);
var
  Ini: TInifile;
  fname: string;
begin
  fname := ChangeFileExt(Application.ExeName, '.ini');
  try
    Ini := TInifile.Create(fname); 
    Ini.WriteInteger('Application', 'Left', Self.Left);
    Ini.WriteInteger('Application', 'Top', Self.Top);
    Ini.WriteInteger('Application', 'Height', Self.Height);
    Ini.WriteInteger('Application', 'Width', Self.Width);
    Ini.UpdateFile; 
  finally
    Ini.Free;
  end;
end;
------------------------

 -> grab keys

--------------------
procedure TForm1.Grab();
begin
   XGrabKeyboard(QTDisplay, QWidget_winID(Self.Handle), Ord(True),
                GrabModeAsync, GrabModeAsync, CurrentTime);
end;

procedure TForm1.Ungrab();
begin
XUngrabKeyboard((QtDisplay, CurrentTime);
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; 
Shift: TShiftState);
begin
// grabbing
end;
-------------------------------------------

 -> kill
----------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var
  pid: integer;
begin
  pid := StrToInt(Edit1.Text);
  Libc.kill(pid, SIGTERM);
end; 




procedure TForm1.Button2Click(Sender: TObject);
var
  pid: integer;
begin
  pid := StrToInt(Edit1.Text);
  Libc.kill(pid, SIGKILL);
end; 

------------------------------------

 -> MathUtil

---------------------------------
library libMathUtil;

uses
  SysUtils,Classes;

function distance(x1, y1, x2, y2: double): double; stdcall;
begin
  result := Sqrt(Sqr(x1 - x2) + Sqr(y1 - y2));
end;


function distanceSq(x1, y1, x2, y2: double): double; stdcall;
begin
  result := Sqr(x1 - x2) + Sqr(y1 - y2);
end;

exports
  distance ,
  distanceSq;
begin
end.

 Delphi Kylix

unit MathUtil;

interface

function distance(x1, y1, x2, y2: double): double; stdcall;
function distanceSq(x1, y1, x2, y2: double): double; stdcall;

implementation

function distance(x1, y1, x2, y2: double): double;
        external 'libMathUtil.so' name 'distance';
function distanceSq(x1, y1, x2, y2: double): double;
        external 'libMathUtil.so' name 'distanceSq';

end.

 how to use

implementation

uses
  MathUtil;

{$R *.xfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  dis: double;
begin
  dis := distance(10, 10, 20, 20);
  ShowMessage(FloatToStr(dis));
  dis := distanceSq(10, 10, 20, 20);
  ShowMessage(FloatToStr(dis));
end;

end.

 c++ kylix mathutil.h

#ifndef MathUtilH
#define MathUtilH
#pragma link "libMathUtil.so"

extern "C" __stdcall double distance(double x1, double y1, double x2, 
double y2);
extern "C" __stdcall double distanceSq(double x1, double y1, double x2, 
double y2);

#endif

-------------

 -> MemFree

----------------------------------------------------function 
GetMemFree(var AllBytes, FreeBytes: Cardinal): boolean;
var
  Info: TSysInfo;
begin
  Result := False;
  if sysinfo(Info) = 0 then begin
      AllBytes := Info.totalram;
      FreeBytes := Info.freeram;
      // Info.sharedram;
      // Info.bufferram;
      // Info.totalswap;
      // Info.freeswap;
      Result := True;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject); 
var
  allbyte, freebyte: Cardinal; 
begin
  GetMemFree(allbyte, freebyte);
  Label1.Caption := Format('Allbytes:%d FreeBytes:%d', [allbyte, 
freebyte]);
end;
------------------------------------------------------

 -> MountList

------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject); 
var
  MntDrv : PIOFile; 
  MntEnt : PMountEntry; 
begin
  MntDrv := setmntent('/etc/mtab','r'); 
  if MntDrv <> nil then
  repeat
  //エントリの取得
    MntEnt := getmntent(MntDrv); 
    if MntEnt <> nil then
    with MntEnt^ do
      ShowMessage(string(mnt_fsname)); // /dev/hda6
      ShowMessage(string(mnt_type)); // ext2
      ShowMessage(string(mnt_dir)); // /
    end;
  until MntEnt = nil;
  endmntent(MntDrv); 
end;
-------------------------------------------

 -> Grab mouse pointer

----------------------------------------

procedure TForm1.Grab();
begin
  XGrabPointer(QtDisplay, QWidget_winID(Self.Handle), Ord(True),
              ButtonPressMask or ButtonReleaseMask or PointerMotionMask,
              GrabModeAsync, GrabModeAsync, 0, 0, 0);
end;

procedure TForm1.UnGrab();
begin
  XUngrabPointer(QtDisplay, CurrentTime);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
//grabbing
end;
-------------------------------------

 -> move file

----------------------------------

function MoveFile(src: string; dst:string): boolean;
var
begin
  Result := RenameFile(src, dst);
end;
---------------------------------

 -> window without title

--------------------------------------
unit Unit1;

interface

uses
  SysUtils, Types, Classes, Variants, QTypes, QGraphics, QControls,   
QForms,QDialogs, QStdCtrls;

type
  TForm1 = class(TForm)
  private
  public
    procedure InitWidget; override;
    function WidgetFlags: Integer; override;
  end;

var
  Form1: TForm1;

implementation

uses
  Qt;

{$R *.xfm}

procedure TForm1.InitWidget;
var
  QB: QBitmapH;
  QP: QPainterH;
  VCanvas: TCanvas;
  R: TRect;
begin
  inherited InitWidget;
  QB := QBitmap_create(Width, Height, True, 
QPixmapOptimization_DefaultOptim);
  try
    QP := QPainter_create(QB, Handle);
    try
      VCanvas := TCanvas.Create;
      try
        VCanvas.Start(False);
        VCanvas.Handle := QP;
        R := ClientRect;
        VCanvas.Brush.Color := clMask;
        VCanvas.FillRect(R);
        VCanvas.Brush.Color := clDontMask;
        VCanvas.Rectangle(R);
        VCanvas.Stop;
        VCanvas.ReleaseHandle;
      finally
        VCanvas.Free;
      end;
      QWidget_setMask(Handle, QB);
    finally
      QPainter_destroy(QP);
    end;
  finally
    QBitmap_destroy(QB);
  end;
end;

function TForm1.WidgetFlags: Integer;
begin
  Result := inherited WidgetFlags and not 
Integer(WidgetFlags_WRepaintNoErase);
end;
--------------------------------------------

 -> operating system version
-----------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var
  un: utsname;
begin
  Libc.uname(un);
  ShowMessage(StrPas(un.sysname)); // Linux
  ShowMessage(StrPas(un.release)); // 2.14
  ShowMessage(StrPas(un.machine)); // i686
end;
----------------------------------

 -> Parameters
-----------------------------------------
procedure PrintParam();
var
  i: Integer;
  cmd: string;
begin
  for i := 0 to ParamCount do begin
    cmd := CommandStr(i);
    ShowMessage(cmd);
  end;
end;

function Command(): string;
var
  path: String;
  ft: TextFile;
  Buff: String;
  p: PChar;
begin
  Result := EmptyStr;
  path := Format('/proc/%d/cmdline', [getPid()]);
  if not FileExists(path) then begin
    Exit;
  end;
  AssignFile(ft, path);
  Reset(ft);
  while not EOF(ft) do
  begin
  ReadLn(ft, Buff);
  p := PChar(Buff+#0);
    while (p^ <> #0) do begin
      Result := Result + StrPas(p) + ' '; // 空白に置き換える
      p := StrChr(p, 0);
      Inc(p);
    end;
  end;
  CloseFile(ft);
end;
----------------------------------------

 -> print dialog
--------------------------------
Uses
  ..., QPrinters;



procedure TForm1.PrintSetup
begin
  with (Printer) do begin
    if (ExecuteSetup) then begin
      BeginDoc;
      Canvas.TextOut(100, 200, 'TestPrint');
      EndDoc;
    end;
  end;
end;
------------------

 -> dpi dialog
---------------------------------

uses
  ..., Qt, QPrinters; // usesする



procedure TForm1.SetPriterDpi
begin
  with (Printer) do begin
    QPainter_scale(Printer.Canvas.Handle, XDPI/360.0, YDPI/360.0);
    BeginDoc;
    Canvas.Pen.Color := clBlack;
    Canvas.Rectangle(100, 100, 200, 200);
    EndDoc;
  end;
end;
-----------------------------------

 -> resources
---------------------------------------------------
implementation

{$R *.dfm}
{$R comp.res} // ここを忘れずに追加

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Bitmap.LoadFromResourceName(hInstance, 'TCOMP');
end;
-------------------------------------

 -> how to create resource for kylix
--------------------------------
download and install binutils

$ tar xvzf binutils-2.13.tar.gz
$ cd binutils-2.13
$ ./configuer --with-windres
$ make

TCOMP BITMAP icon.bmp


$ windres comp.rc comp.res

 in source code

implementation

{$R *.dfm}
{$R comp.res}

-----------------------------------------------------------------------

 -> Play Sound
---------------------------------------

unit sndplay;

{$ALIGN 4}
{$MINENUMSIZE 4}

interface

type
  PWaveFormat = ^TWaveFormat;
  TWaveFormat = record
    wFormatTag        : Word;
    nChannels         : Word;
    nSamplesPerSec    : Cardinal;
    nAvgBytesPerSec   : Cardinal;
    nBlockAlign       : Word;
    wBitsPerSample    : Word;
  end;

function SOUND_PCM_WRITE_BITS: Cardinal;
function SOUND_PCM_WRITE_CHANNELS: Cardinal;
function SOUND_PCM_WRITE_RATE: Cardinal;
function SNDCTL_DSP_SYNC: Cardinal;

function PlaySound(fname: string): boolean;

implementation

uses SysUtils, Libc, KernelIOCtl;

const
  WAVE_BUFF_SIZE = 1024;

type
  EPlayException = Exception;

function SOUND_PCM_WRITE_BITS: Cardinal;
begin
  Result := __IOWR(Ord('P'), 5, SizeOf(Integer));
end;

function SOUND_PCM_WRITE_CHANNELS: Cardinal;
begin
  Result := __IOWR(Ord('P'), 6, SizeOf(Integer));
end;

function SOUND_PCM_WRITE_RATE: Cardinal;
begin
  Result := __IOWR(Ord('P'), 2, SizeOf(Integer));
end;

function readWaveHead(pfi: PIOFile; var wf: TWaveFormat; var datasize: 
integer): boolean;
var
  head: array[0..3] of Char;
  offs: Cardinal;
begin
  Result := False;
  Libc.memset(@wf, 0, sizeof(TWaveFormat));
  Libc.fread(@head, sizeof(head), 1, pfi);
  if (head <> 'RIFF') then begin
    Exit;
  end;
  Libc.fread(@offs, sizeof(offs), 1, pfi);
  Libc.fread(@head, sizeof(head), 1, pfi);
  if (head <> 'WAVE') then begin
    Exit;
  end;
  Libc.fread(@head, sizeof(head), 1, pfi);
  while (feof(pfi) = 0) do begin
    Libc.fread(@offs, sizeof(offs), 1, pfi);
    if (head = 'fmt ') then begin
      if (offs < sizeof(TWaveFormat)) then begin
        Exit;
      end;
      Libc.fread(@wf, sizeof(TWaveFormat), 1, pfi);
      if (wf.wFormatTag <> 1) then begin
        Exit;
      end;
      Libc.fseek(pfi, offs - sizeof(TWaveFormat), SEEK_CUR); // 
読み飛ばし
    end
    else if (head = 'data') then begin
      // ヘッダ終了
      datasize := offs;
      break;
    end
    else begin
      Libc.fseek(pfi, offs, SEEK_CUR); // 読み飛ばし
    end;
    Libc.fread(@head, sizeof(head), 1, pfi);
  end;
  Result := True;
end;

procedure setDspDev(fd: integer; pwf :PWaveFormat);
var
  status: integer;
  para: Cardinal;
begin


  para := pwf^.wBitsPerSample;
  status := Libc.ioctl(fd, SOUND_PCM_WRITE_BITS, @para);
  if (status < 0) then begin
    raise EPlayException.Create('Bit Error');
  end;
  if (para <> pwf^.wBitsPerSample) then begin
    raise EPlayException.Create('Bit Error');
  end;



  para := pwf^.nChannels;
  status := Libc.ioctl(fd, SOUND_PCM_WRITE_CHANNELS, @para);
  if (status < 0) then begin
    raise EPlayException.Create('Channels Error');
  end;
  if (para <> pwf^.nChannels) then begin
    raise EPlayException.Create('Channels Error');
  end;


  para := pwf^.nSamplesPerSec;
  status := Libc.ioctl(fd, SOUND_PCM_WRITE_RATE, @para);
  if (status < 0) then begin
    raise EPlayException.Create('Rate Error');
  end;
  if (para <> pwf^.nSamplesPerSec) then begin
    raise EPlayException.Create('Rate Error');
  end;
end;

procedure playWave(pfi: PIOFile; dspfd: integer; datasize: integer);
var
  rblk, wblk, woff, bufsz, size: integer;
  buff, p: PByte;
begin
  buff := Libc.malloc(WAVE_BUFF_SIZE);
  if (buff = nil) then begin
    Exit;
  end;
  size := 0;
  bufsz := datasize;
  if (bufsz > WAVE_BUFF_SIZE) then begin
    bufsz := WAVE_BUFF_SIZE;
  end;
  rblk := Libc.fread(buff, Sizeof(Byte), bufsz, pfi);
  while (feof(pfi) = 0) do begin
    p := buff;
    wblk := FileWrite(dspfd, p^, rblk);
    Inc(p, wblk);
    while (rblk > wblk) do begin
      woff := FileWrite(dspfd, p^, rblk);
      Inc(wblk, woff);
      Inc(p, woff);
    end;
    Inc(size, rblk);
    if (size >= datasize) then begin
      break;
    end;
    rblk := Libc.fread(buff, Sizeof(Byte), bufsz, pfi);
  end;
end;

function PlaySound(fname: string): boolean;
const
  devdsp = '/dev/dsp';
var
  pfi: PIOFile;
  wf: TWaveFormat;
  datasize: integer;
  fd: integer;
begin
  Result := False;
  pfi := Libc.fopen(PChar(fname), 'rb');
  if (pfi = nil) then begin
    Exit;
  end;
  try
    if (not readWaveHead(pfi, wf, datasize)) then begin
      raise EPlayException.Create('Head Error');
    end;
    fd := FileOpen(devdsp, fmOpenWrite);
    if (fd = -1) then begin
      raise EPlayException.Create('Device Open Error');
    end;
    try
      setDspDev(fd, @wf);
      playWave(pfi, fd, datasize);
      Result := True;
    finally
      FileClose(fd);
    end;
  finally
    Libc.fclose(pfi);
  end;
end;
end.

 how to use


procedure TForm1.Button1Click(Sender: TObject);
begin
  PlaySound('/home/roni/sound.wav');
end;
------------------------

 -> how to create symlink
------------------------------
function FileOrDirExists(file: string): boolean;
begin
  Result := FileExists(file) or DirectoryExists(file);
end;

function symbollink(src: string; dst: string): boolean;
var
  ret: Integer;
begin
  result := True;
  if (FileOrDirExists(src) and not FileExists(dst)) then
    result := False;
    Exit;
  end;
  if (Libc.symlink(PChar(src), PChar(dst)) <> 0) then
    result := False;
  end;
end;
--------------------------------------

 -> text file
---------------------------------
procedure TForm1.Button1Click(Senter: TObject);
var
  F1: TextFile;
  Ch: Char;
begin
  if OpenDialog1.Execute then begin
    AssignFile(F1, OpenDialog1.Filename);
    System.SetLineBreakStyle(F1,tlbsLF);
    Reset(F1);
    while not Eof(F1) do begin
      Read(F1, Ch);
    end;
    CloseFile(F1);
  end;
end;
---------------------------------------------

 -> how to change cursor

-----------------------------------------------------
unit WinCur;

interface

uses Qt;

function LoadCursor(Instance: Cardinal; CursorName: PChar): QCursorH;
function LoadCursorFromFile(FileName: PChar): QCursorH;

implementation

uses Classes, Types, SysUtils, QGraphics, QTypes;

type
  PCursorDirEntry = ^TCursorDirEntry;
  TCursorDirEntry = packed record
    bWidth: Byte;
    bHeight: Byte;
    bColorCount: Byte;
    bReserved: Byte;
    wXHotspot: Word;
    wYHotspot: Word;
    lBytesInRes: Cardinal;
    dwImageOffset: Cardinal;
  end;

  PCursorDir = ^TCursorDir;
  TCursorDir = packed record
    cdReserved: WORD;
    cdType: WORD;
    cdCount: WORD;
    cdEntries: array[0..0] of TCursorDirEntry;
  end;

  TCustomCursor = record
  Bits: array[0..32*4-1] of Byte;
  Mask: array[0..32*4-1] of Byte;
  HotSpot: TPoint;
  end;

  PRGBQuad = ^TRGBQuad;
  TRGBQuad= packed record
    rgbBlue: Byte;
    rgbGreen: Byte;
    rgbRed: Byte;
    rgbReserved: Byte;
  end;

  PCursorResInfo = ^TCursorResInfo;
  TCursorResInfo = packed record
    wWidth: Word;
    wHeight: Word;
    wPlanes: Word;
    wBitCount: Word;
    lBytesInRes: Cardinal;
    wNameOrdinal: Word;
  end;

  TLocalHeader = packed record
    xHotSpot: Word;
    yHotSpot: Word;
    Reserved: array[0..3] of Word;
  end;

const
  RT_CURSOR = Char(1);
  RT_GROUP_CURSOR = Char(12);

function isCursorFormat(const CursorDir: TCURSORDIR): boolean;
begin
  Result := (CursorDir.cdReserved <> 0) or (* 必ず 0 *)
            (CursorDir.cdType <> 2) or (* Cursorの場合は2 *)
            (CursorDir.cdCount < 1);
end;

function CreateCursorFromStream(Stm: TStream; const Cursor: 
TCustomCursor): QCursorH;
var
  BufCur: TCustomCursor;
  Bitmap: QBitmapH;
  Mask: QBitmapH;
  i, j: integer;
  BitsByte, MaskByte: Byte;
begin
  
  for i := 0 to 4 - 1 do begin
    for j := 32-1 downto 0 do begin
      BitsByte := Cursor.Bits[4*j+i];
      MaskByte := Cursor.Mask[4*j+i];
      BufCur.Bits[4*(32-1-j)+i] := not(BitsByte xor MaskByte);
      BufCur.Mask[4*(32-1-j)+i] := not(BitsByte);
    end;
  end;

  Bitmap := QBitmap_create(32, 32, @BufCur.Bits, False);
  Mask := QBitmap_create(32, 32, @BufCur.Mask, False);

  Result := QCursor_create(Bitmap, Mask,
  Cursor.Hotspot.X, Cursor.Hotspot.Y);
  QBitmap_Destroy(Bitmap);
  QBitmap_Destroy(Mask);
end;

function LoadCursor(Instance: Cardinal; CursorName: PChar): QCursorH;
var
  Stm, ResStm: TResourceStream;
  CursorRes: TCursorResInfo;
  LocalHeader: TLocalHeader;
  CursorDir: TCursorDir;
  Cursor: TCustomCursor;
  BmpInfo: TBITMAPINFOHEADER;
begin
  Result := nil;
  Stm := nil;
  try
    Stm := TResourceStream.Create(Instance, CursorName, 
RT_GROUP_CURSOR);
    
    Stm.ReadBuffer(CursorDir, sizeof(TCursorDir));
    if (isCursorFormat(CursorDir)) then begin
      raise Exception.Create('UnSupport Format');
    end;
    Stm.ReadBuffer(CursorRes, sizeof(TCursorResInfo));
    ResStm := nil;
    try
      ResStm := TResourceStream.CreateFromID(hInstance, 
CursorRes.wNameOrdinal, RT_CURSOR);
      
      ResStm.Read(LocalHeader, sizeof(TLocalHeader));
      with LocalHeader do begin
          Cursor.Hotspot.X := xHotspot;
          Cursor.Hotspot.Y := yHotspot
      end;
      ResStm.Read(BmpInfo, sizeof(TBITMAPINFOHEADER));
      
      if (BmpInfo.biBitCount <> 1) then begin
          raise Exception.Create('UnSupport Format');
      end;
      
      Stm.Seek(2 * Sizeof(TRGBQUAD), soFromCurrent);
      Stm.ReadBuffer(Cursor.Mask, sizeof(Cursor.Mask));
      Stm.ReadBuffer(Cursor.Bits, sizeof(Cursor.BIts));
      
      Result := CreateCursorFromStream(Stm, Cursor);
    finally
      if (Assigned(ResStm)) then ResStm.Free;
    end;
  finally
    if (Assigned(Stm)) then Stm.Free;
  end;
end;

 
function LoadCursorFromFile(FileName: PChar): QCursorH;
var
  Stm: TFileStream;
  CursorDir: TCURSORDIR;
  BmpInfo: TBITMAPINFOHEADER;
  Cursor: TCustomCursor;
begin
  Result := nil;
  Stm := nil;
  try
    Stm := TFileStream.Create(FileName, fmOpenRead);
    
    Stm.ReadBuffer(CursorDir, sizeof(TCursorDir));
    if (isCursorFormat(CursorDir)) then begin
      raise Exception.Create('UnSupport Format');
    end;
    Stm.Seek(CursorDir.cdEntries[0].dwImageOffset, soFromBeginning);
    with CursorDir.cdEntries[0] do begin
        Cursor.Hotspot.X := wXHotspot;
        Cursor.Hotspot.Y := wYHotspot
    end;
    Stm.Read(BmpInfo, sizeof(TBITMAPINFOHEADER));
    
    if (BmpInfo.biBitCount <> 1) then begin
      raise Exception.Create('UnSupport Format');
    end;
    
    Stm.Seek(2 * Sizeof(TRGBQUAD), soFromCurrent);
    
    Stm.ReadBuffer(Cursor.Mask, sizeof(Cursor.Mask));
    Stm.ReadBuffer(Cursor.Bits, sizeof(Cursor.BIts));

    
    Result := CreateCursorFromStream(Stm, Cursor);
  finally
    if (Assigned(Stm)) then Stm.Free;
  end;
end;

end.
--------------------------------------------