unit WinRes;

{ unit WinRes
  Copyright 1993,1999 Matthias K"oppe.

  $Id: winres.pas 1.4 1999/02/09 11:08:20 mkoeppe Exp mkoeppe $
 
  This library is free software; you can redistribute it and/or
  modify it under the terms of the GNU Library General Public
  License as published by the Free Software Foundation; either
  version 2 of the License, or (at your option) any later version.

  This library is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  Library General Public License for more details.

  You should have received a copy of the GNU Library General Public
  License along with this library; if not, write to the Free
  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}

{$ifndef FPK}
{$A+,B-,F-,G+,O+,R-,S-,X+}
{$endif}

interface

{$ifdef FPK}
uses Objects;
{$i fpkdef.pp}
{$PACKRECORDS 1}
{$else}
{$ifdef Windows}
uses WinTypes, Objects;
{$else}
uses Objects;
{$endif}
type
  Sw_Integer = Integer;
{$endif}

type
{$ifdef FPK}
  MakeIntResource = LongInt;
{$else}
  MakeIntResource = PChar;
{$endif}
  
{ Extended DOS stream modes, add to stCreate, stOpenRead, etc.
}
const
  stShareCompat    = $00;
  stShareDenyAll   = $10;
  stShareDenyWrite = $20;
  stShareDenyRead  = $30;
  stShareDenyNone  = $40;
  stNoInheritance  = $80;

{ Predefined Resource Types
}
const
  rt_Cursor       = MakeIntResource(1);
  rt_Bitmap       = MakeIntResource(2);
  rt_Icon         = MakeIntResource(3);
  rt_Menu         = MakeIntResource(4);
  rt_Dialog       = MakeIntResource(5);
  rt_String       = MakeIntResource(6);
  rt_FontDir      = MakeIntResource(7);
  rt_Font         = MakeIntResource(8);
  rt_Accelerator  = MakeIntResource(9);
  rt_RCData       = MakeIntResource(10);
  rt_Group_Cursor = MakeIntResource(12);
  rt_Group_Icon   = MakeIntResource(14);
  rt_TTF_Path     = MakeIntResource(204);

type

{ Old-style EXE header
}
  TExeHeader = record
    Signature: Word;
    LastCount: Word;
    PageCount: Word;
    ReloCount: Word;
    eHdrSize:   Word;
    eMinAbove:  Word;
    eMaxAbove:  Word;
    eInitSS:    Word;
    eInitSP:    Word;
    eCheckSum:  Word;
    eInitPC:    Word;
    eInitCS:    Word;
    eRelocOfs:  Word;
    eOvlyNum:   Word;
    eRelocTab:  Word;
    eSpace:     array[1..30] of Byte;
    eNewHeader: Word;
  end;

{ New-Style EXE header
}
  TWinHeader = record
    Signature: Word;
    LinkerVer: Word;
    EntryOffs: Word;
    EntrySize: Word;
    ReservedA: array[0..3] of Byte;
    LinkerFlags: Word;
    nDataSeg: Word;
    LocalHeapSize: Word;
    StackSize: Word;
    CSIP: pointer;
    SSSP: pointer;
    nSegEntries: Word;
    nModRefEntries: Word;
    nNonResNameBytes: Word;
    SegTbl: Word;			{ offsets from Win header }
    ResourceTbl: Word;
    ResNameTbl: Word;
    ModRefTbl: Word;
    ImpNameTbl: Word;
    NonResNameTbl: LongInt;		{ offset from top }
    nMovableEntryPoints: Word;
    ShiftCount: Word;
    nResourceSegs: Word;
    OS: Byte;
    Extra: Byte;
    ReservedB: array[0..7] of Byte;
  End;

{ Resource information
}
  TNameInfo = record
    rnOffset: Word;			{ in alignment units from top }
    rnLength: Word;			{ in bytes }
    rnFlags: Word;
    rnID: Word;		{ offset from resource table or int value + 8000H }
    rnHandle: Word;
    rnUsage: Word;
  End;

{ Resource type information
}
  TTypeInfo = record
    rtTypeID: Word;	{ offset from resource table or int value + 8000H }
    rtResourceCount: Word;
    rtReserved: array[0..3] of Byte;
{   rtNameInfo: array of TNameInfo;
}  End;

{ Resource table
}
  TResTable = record
    rscAlignShift: Word;
{   rscTypes: array of TTypeInfo;
    rscEndTypes: Word = 0;
    rscResourceNames: array of Char;
    rscEndNames: Byte = 0;
} End;

{ Data structures for font resources ***************************************
}

{ Table entry for raster fonts 2.x
}
  TRasterInfo = record			{ Win 2 fonts }
    dcWidth: Word;
    dcOffset: Word;
  End;

{ Table entry for raster fonts 3.x
}
  TNewRasterInfo = record
    dcWidth: Word;
    dcOffset: LongInt;			{ Win 3 fonts }
  End;

{ Table entry for monospaced vector fonts
}
  TFixedVectorInfo = record
    dcOffset: Word;
  End;

{ Table entry for proportionally spaced vector fonts
}
  TPropVectorInfo = record
    dcOffset: Word;
    dcWidth: Word;
  End;

{ Font resource information
}
  TFontInfo = record
{ Font dir only
}
    dfResID: Word;

{ Always present
}
    dfVersion: Word;
    dfSize: LongInt;
    dfCopyright: array[0..59] of Char;
    dfType: Word;			{ Lowest Bit = 1 -> Vector Font }
    dfPoints: Word;
    dfVertRes: Word;
    dfHorizRes: Word;
    dfAscent: Word;
    dfInternalLeading: Word;
    dfExternalLeading: Word;
    dfItalic: Byte;
    dfUnderline: Byte;
    dfStrikeOut: Byte;
    dfWeight: Word;
    dfCharset: Byte;
    dfPixWidth: Word;			{ 0 if variable-width }
    dfPixHeight: Word;
    dfPitchAndFamily: Byte;		{ Lowest Bit = 1 -> variable pitch }
    dfAvgWidth: Word;
    dfMaxWidth: Word;
    dfFirstChar: Byte;
    dfLastChar: Byte;
    dfDefaultChar: Byte;
    dfBreakChar: Byte;
    dfWidthBytes: Word;
    dfDevice: Word;
    dfReserved2: Word;
    dfFace: Word;
    dfReserved3: Word;
    dfBitsPointer: pointer;
    dfBitsOffset: LongInt;
    dfReserved: Byte;

{ Version 3.x only
}
    dfFlags: Word;
    dfAspace: Word;
    dfBspace: Word;
    dfCspace: Word;
    dfColorPointer: LongInt;
    dfReserved1: Word;

{ Font dir only
}
{   devicename: array of Char;
    facename: array of Char;}

{ Font resource only
}
{   dfCharTable: array of record
      case Integer of
	Raster:	     (dfRasterTbl:      TRasterInfo);
	NewRaster:   (dfNewRasterTbl:   TNewRasterInfo);
	FixedVector: (dfFixedVectorTbl: TFixedVectorInfo);
	PropVector:  (dfPropVectorTbl:  TPropVectorInfo)
    end;
    bitmaps: array of Byte;
    facename: array of Char;
    devicename: array of Char;
}
  End;

const
  FontInfoExtraSize = 14;
  FontInfoBaseSize = SizeOf(TFontInfo) - FontInfoExtraSize;

type

{ Font directory
}
  TFontDir = record
    fdCount: Word;
{   fdDir: array of TFontInfo;
} End;


{ Data structures for menu resources ***************************************
}

const
  mo_TurboVision	= 0;
  mo_GraphicsVision	= 1;
  mo_ColorGroups	= 2;

const
  mf_Grayed 		= 1;
  mf_Disabled		= 2;
  mf_Checked		= 8;
  mf_PopUp		= 16;
  mf_MenuBarBreak	= 32;
  mf_MenuBreak		= 64;
  mf_End		= 128;

type
  TMenuHeader = record
    wVersion: Word;
    wReserved: Word
  End;

  TPopUpMenuItem = record
    fItemFlags: Word;
{   szItemText: array of Char
} End;

  TNormalMenuItem = record
    fItemFlags: Word;
    wMenuID: Word;
{   szItemText: array of Char
} End;

const
{ cmXXXX -> hcXXXX relocation value
}
  HelpCtxDelta: Word = 1000;

{ Application codepage
}
  AnsiCodeState: Boolean = {$ifdef Windows} true {$else} false {$endif};

{ Data structures for accelerator resources ********************************
}

type
  PAccelerator = ^TAccelerator;
  TAccelerator = record
    fFlags: Byte;
    wEvent: Word; {key code}
    wID: Word	  {command code}
  end;

  PAccelerators = ^TAccelerators;
  TAccelerators = record
    Size: Word;
    Acc: array[0..0] of TAccelerator;
  end;

const
  accVirtualKey  = $01;
  accNoHighlight = $02;
  accShift       = $04;
  accCtrl        = $08;
  accAlt         = $10;
  accLast        = $80;

{ Data structures for bitmap resources *************************************
}
{$ifdef FPK}
type
  PImage = pointer;
{$else}
{$ifndef Windows}
type
  TPaletteEntry = record
    peRed: Byte;
    peGreen: Byte;
    peBlue: Byte;
    peFlags: Byte;
  end;

  PLogPalette = ^TLogPalette;
  TLogPalette = record
    palVersion: Word;
    palNumEntries: Word;
    palPalEntry: array[0..0] of TPaletteEntry;
  end;

{ Bitmap header definition }

type
  PBitmap = ^TBitmap;
  TBitmap = record
    bmType: Integer;
    bmWidth: Integer;
    bmHeight: Integer;
    bmWidthBytes: Integer;
    bmPlanes: Byte;
    bmBitsPixel: Byte;
    bmBits: Pointer;
    bmPalette: Pointer;
    bmChunks: Word;
  end;

type
  TRGBTriple = record
    rgbtBlue: Byte;
    rgbtGreen: Byte;
    rgbtRed: Byte;
  end;

type
  TRGBQuad = record
    rgbBlue: Byte;
    rgbGreen: Byte;
    rgbRed: Byte;
    rgbReserved: Byte;
  end;

{ Structures for defining DIBs }

type
  PBitmapCoreHeader = ^TBitmapCoreHeader;
  TBitmapCoreHeader = record
    bcSize: Longint;              { used to get to color table }
    bcWidth: Word;
    bcHeight: Word;
    bcPlanes: Word;
    bcBitCount: Word;
  end;

type
  PBitmapInfoHeader = ^TBitmapInfoHeader;
  TBitmapInfoHeader = record
    biSize: Longint;
    biWidth: Longint;
    biHeight: Longint;
    biPlanes: Word;
    biBitCount: Word;
    biCompression: Longint;
    biSizeImage: Longint;
    biXPelsPerMeter: Longint;
    biYPelsPerMeter: Longint;
    biClrUsed: Longint;
    biClrImportant: Longint;
  end;

{ Constants for the biCompression field }

const
  bi_RGB  = 0;
  bi_RLE8 = 1;
  bi_RLE4 = 2;

type
  PBitmapInfo = ^TBitmapInfo;
  TBitmapInfo = record
    bmiHeader: TBitmapInfoHeader;
    bmiColors: array[0..0] of TRGBQuad;
  end;

type
  PBitmapCoreInfo = ^TBitmapCoreInfo;
  TBitmapCoreInfo = record
    bmciHeader: TBitmapCoreHeader;
    bmciColors: array[0..0] of TRGBTriple;
  end;

type
  PBitmapFileHeader = ^TBitmapFileHeader;
  TBitmapFileHeader = record
    bfType: Word;
    bfSize: Longint;
    bfReserved1: Word;
    bfReserved2: Word;
    bfOffBits: Longint;
  end;

type

{ Extended Image (device-compatible bitmap) Definition
}
  PImage = ^TImage;
  TImage = record
    imSizeXm1: Integer;
    imSizeYm1: Integer;
    case Integer of
    -1: (
      imCount: Word;
      imPtrs: array[0..0] of pointer);
    0: (
      imBitmap: array[0..0] of Byte)
  end;

const
  VirtualBitmapChunkSize: LongInt = 64000;
  PhysicalBitmapChunkSize: LongInt = 64000;
  RLEBitmapChunkSize: LongInt = 16000;
  RLEBitmapOverhang: Integer = 258;

{ Bitmap installable services
}
type
  TBitmapLoadProc = function(var BitmapInfoHeader: TBitmapInfoHeader;
    var S: TStream; Size: LongInt; Palette: pointer;
    CreateImage: Boolean): pointer;
  TBitmapFreeProc = procedure(Bitmap: PBitmap);
  TBitmapStoreProc = procedure(var S: TStream; Bitmap: PBitmap);
  TBitmapAllocProc = function(Bitmap: PBitmap; var Bits: pointer): pointer;

var
  BitmapLoadProc: TBitmapLoadProc;
  BitmapStoreProc: TBitmapStoreProc;
  BitmapFreeProc: TBitmapFreeProc;
  BitmapAllocProc: TBitmapAllocProc;

{ Data structures for icon resources ***************************************
}
type
  PIconDir = ^TIconDir;
  TIconDir = record
    idReserved: Word;
    idType: Word;
    idCount: Word;
    {idEntries: array of TIconDirEntry;}
  end;

  PIconDirEntry = ^TIconDirEntry;
  TIconDirEntry = record
    bWidth: Byte;
    bHeight: Byte;
    bColorCount: Byte;
    bReserved: Byte;
    wPlanes: Word;
    wBitCount: Word;
    dwBytesInRes: LongInt;
    wImageName: Word;
  end;

  PIconImage = ^TIconImage;
  TIconImage = record
    Header: TBitmapInfoHeader;
    {Colors: array of TRGBQuad;
    XORMask: array of byte;
    ANDMask: array of Byte}
  end;

{ Data structures for string resources *************************************
}
type
  PStringBlock = ^TStringBlock;
  TStringBlock = record
    sbIndex: Word;
    sbSize: Word;
    sbNext: PStringBlock;
    sbData: record end
  End;

{ Data structures for cursor resources *************************************
}

type
  PCursorDirEntry = ^TCursorDirEntry;
  TCursorDirEntry = record
    wWidth: Word;
    wHeight: Word;
    wPlanes: Word;
    wBitCount: Word;
    lBytesInRes: LongInt;
    wImageIndex: Word
  end;

  PCursorRes = ^TCursorRes;
  TCursorRes = record
    crHotSpotX: Word;
    crHotSpotY: Word;
    crHeader: TBitmapInfoHeader;
{   crColors: array of TRGBQuad;
    crXOR: array of Byte;
    crAND: array of Byte
} end;

type
  PMyCursor = ^TMyCursor;
  TMyCursor = record
    mcHeight: Word;
    mcWidth: Word;
    mcHotSpotX: Word;
    mcHotSpotY: Word;
    mcAND: array[0..127] of Byte;
    mcXOR: array[0..127] of Byte
  end;

{$else Windows}

type
  PBitmapRef = ^TBitmapRef;
  TBitmapRef = object(TObject)
    Bmp: HBitmap;
    Ref: Integer;
    constructor Init(ABmp: HBitmap);
    destructor Done; virtual;
    procedure IncRef;
    procedure DecRef;
  end;

type
  PImage = ^TImage;
  TImage = record
    Color, BkColor: TColorRef;
    {Bmp: HBitmap}
    BitmapRef: PBitmapRef;
  end;

{$endif !Windows}
{$endif !FPK}

{ Data structures for dialog template resources ***************************
}

{ Window Styles }

const
  ws_Overlapped   = $00000000;
  ws_Popup        = $80000000;
  ws_Child        = $40000000;
  ws_Minimize     = $20000000;
  ws_Visible      = $10000000;
  ws_Disabled     = $08000000;
  ws_ClipSiblings = $04000000;
  ws_ClipChildren = $02000000;
  ws_Maximize     = $01000000;
  ws_Caption      = $00C00000;    { ws_Border + ws_DlgFrame }
  ws_Border       = $00800000;
  ws_DlgFrame     = $00400000;
  ws_VScroll      = $00200000;
  ws_HScroll      = $00100000;
  ws_SysMenu      = $00080000;
  ws_ThickFrame   = $00040000;
  ws_Group        = $00020000;
  ws_TabStop      = $00010000;

const
  ws_MinimizeBox = $00020000;
  ws_MaximizeBox = $00010000;

const
  ws_Tiled   = ws_Overlapped;
  ws_Iconic  = ws_Minimize;
  ws_SizeBox = ws_ThickFrame;

{ Common Window Styles }

const
  ws_OverlappedWindow = ws_Overlapped + ws_Caption + ws_SysMenu +
			ws_ThickFrame + ws_MinimizeBox + ws_MaximizeBox;
  ws_PopupWindow      = ws_Popup + ws_Border + ws_SysMenu;
  ws_ChildWindow      = ws_Child;
  ws_TiledWindow      = ws_OverlappedWindow;

{ Extended Window Styles }

const
  ws_ex_DlgModalFrame  = $00000001;
  ws_ex_NoParentNotify = $00000004;

{ Dialog Box Command IDs }

const
  id_Ok     = 1;
  id_Cancel = 2;
  id_Abort  = 3;
  id_Retry  = 4;
  id_Ignore = 5;
  id_Yes    = 6;
  id_No     = 7;

{ Edit Control Styles }

const
  es_Left        = $0000;
  es_Center      = $0001;
  es_Right       = $0002;
  es_MultiLine   = $0004;
  es_UpperCase   = $0008;
  es_LowerCase   = $0010;
  es_Password    = $0020;
  es_AutoVScroll = $0040;
  es_AutoHScroll = $0080;
  es_NoHideSel   = $0100;
  es_OEMConvert  = $0400;

{ Button Control Styles }

const
  bs_PushButton      = $00;
  bs_DefPushButton   = $01;
  bs_CheckBox        = $02;
  bs_AutoCheckBox    = $03;
  bs_RadioButton     = $04;
  bs_3State          = $05;
  bs_Auto3State      = $06;
  bs_GroupBox        = $07;
  bs_UserButton      = $08;
  bs_AutoRadioButton = $09;
  bs_PushBox         = $0A;
  bs_OwnerDraw       = $0B;
  bs_LeftText        = $20;

{ Static Control Constants }

const
  ss_Left           = $00;
  ss_Center         = $01;
  ss_Right          = $02;
  ss_Icon           = $03;
  ss_BlackRect      = $04;
  ss_GrayRect       = $05;
  ss_WhiteRect      = $06;
  ss_BlackFrame     = $07;
  ss_GrayFrame      = $08;
  ss_WhiteFrame     = $09;
  ss_UserItem       = $0A;
  ss_Simple         = $0B;
  ss_LeftNoWordWrap = $0C;
  ss_NoPrefix       = $80;   { Don't do "&" character translation }

{ Dialog Styles }

const
  ds_AbsAlign   = $01;
  ds_SysModal   = $02;
  ds_LocalEdit  = $20;   { Edit items get Local storage }
  ds_SetFont    = $40;   { User specified font for Dlg controls }
  ds_ModalFrame = $80;   { Can be combined with ws_Caption }
  ds_NoIdleMsg  = $100;  { wm_EnterIdle message will not be sent }

{ Listbox Styles }

const
  lbs_Notify            = $0001;
  lbs_Sort              = $0002;
  lbs_NoRedraw          = $0004;
  lbs_MultipleSel       = $0008;
  lbs_OwnerDrawFixed    = $0010;
  lbs_OwnerDrawVariable = $0020;
  lbs_HasStrings        = $0040;
  lbs_UseTabStops       = $0080;
  lbs_NoIntegralHeight  = $0100;
  lbs_MultiColumn       = $0200;
  lbs_WantKeyboardInput = $0400;
  lbs_ExtendedSel       = $0800;
  lbs_Standard          = lbs_Notify + lbs_Sort + ws_VScroll + ws_Border;

{ Combo Box styles }

const
  cbs_Simple            = $0001;
  cbs_DropDown          = $0002;
  cbs_DropDownList      = $0003;
  cbs_OwnerDrawFixed    = $0010;
  cbs_OwnerDrawVariable = $0020;
  cbs_AutoHScroll       = $0040;
  cbs_OEMConvert        = $0080;
  cbs_Sort              = $0100;
  cbs_HasStrings        = $0200;
  cbs_NoIntegralHeight  = $0400;

{ Scroll Bar Styles }

const
  sbs_Horz                    = $0000;
  sbs_Vert                    = $0001;
  sbs_TopAlign                = $0002;
  sbs_LeftAlign               = $0002;
  sbs_BottomAlign             = $0004;
  sbs_RightAlign              = $0004;
  sbs_SizeBoxTopLeftAlign     = $0002;
  sbs_SizeBoxBottomRightAlign = $0004;
  sbs_SizeBox                 = $0008;

{ Dialog box template resource }

type
  PDialogBoxHeader = ^TDialogBoxHeader;
  TDialogBoxHeader = record
    lStyle: LongInt;
    bNumberOfItems: Byte;
    x: Integer;
    y: Integer;
    cx: Integer;
    cy: Integer;
    szMenuName: PChar;
    szClassName: PChar;
    szCaption: PChar;
    wPointSize: Word;
    szFaceName: PChar
  end;

  PControlData = ^TControlData;
  TControlData = record
    x: Integer;
    y: Integer;
    cx: Integer;
    cy: Integer;
    wID: Word;
    lStyle: LongInt;
    szClass: PChar;
    szText: PChar;
    bExtraSize: Byte;
    bExtra: array[0..255] of Byte
  end;

{ Dialog/control class definition }

type
{$ifdef FPK}
  MakeIntClass = LongInt;
{$else}
  MakeIntClass = PChar;
{$endif}

const
  cl_Button    = MakeIntClass($80);
  cl_Edit      = MakeIntClass($81);
  cl_Static    = MakeIntClass($82);
  cl_ListBox   = MakeIntClass($83);
  cl_ScrollBar = MakeIntClass($84);
  cl_ComboBox  = MakeIntClass($85);

type
  PLinkRec = ^TLinkRec;
  TLinkRec = record
    Next: PLinkRec;
    proc: pointer; { TLinkProc }
    control: pointer
  end;

  PDialogInfo = ^TDialogInfo;
  TDialogInfo = record
    Resource: PStream;
    ResTblPos: LongInt;
    Base: record x, y: Real end;
    Move: TPoint;
    Grow: TPoint;
    Font: Word;
    Links: PLinkRec;
    Group: Boolean;
    Dialog: pointer;
    Wake: pointer;  { TWakeProc }
  end;

const
  { Class TypeId constants
  }
  ctDialog = 0;

type
  PClassRec = ^TClassRec;
  TClassRec = record
    ClassId: PChar;
    Init: pointer;  { TInitProc }
    TypeId: Word;
  end;

  TInitProc = procedure(Data: pointer; Info: PDialogInfo);
  TLinkProc = procedure(link, control: pointer);
  TWakeProc = procedure(Info: PDialogInfo);

{ Data structures for BGI and CPI files **********************************
}
{$ifndef Windows}
{$ifndef FPK}
  { BGI stroked font information
}
type
  TBgiFontInfo = record
    biRes1: Byte;
    biCharCount: Byte;
    biRes2: Byte;
    biRes3: Byte;
    biFirstChar: Byte;
    biVectorOffset: Word;
    biRes4: Byte;
    biPixHeight: Byte;
    biRes5: array[0..6] of Byte;
  { biOffsets: array of Word;
    biWidths: array of Byte }
  End;

{ CPI file header
}
type
  TCpiFileHeader = record
    cfhSign1: LongInt;
    cfhSign2: LongInt;
    cfhReserved: array[0..16] of Byte
  end;

{ CPI device/codepage header
}
type
  TCpiDevCpHeader = record
    cdchRes1: Word;
    cdchNext: LongInt;
    cdchRes2: Word;
    cdchDevice: array[0..7] of Char;
    cdchCodePage: Word;
    cdchRes3: array[0..11] of Byte;
    cdchCount: Word;
    cdchRes4: Word
  end;

{ CPI font header
}
type
  TCpiFontHeader = record
    cfhHeight: Byte;
    cfhWidth: Byte;
    cfhRes1: Word;
    cfhRes2: Word
  end;
{$endif FPK}
{$endif Windows}

{ Object types *************************************************************
}

type
{ Resource name collection, allowing integer and string names
}
  PNameCollection = ^TNameCollection;
  TNameCollection = object(TStringCollection)
    function Compare(Key1, Key2: pointer): Sw_Integer; virtual;
    procedure FreeItem(Item: pointer); virtual;
  end;

{$ifdef Windows}
  PResObj = pointer;
  PResType = pointer;
  PResName = pointer;

  PResStream = ^TResStream;
  TResStream = object(TStream)
    Instance: THandle;
    Resource: THandle;
    ResourcePtr: PChar;
    Offset: Word;
    constructor Init(AnInstance: THandle);
    destructor Done; virtual;
    function GetPos: LongInt; virtual;
    procedure Read(var Buf; Count: Word); virtual;
    procedure Seek(Pos: LongInt); virtual;
    function ToResource(Name, ResType: PChar): LongInt;
  end;
{$else}
{$ifdef ver60}
  PResStream = PStream;
  PResObj = pointer;
  PResType = pointer;
  PResName = pointer;
{$else}
{ Generic resource object
}
  PResObj = ^TResObj;
  TResObj = object(TObject)
    ID: PChar;
    constructor Init(AnID: PChar);
    destructor Done; virtual;
  end;

{ A sorted collection of resource objects
}
  PResObjCollection = ^TResObjCollection;
  TResObjCollection = object(TStringCollection)
    function Compare(Key1, Key2: pointer): Sw_Integer; virtual;
    procedure FreeItem(Item: pointer); virtual;
  end;

{ Specialized stream, keeping a collection of resources
}
type
  PResType = ^TResType;

  PResStream = ^TResStream;
  TResStream = object(TBufStream)
    Types: PResObjCollection;
    TablePos: LongInt;
    AlignShift: Word;
    constructor Init(FileName: FNameStr; Mode, Size: Word);
    destructor Done; virtual;
    function LookupType(ResType: PChar): PResType;
    function ToResource(Name, ResType: PChar): LongInt;
  end;

{ A resource name entry
}
  PResName = ^TResName;
  TResName = object(TResObj)
    Pos: LongInt;
    Len: LongInt;
    constructor Load(var S: TResStream);
  end;

{ A resource type entry
}
  TResType = object(TResObj)
    Info: TTypeInfo;
    NamePos: LongInt;
    Names: PResObjCollection;
    constructor Load(var S: TResStream);
    destructor Done; virtual;
    function GetNames(var S: TResStream): PResObjCollection;
  end;
{$endif ver60}
{$endif Windows}

{ Procedures and functions *************************************************
}

function OpenResource(Path: string): PResStream;

{$ifndef Windows}
function OpenRawResource(Path: string): PStream;
function SkipStub(var S: TStream): Boolean;
function SkipToResTbl(var S: TStream): Boolean;
function SkipToResource(var S: TStream; Name, ResType: PChar): Boolean;
function SkipToResourceS(var S: TStream; Name, ResType: PChar): LongInt;

function ListResourceNames(var S: TStream; ResType: PChar): PNameCollection;

{$ifndef FPK}
procedure ReadFontInfo(var S: TStream; var FontInfo: TFontInfo;
  FontDir: Boolean);
procedure ReadFontInfoExt(var S: TStream; var FontInfo: TFontInfo;
  FontDir: Boolean; DeviceName, FaceName: PString);
procedure ReadStrZ(var S: TStream; str: PString);

function MakeCompoundImage(Count: Integer; var ImagePtrs): PImage;
function LoadCursor(var S: TStream; CursorName: PChar): PMyCursor;
{$endif}
{$endif Windows}

{$ifndef FPK}
function LoadBitmap(var S: TStream; BitmapName: PChar): PBitmap;
function LoadBitmapFile(var S: TStream): PBitmap;
procedure DeleteBitmap(Bitmap: PBitmap);
procedure StoreBitmapFile(var S: TStream; Bitmap: PBitmap);
procedure LoadIcon(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorBitmap, AndBitmap: PBitmap);
{$endif}
function LoadBitmapImg(var S: TStream; BitmapName: PChar): pointer;
function LoadBitmapFileImg(var S: TStream): pointer;
procedure LoadIconImg(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorImage, AndImage: pointer);

{$ifndef Windows}
{$ifndef FPK}
function LoadStringBlock(var S: TStream; Index: Word): PStringBlock;
function NullStringBlock(Index: Word): PStringBlock;
procedure FreeStringBlock(Block: PStringBlock);
function GetStringFromBlock(Block: PStringBlock; Index: Word): PString;
{$endif !FPK}
{$endif !Windows}

function LoadString(var S: TStream; Index: Word): string;

function LoadAccelerators(var S: TStream; Name: PChar): PAccelerators;
procedure FreeAccelerators(Accelerators: PAccelerators);
function LookupAccelerator(Accelerators: PAccelerators;
  Command: Word): Word;

procedure SetHelpCtxDelta(ADelta: Word);
function AnsiCode: Boolean;
procedure SetAnsiCode(on_: Boolean);
procedure AnsiFrom437(Buf: PChar);
procedure AnsiFrom437Str(Str: PString);
procedure AnsiTo437(Buf: PChar);
procedure AnsiTo437Str(Str: PString); 

{$IFNDEF VER60}
function LoadMenu(var S: TStream; MenuName: PChar; Options: Word): pointer;

procedure InitClasses;
procedure RegisterClass(var ClassRec: TClassRec);
function GetClass(ClassName: PChar; ClassTypeId: Integer): PClassRec;
procedure DoneClasses;

function LoadDialog(var S: TStream; DialogName: PChar): pointer;
procedure InsertLink(Info: PDialogInfo; AProc: pointer; AControl: pointer);
procedure CreateLinks(Info: PDialogInfo; Link: pointer);

function ConvertMarkers(Buf: PChar; Max: Word): Boolean;
{$ENDIF}

{$ifndef Windows}
{$ifndef FPK}
procedure FreeMemAlign(var P: Pointer; Size: Word; PtrUp, SizeUp: Boolean);
{$endif}
{$endif Windows}

implementation

{$ifdef FPK}
uses Dos, Drivers, Strings, Memory, Bitmaps, Bmp, Bgi;
{$else}
{$ifdef Windows}
uses WinProcs, Dos, Drivers, OMemory, Strings, Bitmap;
{$else}
uses Dos, Drivers, Memory
{$ifndef VER60}
, Strings
{$endif}
;
{$endif !Windows}
{$endif !FPK}

{$ifdef VER60}

{ From Strings.pas, Borland Pascal 7.0 Runtime Library,
  Copyright (c) Borland International Inc. 1992
}
function StrIComp(Str1, Str2: PChar): Integer; assembler;
asm
	PUSH	DS
	CLD
	LES	DI,Str2
	MOV	SI,DI
	MOV	CX,0FFFFH
	XOR	AX,AX
	CWD
	REPNE	SCASB
	NOT	CX
	MOV	DI,SI
	LDS	SI,Str1
@@1:	REPE	CMPSB
	JE	@@4
	MOV	AL,DS:[SI-1]
	CMP	AL,'a'
	JB	@@2
	CMP	AL,'z'
	JA	@@2
	SUB	AL,20H
@@2:	MOV	DL,ES:[DI-1]
	CMP	DL,'a'
	JB	@@3
	CMP	DL,'z'
	JA	@@3
	SUB	DL,20H
@@3:	SUB	AX,DX
	JE	@@1
@@4:	POP	DS
end;
{$endif VER60}

{$ifndef Windows}
procedure FreeMemAlign(var P: Pointer; Size: Word; PtrUp, SizeUp: Boolean);
  {$IFDEF MSDOS}
var
  n: Word;
Begin
  with PtrRec(P) do Begin
    If PtrUp
    then n := (Ofs + 7) and $FFF8
    else n := Ofs and $FFF8;
    Inc(Size, Ofs - n);
    If not SizeUp then Size := Size and $FFF8;
    Ofs := n;
    Inc(Seg, Ofs shr 4);
    Ofs := Ofs and $8
  End;
  {$ELSE}
Begin
  {$ENDIF}
  FreeMem(P, Size);
End;

{ Internal structure
}
type
  TResInt = record
    riAlignShift: Word;
    riTablePos: LongInt;
    riStream: PStream;
  end;

function SkipStub(var S: TStream): Boolean;
var
  ExeHeader: TExeHeader;
begin
  SkipStub := false;
  If S.GetPos > S.GetSize - SizeOf(TExeHeader) then Exit;
  S.Read(ExeHeader, SizeOf(TExeHeader));
  If (ExeHeader.Signature <> $5A4D) or (ExeHeader.eRelocOfs < $40) then Exit;
  S.Seek(ExeHeader.eNewHeader);
  SkipStub := S.Status = 0
End;

function SkipToResTbl(var S: TStream): Boolean;
var
  WinHeader: TWinHeader;
  HeaderPos: LongInt;
begin
  SkipToResTbl := false;
  HeaderPos := S.GetPos;
  If HeaderPos > S.GetSize - SizeOf(TWinHeader) then Exit;
  S.Read(WinHeader, SizeOf(TWinHeader));
  If WinHeader.Signature <> $454E then Exit;
  S.Seek(HeaderPos + WinHeader.ResourceTbl);
  SkipToResTbl := S.Status = 0
End;

function CompareStrings(Key: PChar; Offset: Word; var ResInt: TResInt): Boolean;
var
  P: LongInt;
  c: array[0..255] of Char;
  l: Byte;
Begin
  CompareStrings := false;
  with ResInt.riStream^ do Begin
    P := GetPos;
    Seek(ResInt.riTablePos + Offset);
    Read(l, 1);
    Read(c, l);
    Seek(P);
  End;
  c[l] := #0;
  CompareStrings := StrIComp(Key, @c) = 0;
End;

function Compare(Key: PChar; ID: Word; var ResInt: TResInt): Boolean;
Begin
  If LongRec(Key).Hi = 0
    then if ID < $8000
      then Compare := false
      else Compare := LongRec(Key).Lo = ID and $7FFF
    else if ID < $8000
      then Compare := CompareStrings(Key, ID, ResInt)
      else Compare := false
End;

function ReadNameStr(Offset: Word; var ResInt: TResInt): PString;
var
  P: LongInt;
  l: Byte;
  t: PString;
Begin
  with ResInt.riStream^ do Begin
    P := GetPos;
    Seek(ResInt.riTablePos + Offset);
    Read(l, 1);
    GetMem(t, l + 1);
    t^[0] := Chr(l);
    Read(t^[1], l);
    Seek(P)
  End;
  ReadNameStr := t
End;

{ This procedure fills the ResInt structure. }

function SkipToResType(var S: TStream; ResType: PChar;
  var ResInt: TResInt): Word;
var
  TypeInfo: TTypeInfo;
Begin
  SkipToResType := 0;
  ResInt.riTablePos := S.GetPos;
  S.Read(ResInt.riAlignShift, SizeOf(TResTable));
  ResInt.riStream := @S;
  Repeat
    S.Read(TypeInfo, SizeOf(TTypeInfo));
    If TypeInfo.rtTypeID = 0 then Exit else
    if Compare(ResType, TypeInfo.rtTypeID, ResInt) then Begin
      SkipToResType := TypeInfo.rtResourceCount;
      Exit
    End else
      S.Seek(S.GetPos + TypeInfo.rtResourceCount * SizeOf(TNameInfo))
  Until false
End;

{ New-style resource handling 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}
{$IFNDEF VER60}
function ReadID(var S: TResStream; ID: Word): PChar;
var
  P: LongInt;
  c: PChar;
  l: Byte;
Begin
  If ID >= $8000
  then ReadID := PChar(LongInt(ID and $7FFF)) else
  with S do
  begin
    P := GetPos;
    Seek(TablePos + ID);
    Read(l, 1);
    GetMem(c, Integer(l) + 1);
    Read(c^, l);
    c[l] := #0;
    ReadID := c;
    Seek(P);
  end
end;

procedure DisposeID(ID: PChar);
begin
  If Seg(ID^) <> 0
  then StrDispose(ID)
end;

function CompareID(ID1, ID2: PChar): Integer;
begin
  If (Seg(ID1^) = 0) or (Seg(ID2^) = 0) then
    if LongInt(ID1) > LongInt(ID2)
    then CompareID := +1 else
    if LongInt(ID1) < LongInt(ID2)
    then CompareID := -1 else CompareID := 0
  else CompareID := StrIComp(ID1, ID2)
end;

{ TResObj 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

constructor TResObj.Init(AnID: PChar);
begin
  inherited Init;
  ID := AnID
end;

destructor TResObj.Done;
begin
  DisposeID(ID);
  inherited Done
end;

{ TResObjCollection 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

function TResObjCollection.Compare(Key1, Key2: pointer): Sw_Integer;
begin
  Compare := CompareID(PResObj(Key1)^.ID, PResObj(Key2)^.ID)
end;

procedure TResObjCollection.FreeItem(Item: pointer);
begin
  Dispose(PObject(Item), Done)
end;

{ TResName 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

constructor TResName.Load(var S: TResStream);
var
  Info: TNameInfo;
begin
  inherited Init(nil);
  S.Read(Info, SizeOf(Info));
  ID := ReadID(S, Info.rnID);
  Pos := LongInt(Info.rnOffset) shl S.AlignShift;
  Len := Info.rnLength shl S.AlignShift
end;

{ TResType 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

constructor TResType.Load(var S: TResStream);
begin
  inherited Init(nil);
  S.Read(Info, SizeOf(Info));
  If Info.rtTypeID = 0 then Fail;
  NamePos := S.GetPos;
  ID := ReadID(S, Info.rtTypeID);
  S.Seek(NamePos + Info.rtResourceCount * SizeOf(TNameInfo))
end;

destructor TResType.Done;
begin
  If Names <> nil then Dispose(Names, Done);
  inherited Done
end;

function TResType.GetNames(var S: TResStream): PResObjCollection;
var
  i: Integer;
begin
  If Names = nil
  then begin
    Names := New(PResObjCollection, Init(Info.rtResourceCount, 8));
    S.Seek(NamePos);
    For i := 1 to Info.rtResourceCount do
      Names^.Insert(New(PResName, Load(S)));
  end;
  GetNames := Names
end;

{ TResStream 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

constructor TResStream.Init(FileName: FNameStr; Mode, Size: Word);
var
  P: PResObj;
begin
  inherited Init(FileName, Mode, Size);
  If SkipStub(Self) and SkipToResTbl(Self)
  then begin
    TablePos := GetPos;
    Read(AlignShift, SizeOf(TResTable));
    Types := New(PResObjCollection, Init(8, 8));
    Repeat
      P := New(PResType, Load(Self));
      If P <> nil then Types^.Insert(P)
    Until P = nil;
    Seek(TablePos)
  end
  else
    Error(stInitError, 0);
end;

destructor TResStream.Done;
begin
  If Types <> nil
  then Dispose(Types, Done);
  inherited Done
end;

function TResStream.LookupType(ResType: PChar): PResType;
var
  TypeKey: TResType;
  Index: Sw_Integer;
begin
  LookUpType := nil;
  If Types <> nil
  then begin
    TypeKey.Init(ResType);
    If Types^.Search(@TypeKey, Index) then
      LookUpType := Types^.At(Index)
  end
end;

function TResStream.ToResource(Name, ResType: PChar): LongInt;
var
  TypeObj: PResType;
  NameKey: TResName;
  NameObj: PResName;
  Index: Sw_Integer;
begin
  ToResource := 0;
  TypeObj := LookupType(ResType);
  If TypeObj <> nil then
  with TypeObj^ do
    with GetNames(Self)^ do
      If Count > 0
      then begin
	If Name = nil
	then NameObj := At(0)
	else begin
	  NameKey.Init(Name);
	  If Search(@NameKey, Index)
	  then NameObj := At(Index)
	  else NameObj := nil
	end;
	If NameObj <> nil then
	with NameObj^ do
	begin
	  Seek(Pos);
	  ToResource := Len
	end
      end
end;

function IsResStream(var S: TStream): Boolean;
begin
  IsResStream := TypeOf(S) = TypeOf(TResStream)
end;

{$ENDIF !VER60}

{$else Windows}

constructor TResStream.Init(AnInstance: THandle);
begin
  inherited Init;
  if AnInstance < 32 { Error condition }
  then begin
    Error(stInitError, AnInstance);
    Instance := 0
  end
  else
    Instance := AnInstance;
end;

destructor TResStream.Done;
begin
  Seek(0);
  if (Instance <> HInstance) and (Instance >= 32)
  then FreeLibrary(Instance);
  inherited Done
end;

function TResStream.GetPos: LongInt;
var
  Res: LongRec;
begin
  Res.Hi := Resource;
  Res.Lo := Offset;
  GetPos := LongInt(Res)
end;

procedure TResStream.Read(var Buf; Count: Word);
begin
  Move((ResourcePtr + Offset)^, Buf, Count);
  Inc(Offset, Count)
end;

function TResStream.ToResource(Name, ResType: PChar): LongInt;
var
  ResInfo: THandle;
  Pos: LongInt;
begin
  ResInfo := FindResource(Instance, Name, ResType);
  ToResource := SizeOfResource(Instance, ResInfo);
  LongRec(Pos).Hi := LoadResource(Instance, ResInfo);
  LongRec(Pos).Lo := 0;
  TResStream.Seek(Pos);
end;

procedure TResStream.Seek(Pos: LongInt);
begin
  If LongRec(Pos).Hi <> Resource
  then begin
    UnlockResource(Resource);
    If LongRec(Pos).Hi = 0
    then begin
      ResourcePtr := nil;
      FreeResource(Resource)
    end
    else
      ResourcePtr := LockResource(LongRec(Pos).Hi);
    Resource := LongRec(Pos).Hi;
  end;
  Offset := LongRec(Pos).Lo;
end;

function IsResStream(var S: TStream): Boolean;
begin
  IsResStream := TypeOf(S) = TypeOf(TResStream)
end;

{$endif Windows}

{ Resource access 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

function SkipToResourceS(var S: TStream; Name, ResType: PChar): LongInt;
{$ifndef Windows}
var
  NameInfo: TNameInfo;
  ResInt: TResInt;
  i: Word;
{$endif Windows}
begin
  {$ifndef ver60}
  If IsResStream(S)
  then SkipToResourceS := PResStream(@S)^.ToResource(Name, ResType)
  else
  {$endif ver60}
  {$ifndef Windows}
       begin
    SkipToResourceS := 0;
    For i := 1 to SkipToResType(S, ResType, ResInt) do Begin
      S.Read(NameInfo, SizeOf(TNameInfo));
      If (Name = nil) or Compare(Name, NameInfo.rnID, ResInt) then Begin
	S.Seek(LongInt(NameInfo.rnOffset) shl ResInt.riAlignShift);
	{ Size is given in alignment units, not in bytes, as the
	  documentation erroneously states. }
	SkipToResourceS := NameInfo.rnLength shl ResInt.riAlignShift;
	Exit
      End;
    End;
  end
  {$endif Windows}
End;

function SkipToResource(var S: TStream; Name, ResType: PChar): Boolean;
Begin
  SkipToResource := SkipToResourceS(S, Name, ResType) <> 0
End;

function ListResourceNames(var S: TStream; ResType: PChar): PNameCollection;
{$ifndef Windows}
var
  coll: PNameCollection;
  NameInfo: TNameInfo;
  ResInt: TResInt;
  i, count: Word;
  n: LongInt;
  TypeObj: PResType;

	{$ifndef ver60}
	procedure Ins(Name: PResName); {$ifndef FPK}far;{$endif}
	begin
	  with Name^ do
	    If Seg(ID^) = 0
	    then coll^.Insert(pointer(LongInt(ID)))
	    else coll^.Insert(NewStr(StrPas(ID)))
	end;
	{$endif}
{$endif Windows}

Begin
  ListResourceNames := nil;
  {$ifndef Windows}
  {$ifndef ver60}
  If IsResStream(S)
  then begin
    TypeObj := PResStream(@S)^.LookupType(ResType);
    If TypeObj <> nil
    then begin
      coll := New(PNameCollection, Init(count, 8));
      TypeObj^.GetNames(PResStream(@S)^)^.ForEach(@Ins)
    end
  end
  else
  {$endif ver60}
       begin
    count := SkipToResType(S, ResType, ResInt);
    If count = 0 then Exit;
    coll := New(PNameCollection, Init(count, 8));
    For i := 1 to count do Begin
      S.Read(NameInfo, SizeOf(TNameInfo));
      If NameInfo.rnID < $8000
      then coll^.Insert(ReadNameStr(NameInfo.rnID, ResInt))
      else Begin
	n := NameInfo.rnID and $7FFF;
	coll^.Insert(pointer(n))
      End
    End;
  end;
  ListResourceNames := coll
  {$endif Windows}
End;

{ High-level open-resource 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

{$ifndef Windows}
function OpenRawResource(Path: string): PStream;
var
  S: PStream;
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
begin
  If Path = ''
  then Path := ParamStr(0)
  else begin
    FSplit(ParamStr(0), Dir, Name, Ext);
    Path := FSearch(Path, Dir + ';' + GetEnv('PATH'));
  end;
  S := New(PBufStream, Init(Path, stOpenRead or stShareDenyNone, 2048));
  SkipStub(S^);
  SkipToResTbl(S^);
  OpenRawResource := S
end;
{$endif}

function OpenResource(Path: string): PResStream;
var
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
begin
{$ifdef Windows}
  if Path = ''
  then OpenResource := New(PResStream, Init(HInstance))
  else begin
    FSplit(ParamStr(0), Dir, Name, Ext);
    Path := FSearch(Path, Dir + ';' + GetEnv('PATH')) + #0;
    OpenResource := New(PResStream, Init(LoadLibrary(@Path[1])));
  end;
{$else}
{$ifdef ver60}
  OpenResource := OpenRawResource(Path);
{$else}
  If Path = ''
  then Path := ParamStr(0)
  else begin
    FSplit(ParamStr(0), Dir, Name, Ext);
    Path := FSearch(Path, Dir + ';' + GetEnv('PATH'));
  end;
  OpenResource := New(PResStream, Init(Path, stOpenRead or stShareDenyNone, 2048));
{$endif ver60}
{$endif Windows}
end;

{ TNameCollection object 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

function TNameCollection.Compare(Key1, Key2: pointer): Sw_Integer;
Begin
  If (Seg(Key1^) = 0) or (Seg(Key2^) = 0) then
    if LongInt(Key1) > LongInt(Key2) then Compare := +1 else
    if LongInt(Key1) < LongInt(Key2) then Compare := -1 else Compare := 0
  else Compare := TStringCollection.Compare(Key1, Key2)
End;

procedure TNameCollection.FreeItem(Item: pointer);
Begin
  If Seg(Item^) <> 0 then TStringCollection.FreeItem(Item)
End;

{ Font routines 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}
{$ifndef FPK}
{$ifndef Windows}
procedure ReadFontInfo(var S: TStream; var FontInfo: TFontInfo;
  FontDir: Boolean);
begin
  ReadFontInfoExt(S, FontInfo, FontDir, nil, nil)
end;

procedure ReadStrZ(var S: TStream; str: PString);
{ bwah }
var
  C: Char;
begin
  if str <> nil then str^ := '';
  Repeat
    S.Read(C, 1);
    If (C <> #0) and (str <> nil)
    then str^ := str^ + C;
  until C = #0;
end;

procedure ReadFontInfoExt(var S: TStream; var FontInfo: TFontInfo;
  FontDir: Boolean; DeviceName, FaceName: PString);
Begin
  FillChar(FontInfo, SizeOf(TFontInfo), 0);
  If FontDir
    then S.Read(FontInfo, FontInfoBaseSize - 5)
    else Begin
      FontInfo.dfResID:=0;
      S.Read(FontInfo.dfVersion, FontInfoBaseSize - 3);
      case FontInfo.dfVersion of
	$200:
	  S.Read(FontInfo.dfReserved, 1);
	$300:
	Begin
	  S.Read(FontInfo.dfReserved, 1);
	  S.Read(FontInfo.dfFlags, FontInfoExtraSize);
	  S.Seek(S.GetPos + 16)
	End;
      End;
    End;
  If FontDir then Begin
    ReadStrZ(S, DeviceName);
    ReadStrZ(S, FaceName);
  End
End;

{ Cursor routines 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

procedure ConvertMask(var Source; var Dest); assembler;
asm
	push	ds
	lds	si, Source
	les	di, Dest
	cld
	mov	cx, 32
	add	di, 64
@@1:    sub	di, 2
	lodsw
	xchg	ah, al
	mov	es:[di], ax
	lodsw
	xchg	ah, al
	mov	es:[di].64, ax
	loop	@@1
	pop	ds
end;

function LoadCursor(var S: TStream; CursorName: PChar): PMyCursor;
var
  p: LongInt;
  c: PMyCursor;
  CursorRes: TCursorRes;
  Mask: array[0..127] of Byte;
Begin
  p := S.GetPos;
  c := nil;
  If SkipToResource(S, CursorName, PChar(rt_Cursor)) then Begin
    S.Read(CursorRes, SizeOf(TCursorRes));
    New(c);
    with c^ do
    with CursorRes do Begin
      mcHotSpotX := crHotSpotX;
      mcHotSpotY := crHotSpotY;
      with crHeader do Begin
	mcHeight := 32 {biHeight div 2};
	mcWidth := 4 {biHeight div 8};
	S.Seek(S.GetPos + 1 shl biBitCount * SizeOf(TRGBQuad))
      End;
      S.Read(Mask, 128);
      ConvertMask(mask, mcXOR);
      S.Read(Mask, 128);
      ConvertMask(mask, mcAND)
    End
  End;
  S.Seek(p);
  LoadCursor := c
End;

{ Bitmap routines 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

function MakeCompoundImage(Count: Integer; var ImagePtrs): PImage;
var
  Image: PImage;
  Size: TPoint;
  i: Integer;
  p: pointer;
begin
  GetMem(Image, SizeOf(TImage) + (Count - 1) * SizeOf(pointer));
  with Image^ do
  begin
    imSizeXm1 := -1;
    imSizeYm1 := -1;
    Size.X := 0; Size.Y := 0;
    p := @ImagePtrs;
    imCount := Count;
    Move(ImagePtrs, imPtrs, Count * SizeOf(pointer));
  end;
  MakeCompoundImage := Image
end;

{ Free Bitmap
}

procedure StdBitmapFree(Bitmap: PBitmap); {$ifndef FPK}far;{$endif}
var
  p: pointer;
  i: Integer;
Begin
  with Bitmap^ do
    If bmChunks = 0
    then FreeMemAlign(bmBits, abs(bmHeight) * bmWidthBytes * bmPlanes, false, true)
    else begin
      P := bmBits;
      For i := 1 to bmChunks do
      begin
	DeleteBitmap(PBitmap(P^));
	Inc(PtrRec(P).Ofs, SizeOf(pointer))
      end;
      FreeMem(bmBits, bmChunks * SizeOf(pointer))
    end
End;

procedure DeleteBitmap(Bitmap: PBitmap); {public}
begin
  If Bitmap <> nil
  then begin
    with Bitmap^ do
    begin
      If bmBits <> nil then
	BitmapFreeProc(Bitmap);
      If bmPalette <> nil then
	FreeMem(bmPalette, SizeOf(TRGBQuad) shl (bmBitsPixel * bmPlanes));
    end;
    Dispose(Bitmap)
  end
end;

{ Load Bitmap
}

{$L wrespal.obj (wrespal.asm) }
procedure TripleToQuad(var Triple, Quad; Count: Word); near; external;

{$L wresrle.obj (wresrle.asm) }
function DecodeRLE4(Buffer: pointer; Bitmap: PBitmap): LongInt; near; external;
function DecodeRLE8(Buffer: pointer; Bitmap: PBitmap): LongInt; near; external;

function PaletteLoad(var BitmapInfoHeader: TBitmapInfoHeader;
  var S: TStream): pointer; near;
var
  palsize, tempsize: Word;
  pal, temp: pointer;
Begin
  with BitmapInfoHeader do Begin
    If biBitCount = 24
    then begin
      If biSize = SizeOf(TBitmapCoreHeader)
      then palSize := SizeOf(TRGBTriple)
      else palSize := SizeOf(TRGBQuad);
      S.Seek(S.GetPos + palSize * biClrUsed);
      pal := nil
    end
    else begin
      palsize := SizeOf(TRGBQuad) shl biBitCount;
      GetMem(pal, palsize);
      If biSize = SizeOf(TBitmapCoreHeader)
      then begin
	tempsize := SizeOf(TRGBTriple) shl biBitCount;
	GetMem(temp, tempsize);
	S.Read(temp^, tempsize);
	TripleToQuad(temp^, pal^, 1 shl biBitCount);
	FreeMem(temp, tempsize)
      end
      else begin
	If biClrUsed <> 0
	then begin
	  tempSize := SizeOf(TRGBQuad) * biClrUsed;
	  If tempSize < palSize
	  then palSize := tempSize
	end;
	S.Read(pal^, palsize)
      end
    end
  End;
  PaletteLoad := pal
End;

function PaletteCopy(var BitmapInfoHeader: TBitmapInfoHeader;
  Palette: pointer): pointer;
var
  pal: pointer;
  palSize: Word;
begin
  with BitmapInfoHeader do
    If Palette = nil
    then PaletteCopy := nil
    else begin
      palSize := SizeOf(TRGBQuad) shl biBitCount;
      GetMem(pal, palSize);
      Move(Palette^, pal^, palSize);
      PaletteCopy := pal
    end
end;

function StdBitmapAlloc(Bitmap: PBitmap; var Bits: pointer): pointer; {$ifndef FPK}far;{$endif}
begin
  with Bitmap^ do
    Bits := MemAlloc(abs(bmHeight) * bmWidthBytes * bmPlanes);
  StdBitmapAlloc := nil
end;

function StdBitmapLoad(var BitmapInfoHeader: TBitmapInfoHeader;
  var S: TStream; Size: LongInt; Palette: pointer;
  CreateImage: Boolean): pointer; {$ifndef FPK}far;{$endif}
var
  Bitmap: PBitmap;
  Pos, P, L: LongInt;
  RLEBuffer: pointer;
Begin
  with BitmapInfoHeader do
  If not CreateImage
  then Begin
    New(Bitmap);
    FillChar(Bitmap^, SizeOf(TBitmap), 0);
    with Bitmap^ do Begin
      bmWidth := biWidth;
      bmHeight := - biHeight;
      bmPlanes := biPlanes;
      bmBitsPixel := biBitCount div biPlanes;
      bmWidthBytes := ((bmWidth * bmBitsPixel + 31) shr 3) and $FFFC;
      bmPalette := Palette;
      StdBitmapAlloc(Bitmap, bmBits);
      If bmBits = nil
      then begin
	Dispose(Bitmap);
	Bitmap := nil
      end
      else begin
	case biCompression of
	  bi_RGB:
	    S.Read(bmBits^, abs(bmHeight) * bmWidthBytes * bmPlanes);
	  bi_RLE4, bi_RLE8:
	    begin
	      RLEBuffer := MemAlloc(RLEBitmapChunkSize + RLEBitmapOverhang);
	      If RLEBuffer = nil
	      then begin
		DeleteBitmap(Bitmap);
		Bitmap := nil;
	      end
	      else begin
		Pos := S.GetPos;
		Size := S.GetSize;
		repeat
		  L := RLEBitmapChunkSize + RLEBitmapOverhang;
		  If L >= Size - Pos
		  then L := Size - Pos;
		  S.Read(RLEBuffer^, L);
		  If biCompression = bi_RLE4
		  then P := DecodeRLE4(RLEBuffer, Bitmap)
		  else P := DecodeRLE8(RLEBuffer, Bitmap);
		  Inc(Pos, LongRec(P).Lo);
		  S.Seek(Pos); { re-seek }
		  S.Reset;
		until LongRec(P).Hi <> 0; { image chunk has been read }
		FreeMem(RLEBuffer, RLEBitmapChunkSize + RLEBitmapOverhang);
	      end
	    end;
	end;
      end;
    End;
    StdBitmapLoad := Bitmap;
  End
  else StdBitmapLoad := nil;
End;

function ChunkedBitmapLoad(var BitmapInfoHeader: TBitmapInfoHeader;
  var S: TStream; Size: LongInt; Palette: pointer;
  CreateImage: Boolean): pointer; far;
var
  Bitmap: PBitmap;
  Image: PImage;
  ChunkCount: Integer;
  ChunkHeight: Integer;
  WidthBytes: Integer;
  List: pointer;
  i, y: Integer;
  BitmapChunkSize: LongInt;
begin
  with BitmapInfoHeader do
  begin
    WidthBytes := ((biWidth * biBitCount div biPlanes + 31) shr 3) and $FFFC;
    BitmapChunkSize := (VirtualBitmapChunkSize * biBitCount) div 8;
    If BitmapChunkSize > PhysicalBitmapChunkSize
    then BitmapChunkSize := PhysicalBitmapChunkSize;
    ChunkHeight := BitmapChunkSize div WidthBytes;
    ChunkCount := (abs(biHeight) + ChunkHeight - 1) div ChunkHeight;
    If abs(biHeight) > ChunkHeight
    then begin
      If CreateImage
      then begin
	GetMem(Image, SizeOf(TImage) + (ChunkCount - 1) * SizeOf(pointer));
	with Image^ do
	begin
	  imSizeXm1 := -1;
	  imSizeYm1 := -1;
	  imCount := ChunkCount;
	  y := biHeight;
	  For i := imCount - 1 downto 0 do
	  begin
	    If y > ChunkHeight
	    then begin
	      biHeight := ChunkHeight;
	      Dec(y, ChunkHeight)
	    end
	    else biHeight := y;
	    imPtrs[i] := BitmapLoadProc(BitmapInfoHeader, S, Size,
	      PaletteCopy(BitmapInfoHeader, Palette), true)
	  end
	end;
	ChunkedBitmapLoad := Image;
	If Palette <> nil then
	  FreeMem(Palette, SizeOf(TRGBQuad) shl biBitCount);
      end
      else begin
        New(Bitmap);
	FillChar(Bitmap^, SizeOf(TBitmap), 0);
        with Bitmap^ do
	begin
          bmWidth := biWidth;
          bmHeight := - biHeight;
	  bmPlanes := biPlanes;
          bmBitsPixel := biBitCount div biPlanes;
	  bmWidthBytes := ((bmWidth * bmBitsPixel + 31) shr 3) and $FFFC;
          bmPalette := Palette;
          GetMem(bmBits, ChunkCount * SizeOf(pointer));
          List := bmBits;
          bmChunks := ChunkCount;
        end;
        y := biHeight;
	For i := 1 to ChunkCount do
        begin
	  If y > ChunkHeight
          then begin
            biHeight := ChunkHeight;
	    Dec(y, ChunkHeight)
          end
          else biHeight := y;
          pointer(List^) := BitmapLoadProc(BitmapInfoHeader, S, Size,
            PaletteCopy(BitmapInfoHeader, Palette), false);
          Inc(PtrRec(List).Ofs, SizeOf(pointer))
	end;
	ChunkedBitmapLoad := Bitmap
      end
    end
    else
      ChunkedBitmapLoad := BitmapLoadProc(BitmapInfoHeader, S, Size, Palette, CreateImage)
  end
end;

function DoLoadBitmap(var S: TStream; Size: LongInt; BitsOffset: LongInt;
  CreateImage: Boolean): pointer; near;
var
  Bitmap: PBitmap;
  BitmapInfoHeader: TBitmapInfoHeader;
  pal: pointer;
Begin
  DoLoadBitmap := nil;
  Inc(Size, S.GetPos);
  with BitmapInfoHeader do Begin
    S.Read(biSize, 4);
    If biSize > SizeOf(TBitmapInfoHeader) then Exit;
    S.Read(biWidth, biSize - 4);
    If biSize = SizeOf(TBitmapCoreHeader) then Begin
      biCompression := bi_RGB;
      FillChar(biSizeImage, 20, 0)
    End;
  End;
  If S.Status <> stOk then Exit;
  pal := PaletteLoad(BitmapInfoHeader, S);
  If BitsOffset = 0
  then BitsOffset := S.GetPos
  else S.Seek(BitsOffset);
  Dec(Size, BitsOffset);
  DoLoadBitmap := {BitmapLoadProc}ChunkedBitmapLoad(BitmapInfoHeader, S, Size, pal, CreateImage)
End;

function DoLoadBitmapRes(var S: TStream; BitmapName: PChar;
  CreateImage: Boolean): pointer; near;
var
  p, Size: LongInt;
Begin
  p := S.GetPos;
  Size := SkipToResourceS(S, BitmapName, rt_Bitmap);
  If Size <> 0
  then DoLoadBitmapRes := DoLoadBitmap(S, Size, 0, CreateImage)
  else DoLoadBitmapRes := nil;
  S.Seek(P);
End;

function DoLoadBitmapFile(var S: TStream; CreateImage: Boolean): PBitmap; near;
var
  BitmapFileHeader: TBitmapFileHeader;
  P: LongInt;
Begin
  P := S.GetPos; { Support for encapsulated BMP files }
  S.Read(BitMapFileHeader, SizeOf(TBitmapFileHeader));
  with BitMapFileHeader do
    If bfType = $4D42
    then DoLoadBitmapFile := DoLoadBitmap(S, bfSize, P+bfOffBits, CreateImage)
    else DoLoadBitmapFile := nil
End;

function LoadBitmap(var S: TStream; BitmapName: PChar): PBitmap; {public}
Begin
  LoadBitmap := DoLoadBitmapRes(S, BitmapName, false)
End;

function LoadBitmapImg(var S: TStream; BitmapName: PChar): pointer; {public}
Begin
  LoadBitmapImg := DoLoadBitmapRes(S, BitmapName, true)
End;

function LoadBitmapFile(var S: TStream): PBitmap; {public}
Begin
  LoadBitmapFile := DoLoadBitmapFile(S, false)
End;

function LoadBitmapFileImg(var S: TStream): pointer; {public}
Begin
  LoadBitmapFileImg := DoLoadBitmapFile(S, true)
End;

{ Store Bitmap
}

procedure StdBitmapStore(var S: TStream; Bitmap: PBitmap); {$ifndef FPK}far;{$endif}
var
  i: Integer;
  p: pointer;
Begin
  with Bitmap^ do
    If bmChunks = 0
    then S.Write(bmBits^, bmWidthBytes * abs(bmHeight) * bmPlanes)
    else begin
      p := bmBits;
      For i := 1 to bmChunks do
      begin
        If PBitmap(p^) <> nil
        then BitmapStoreProc(S, PBitmap(p^));
        Inc(PtrRec(p).Ofs, SizeOf(pointer))
      end
    end
End;

procedure StoreBitmapFile(var S: TStream; Bitmap: PBitmap); {public}
var
  FileHeader: TBitmapFileHeader;
  BitmapInfoheader: TBitmapInfoHeader;
  size: Word;
  zero: pointer;
  posa, posb, posc: LongInt;
Begin
  posa := S.GetPos;
  with Bitmap^ do Begin
    FillChar(FileHeader, SizeOf(FileHeader), 0);
    with FileHeader do
      bfType := $4D42;
    S.Write(FileHeader, SizeOf(TBitmapFileHeader));
    with BitmapInfoHeader do Begin
      biSize := SizeOf(TBitmapInfoHeader);
      biWidth := bmWidth;
      biHeight := abs(bmHeight);
      biPlanes := 1 {bmPlanes;     !!!!!!!!! };
      biBitCount := bmPlanes * bmBitsPixel;
      biCompression := bi_RGB;
      biSizeImage := 0;
      biXPelsPerMeter := 0;
      biYPelsPerMeter := 0;
      biClrUsed := 0;
      biClrImportant := 0
    End;
    S.Write(BitmapInfoHeader, SizeOf(TBitmapInfoHeader));
    If bmPalette = nil then Begin
      size := SizeOf(TRGBQuad) shl BitmapinfoHeader.biBitCount;
      GetMem(zero, size);
      FillChar(zero, size, 0);
      S.Write(zero^, size);
      FreeMem(zero, size)
    End
    else
      S.Write(bmPalette^, SizeOf(TRGBQuad) shl (bmPlanes * bmBitsPixel));
    posb := S.GetPos;
    BitmapStoreProc(S, Bitmap);
  End;
  posc := S.GetPos;
  S.Seek(posa);
  with FileHeader do
  begin
    bfSize := posc - posa;
    bfOffBits := posb - posa
  end;
  S.Write(FileHeader, SizeOf(TBitmapFileHeader));
  S.Seek(posc);
End;

{ Icon resource routines 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

function PlainSize(var InfoHeader: TBitmapInfoHeader): LongInt;
begin
  with InfoHeader do
    PlainSize := (((biWidth + 31) div 32) * biHeight) shl biBitCount
end;

procedure DoLoadIcon(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorWhat, AndWhat: pointer; CreateImage: Boolean);
var
  P: LongInt;
  IconDir: TIconDir;
  BestEntry, IconDirEntry: TIconDirEntry;
  IconImage: TIconImage;
  i: Integer;
  pal: pointer;
  size: LongInt;
  This, Best: Integer;
begin
  P := S.GetPos;
  XorWhat := nil;
  AndWhat := nil;
  If SkipToResource(S, IconName, rt_Group_Icon)
  then begin
    S.Read(IconDir, SizeOf(IconDir));
    Best := -1;
    For i := 1 to IconDir.idCount do
    begin
      S.Read(IconDirEntry, SizeOf(IconDirEntry));
      with IconDirEntry do
	This := Byte(SizeX = bWidth) + Byte(SizeY = bHeight) +
		Byte(NumColors = bColorCount);
      If This > Best
      then begin
	Best := This;
	BestEntry := IconDirEntry
      end
    end;
    with BestEntry do
    begin
      S.Seek(P);
      size := SkipToResourceS(S, MakeIntResource(wImageName), rt_Icon);
      If Size > 0
      then begin
	S.Read(IconImage, SizeOf(TIconImage));
	with IconImage do
	begin
	  Header.biHeight := Header.biHeight div 2;
	  pal := PaletteLoad(Header, S);
	  XorWhat := BitmapLoadProc(Header, S,
	    PlainSize(Header), pal, CreateImage);
	  Header.biBitCount := 1;
	  Header.biPlanes := 1;
	  AndWhat := BitmapLoadProc(Header, S,
	    PlainSize(Header), nil, CreateImage);
	end
      end
    end
  end;
  S.Seek(P)
end;

procedure LoadIcon(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorBitmap, AndBitmap: PBitmap);
begin
  DoLoadIcon(S, IconName, SizeX, SizeY, NumColors,
    pointer(XorBitmap), pointer(AndBitmap), false)
end;

procedure LoadIconImg(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorImage, AndImage: pointer);
begin
  DoLoadIcon(S, IconName, SizeX, SizeY, NumColors, XorImage, AndImage, true)
end;

{$else Windows}

{ This code has been adapted from BSCRLAPP.PAS, which is
  copr. 1991 Borland International.
}

procedure AHIncr; far; external 'KERNEL' index 114;

procedure GetBitmapData(var TheFile: TStream;
  BitsHandle: THandle; BitsByteSize: Longint);
type
  LongType = record
    case Word of
      0: (Ptr: Pointer);
      1: (Long: Longint);
      2: (Lo: Word;
	  Hi: Word);
  end;
var
  Count: Longint;
  Start, ToAddr, Bits: LongType;
begin
  Start.Long := 0;
  Bits.Ptr := GlobalLock(BitsHandle);
  Count := BitsByteSize - Start.Long;
  while Count > 0 do
  begin
    ToAddr.Hi := Bits.Hi + (Start.Hi * Ofs(AHIncr));
    ToAddr.Lo := Start.Lo;
    if Count > $4000 then Count := $4000;
    TheFile.Read(ToAddr.Ptr^, Count);
    Start.Long := Start.Long + Count;
    Count := BitsByteSize - Start.Long;
  end;
  GlobalUnlock(BitsHandle);
end;

function OpenDIB(var TheFile: TStream): HBitmap;
var
  bitCount: Word;
  size: Word;
  longWidth: Longint;
  DCHandle: HDC;
  BitsPtr: Pointer;
  BitmapInfo: PBitmapInfo;
  BitsHandle, NewBitmapHandle: THandle;
  NewPixelWidth, NewPixelHeight: Word;
  p: LongInt;
begin
  p := TheFile.GetPos;
  TheFile.Seek(p + 28);
  TheFile.Read(bitCount, SizeOf(bitCount));
  if bitCount <= 8 then
  begin
    size := SizeOf(TBitmapInfoHeader) + ((1 shl bitCount) * SizeOf(TRGBQuad));
    BitmapInfo := MemAlloc(size);
    TheFile.Seek(p + SizeOf(TBitmapFileHeader));
    TheFile.Read(BitmapInfo^, size);
    NewPixelWidth := BitmapInfo^.bmiHeader.biWidth;
    NewPixelHeight := BitmapInfo^.bmiHeader.biHeight;
    longWidth := (((NewPixelWidth * bitCount) + 31) div 32) * 4;
    BitmapInfo^.bmiHeader.biSizeImage := longWidth * NewPixelHeight;
    {GlobalCompact(-1);}
    BitsHandle := GlobalAlloc(gmem_Moveable or gmem_Zeroinit,
      BitmapInfo^.bmiHeader.biSizeImage);
    GetBitmapData(TheFile, BitsHandle, BitmapInfo^.bmiHeader.biSizeImage);
    DCHandle := CreateDC('Display', nil, nil, nil);
    BitsPtr := GlobalLock(BitsHandle);
    NewBitmapHandle :=
      CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
      BitmapInfo^, 0);
    DeleteDC(DCHandle);
    GlobalUnlock(BitsHandle);
    GlobalFree(BitsHandle);
    FreeMem(BitmapInfo, size);
    OpenDIB := NewBitmapHandle
  end
  else
    OpenDIB := 0;
end;

{ up to here }

constructor TBitmapRef.Init(ABmp: HBitmap);
begin
  inherited Init;
  Bmp := ABmp;
  Ref := 1
end;

destructor TBitmapRef.Done;
begin
  DeleteObject(Bmp);
  inherited Done;
end;

procedure TBitmapRef.IncRef;
begin
  Inc(Ref)
end;

procedure TBitmapRef.DecRef;
begin
  Dec(Ref);
  If Ref <= 0 then Free;
end;

function LoadBitmap(var S: TStream; BitmapName: PChar): PBitmap;
begin
  LoadBitmap := nil;
end;

function LoadBitmapImg(var S: TStream; BitmapName: PChar): pointer;
var
  Img: PImage;
begin
  If IsResStream(S)
  then begin
    New(Img);
    with Img^ do
    begin
      Color := Bitmap.Color;
      BkColor := Bitmap.BkColor;
      New(BitmapRef, Init(WinProcs.LoadBitmap(PResStream(@S)^.Instance, BitmapName)))
    end;
    LoadBitmapImg := Img
  end
  else
    LoadBitmapImg := nil
end;

function LoadBitmapFile(var S: TStream): PBitmap;
begin
  LoadBitmapFile := nil
end;

function LoadBitmapFileImg(var S: TStream): pointer;
var
  TheBmp: HBitmap;
  Img: PImage;
begin
  TheBmp := OpenDIB(S);
  If TheBmp <> 0
  then begin
    New(Img);
    with Img^ do
    begin
      Color := 0;
      BkColor := 0;
      New(BitmapRef, Init(TheBmp));
    end;
    LoadBitmapFileImg := Img
  end
  else
    LoadBitmapFileImg := nil
end;

procedure DeleteBitmap(Bitmap: PBitmap);
begin
end;

procedure StoreBitmapFile(var S: TStream; Bitmap: PBitmap);
begin
end;

procedure LoadIcon(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorBitmap, AndBitmap: PBitmap);
begin
  XorBitmap := nil;
  AndBitmap := nil;
end;

procedure LoadIconImg(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorImage, AndImage: pointer);
begin
  XorImage := nil;
  AndImage := nil
end;

{$endif Windows}
{$endif !FPK}

{ Code page routines 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

{$ifdef FPK}

procedure AnsiFrom437(Buf: PChar);
begin
end; { AnsiFrom437 }

procedure AnsiFrom437Str(Str: PString);
begin
end; { AnsiFrom437Str }

procedure AnsiTo437(Buf: PChar);
begin
end; { AnsiTo437 }

procedure AnsiTo437Str(Str: PString);
begin
end; { AnsiTo437Str }

{$else !FPK}

{$L WResChr.obj  (WResChr.asm) 		WinRes: Character translation }
{$L 10070437.obj (10070437.bin) }
{$L 04371007.obj (04371007.bin) }

procedure AnsiFrom437(Buf: PChar); external;
procedure AnsiFrom437Str(Str: PString); external;

procedure AnsiTo437(Buf: PChar); external;
procedure AnsiTo437Str(Str: PString); external;

procedure AnsiTo437Buf(var Buf); near; external;

{$endif !FPK}

{ String resource routines 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}
{$ifndef Windows}
{$ifndef FPK}
function LoadStringBlock(var S: TStream; Index: Word): PStringBlock;
var
  P, Q, Size: LongInt;
  Block: PStringBlock;
Begin
  LoadStringBlock := nil;
  P := S.GetPos;
  size := SkipToResourceS(S, MakeIntResource(Index shr 4 + 1), rt_String);
  If size <> 0 then Begin
    Q := S.GetPos;
    GetMem(Block, SizeOf(TStringBlock) + size);
    LoadStringBlock := Block;
    with Block^ do Begin
      sbIndex := Index shr 4 + 1;
      sbSize := size;
      sbNext := nil;
      S.Read(sbData, size);
      If not AnsiCode then AnsiTo437Buf(sbData)
    End
  End;
  S.Seek(P)
End;

function NullStringBlock(Index: Word): PStringBlock;
var
  Block: PStringBlock;
begin
  GetMem(Block, SizeOf(TStringBlock) + 16);
  NullStringBlock := Block;
  with Block^ do
  begin
    sbIndex := Index shr 4 + 1;
    sbSize := 16;
    sbNext := nil;
    FillChar(sbData, 16, 0)
  end;
end;

procedure FreeStringBlock(Block: PStringBlock);
Begin
  If Block <> nil then
  FreeMem(Block, SizeOf(TStringBlock) + Block^.sbSize)
End;

function GetStringFromBlock(Block: PStringBlock; Index: Word): PString; external;

{$L WResStr.obj  (WResStr.asm)		WinRes: strings }

{$endif !FPK}

function LoadString(var S: TStream; Index: Word): string;
var
  P, Cur: LongInt;
  i: Integer;
  d: Byte;
  str: PString;
{$ifdef NOIASM}
  b: string;
{$endif}
Begin
  P := S.GetPos;
  If SkipToResource(S, PChar(MakeIntResource(Index shr 4 + 1)), PChar(rt_String))
  then Begin
    Cur := S.GetPos;
    For i := 1 to Index and 15 do Begin
      S.Read(d, 1);
      Inc(Cur, d + 1);
      S.Seek(Cur)
    End;
    {$ifdef NOIASM}
    str := @b;
    {$else}
    asm
	les	di, @Result
	mov	WORD PTR str, di
	mov	WORD PTR str.2, es
    end;
    {$endif}
    S.Read(str^[0], 1);
    S.Read(str^[1], Length(str^));
    If not AnsiCode then AnsiTo437Str(str);
    {$ifdef NOIASM}
    LoadString := b;
    {$endif}
  End
  else LoadString := '';
  S.Seek(P)
End;
{$else Windows}
function LoadString(var S: TStream; Index: Word): string;
var
  Buf: string;
begin
  If IsResStream(S)
  then begin
    WinProcs.LoadString(PResStream(@S)^.Instance, Index, @Buf[1], 255);
    Buf[0] := Chr(StrLen(@Buf[1]));
    If not AnsiCode then AnsiTo437Str(@Buf);
    LoadString := Buf
  end
  else
    LoadString := ''
end;
{$endif Windows}

{$ifdef FPK}
function LoadBitmapImg(var S: TStream; BitmapName: PChar): pointer;
begin		
  { FIXME: Must change bitmaps.pp }
  LoadBitmapImg := nil
end;		

function LoadBitmapFileImg(var S: TStream): pointer;
var
  Bitmap: TBitmap;
begin
  Bitmap.Create;
  BitmapIO_BMP.SetBitmap(@Bitmap);
  LoadBitmapFileImg := nil;
  if BitmapIO_BMP.LoadFromStream(@S) then begin
    LoadBitmapFileImg := CopyImage(Bitmap.GetData);
  end;
  Bitmap.Destroy;
end;

procedure LoadIconImg(var S: TStream; IconName: PChar; SizeX, SizeY: Integer;
  NumColors: Word; var XorImage, AndImage: pointer);
begin
  XorImage := nil;
  AndImage := nil
end;

{$endif FPK}

{ Accelerators 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

procedure TranslateAcc(Acc: PAccelerators);
type
  TModifier = (None, Shift, Ctrl, Alt);
const
  CtrlCursor: array[$21..$28] of Word =
    (kbPgUp, kbPgDn, kbEnd, kbHome, kbLeft, kbUp, kbRight, kbDown);
  Cursor: array[$21..$28] of Word =
    (kbCtrlPgUp, kbCtrlPgDn, kbCtrlEnd, kbCtrlHome, kbCtrlLeft,
     kbUp, kbCtrlRight, kbDown);
  FuncBases: array[TModifier] of Word =
    (kbF1, kbShiftF1, kbCtrlF1, kbAltF1);
  InsDel: array[TModifier, $2D..$2E] of Word =
    ((kbIns, kbDel), (kbShiftIns, kbShiftDel), (kbCtrlIns, kbCtrlDel), (0, 0));
  {$ifdef VER60}
  kbAltBack = kbCtrlBack;
  {$endif}
var
  Cur: PAccelerator;
  Modifier: TModifier;
  Last: Boolean;
begin
  Cur := @Acc^.Acc;
  Repeat
    with Cur^ do
    begin
      If fFlags and accVirtualKey <> 0
      then begin
	If fFlags and accAlt <> 0 then Modifier := Alt else
	if fFlags and accCtrl <> 0 then Modifier := Ctrl else
	if fFlags and accShift <> 0 then Modifier := Shift else
	Modifier := None;
	case wEvent of
	  $70..$79:  {funkeys}
	    wEvent := FuncBases[Modifier] + (wEvent - $70) shl 8;
	  $08:
	    If fFlags and accAlt <> 0 then wEvent := kbAltBack else
	    if fFlags and accCtrl <> 0 then wEvent := kbCtrlBack else
	    wEvent := kbBack;
	  $09:
	    If fFlags and accShift <> 0 then wEvent := kbShiftTab else
	    wEvent := kbTab;
	  $0D:
	    If fFlags and accCtrl <> 0 then wEvent := kbCtrlEnter else
	    wEvent := kbEnter;
	  $1B:
	    wEvent := kbEsc;
	  $21..$28:
	    If fFlags and accCtrl <> 0 then wEvent := CtrlCursor[wEvent]
	    else wEvent := Cursor[wEvent];
	  $2D, $2E:
	    wEvent := InsDel[Modifier][wEvent];
	  else
	    wEvent := 0;
	end;
      end
      else begin
	If fFlags and accAlt <> 0
	then wEvent := GetAltCode(Chr(wEvent))
      end
    end;
    Last := Cur^.fFlags and accLast <> 0;
    Inc(PtrRec(Cur).Ofs, SizeOf(TAccelerator));
  until Last
end;

{$ifdef Windows}
function LoadAccelerators(var S: TStream; Name: PChar): PAccelerators;
var
  Acc: PAccelerators;
  Handle: THandle;
  P: pointer;
  Size: Word;
begin
  LoadAccelerators := nil;
  If not IsResStream(S) then Exit;
  Handle := WinProcs.LoadAccelerators(PResStream(@S)^.Instance, Name);
  Size := GlobalSize(Handle);
  p := GlobalLock(Handle);
  if p <> nil
  then begin
    GetMem(Acc, Size + SizeOf(Word));
    Acc^.Size := Size;
    Move(p^, Acc^.Acc, Size);
    TranslateAcc(Acc);
    LoadAccelerators := Acc
  end;
  GlobalUnlock(Handle);
  GlobalFree(Handle)
end;
{$else !Windows}
function LoadAccelerators(var S: TStream; Name: PChar): PAccelerators;
var
  Acc: PAccelerators;
  P: LongInt;
  Size: Word;
begin
  P := S.GetPos;
  Size := SkipToResourceS(S, Name, PChar(rt_Accelerator));
  If Size = 0
  then LoadAccelerators := nil
  else begin
    GetMem(Acc, Size + SizeOf(Word));
    Acc^.Size := Size;
    S.Read(Acc^.Acc, Size);
    TranslateAcc(Acc);
    LoadAccelerators := Acc
  end;
  S.Seek(P)
end;
{$endif Windows}

procedure FreeAccelerators(Accelerators: PAccelerators);
begin
  If Accelerators <> nil
  then FreeMem(Accelerators, Accelerators^.Size + SizeOf(Word))
end;

{$ifdef NOIASM}
function LookupAccelerator(Accelerators: PAccelerators;
  Command: Word): Word; 
begin
  {FIXME:}
  LookupAccelerator := 0
end; { LookupAccelerator }
{$else}
function LookupAccelerator(Accelerators: PAccelerators;
  Command: Word): Word; assembler;
asm
	les	di, Accelerators
	mov	cx, Command
	add	di, TAccelerators.Acc
	mov	ax, 0
@@2:
	cmp	cx, es:[di].TAccelerator.wID
	jz	@@1
	test	es:[di].TAccelerator.fFlags, accLast
	jnz	@@0
	add	di, TYPE TAccelerator
	jmp	@@2
@@1:
	mov	ax, es:[di].TAccelerator.wEvent
@@0:
	end;
{$endif}

procedure SetHelpCtxDelta(ADelta: Word);
begin
  HelpCtxDelta := ADelta
end;

function AnsiCode: Boolean;
begin
  AnsiCode := AnsiCodeState
end;

procedure SetAnsiCode(on_: Boolean);
begin
  AnsiCodeState := on_
end;

{$IFNDEF VER60 *************************************************************}

{ String zero routines
}

procedure ReadSZ(var S: TStream; Buf: PChar); {$ifndef FPK}near;{$endif}
var
  C: Char;
  cnt: Word;
Begin
  cnt := 0;
  Repeat
    S.Read(C, 1);
    Buf[0] := C;
    If cnt < 256 then Inc(Buf);
    Inc(cnt)
  Until C = #0;
End;

function ReadNewSZ(var S: TStream; Buf: PChar): PChar; {$ifndef FPK}near;{$endif}
Begin
  ReadSZ(S, Buf);
  ReadNewSZ := StrNew(Buf)
End;

procedure DisposeSZ(Buf: PChar); {$ifndef FPK}near;{$endif}
Begin
  If Seg(Buf^) <> 0 then StrDispose(Buf)
End;

{ Marker routines
}

function ConvertMarkers(Buf: PChar; Max: Word): Boolean;
var
  M: PChar;
Begin
  ConvertMarkers := false;
  M := Buf + Max;
  Repeat
    Buf := StrScan(Buf, '&');
    If Buf <> nil then
    if Buf[1] = '&'
    then Begin					{ &&  & }
      StrMove(Buf + 1, Buf, StrLen(Buf));
      Inc(Buf, 2)
    End
    else Begin					{ &a  ~a~ }
      ConvertMarkers := true;
      Buf[0] := '~';
      If StrEnd(Buf) = M - 1
      then StrMove(Buf + 3, Buf + 2, StrLen(Buf+3))
      else StrMove(Buf + 3, Buf + 2, StrLen(Buf+1));
      Buf[2] := '~';
      Inc(Buf, 3)
    End;
  Until (Buf >= M) or (Buf = nil)
End;

{ Menu routines
}
const
  dfDisabled   = $01;
  dfMenuCheck  = $02;
  dfRadio      = $04;
  dfCheckState = $08;
  dfBitmap     = $10;

type
  PMenu = ^TMenu;

  PMenuItem = ^TMenuItem;
  TMenuItem = record
    Next: PMenuItem;
    Name: PString;
    Command: Word;
    Disabled: Byte;
    KeyCode: Word;
    HelpCtx: Word;
    case Integer of
      0: (Param: PString);
      1: (SubMenu: PMenu);
  end;

  TMenu = record
    Items: PMenuItem;
    Default: PMenuItem;
  end;

  PColorItem = ^TColorItem;
  TColorItem = record
    Name: PString;
    Index: Byte;
    Next: PColorItem;
  end;

  PColorGroup = ^TColorGroup;
  TColorGroup = record
    Name:  PString;
    Items: PColorItem;
    Next:  PColorGroup;
  end;

function LoadMenu(var S: TStream; MenuName: PChar; Options: Word): pointer;
var
  P: LongInt;
  MenuHeader: TMenuHeader;
  Buf: array[0..255] of Char;
  SaveHelpCtx: Word;

 function DoLoadMenu: PMenu;
 var
   Menu: PMenu;
   Res, Item: PMenuItem;
   Flags: Word;
   Prefix: string[2];
   P: PChar;
   SaveSave: Word;
 Begin
   New(Menu); FillChar(Menu^, SizeOf(Menu^), 0);
   DoLoadMenu := Menu;
   Res := nil;
   Repeat
     S.Read(Flags, SizeOf(Word));
     If Flags and (mf_Disabled + mf_Popup) = mf_Disabled
     then begin
       S.Read(SaveHelpCtx, SizeOf(Word));
       ReadSZ(S, Buf)
     end
     else begin
       New(Item);
       If Res = nil then Begin
	 Menu^.Items := Item;
	 Menu^.Default := Item
       End else Res^.Next := Item;
       Res := Item;
       with Item^ do Begin
	 Next := nil;
	 Disabled := Byte(Flags and mf_Grayed <> 0);
	 KeyCode := 0;
	 If Flags and mf_PopUp = 0 then Begin
	   S.Read(Command, SizeOf(Word));
	   HelpCtx := Command + HelpCtxDelta;
	   ReadSZ(S, Buf);
	   If not AnsiCode then AnsiTo437(Buf);
	   P := StrScan(Buf, #9);
	   If P <> nil then Begin
	     P[0] := #0;
	     Param := NewStr(StrPas(P+1))
	   End
	   else Param := nil;
	   Prefix := '';
	   If Flags and mf_Checked <> 0 then
	   if Options = mo_GraphicsVision
	     then Disabled := Disabled or (dfMenuCheck + dfCheckState)
	     else Prefix := ' ';
	   ConvertMarkers(Buf, 256);
	   Name := NewStr(Prefix + StrPas(Buf))
	 End
	 else Begin
	   Command := 0;
	   ReadSZ(S, Buf);
	   If not AnsiCode then AnsiTo437(Buf);
	   ConvertMarkers(Buf, 256);
	   Name := NewStr(StrPas(Buf));
	   SaveSave := SaveHelpCtx;
	   SaveHelpCtx := 0;
	   SubMenu := DoLoadMenu;
	   HelpCtx := SaveHelpCtx;
	   SaveHelpCtx := SaveSave
	 End
       End
     end
   Until Flags and mf_End <> 0;
 End;

 procedure SkipMenu;
 var
   Flags: Word;
   Command: Word;
 Begin
   Repeat
     S.Read(Flags, SizeOf(Word));
     If Flags and mf_PopUp = 0
     then begin
       S.Read(Command, SizeOf(Word));
       ReadSZ(S, Buf)
     end
     else begin
       ReadSZ(S, Buf);
       SkipMenu
     end
   Until Flags and mf_End <> 0;
 End;

 function DoLoadColorItems: PColorItem;
 var
   Res, Item: PColorItem;
   Flags: Word;
   Command: Word;
 Begin
   Res := nil;
   DoLoadColorItems := nil;
   Repeat
     S.Read(Flags, SizeOf(Word));
     If Flags and mf_PopUp = 0
     then Begin
       S.Read(Command, SizeOf(Word));
       ReadSZ(S, Buf);
       If Buf[0] <> #0
       then begin
	 If not AnsiCode then AnsiTo437(Buf);
	 New(Item);
	 If Res = nil
	 then DoLoadColorItems := Item
	 else Res^.Next := Item;
	 Res := Item;
	 with Item^ do
	 begin
	   Next := nil;
	   Index := Command;
	   Name := NewStr(StrPas(Buf))
	 end
       end
     end
     else begin
       ReadSZ(S, Buf);
       SkipMenu;
     end
   Until Flags and mf_End <> 0;
 End;

 function DoLoadColorGroups: PColorGroup;
 var
   Res, Item: PColorGroup;
   Flags: Word;
   Command: Word;
 Begin
   Res := nil;
   DoLoadColorGroups := nil;
   Repeat
     S.Read(Flags, SizeOf(Word));
     If Flags and mf_PopUp = 0
     then begin
       S.Read(Command, SizeOf(Word));
       ReadSZ(S, Buf);
     end
     else begin
       ReadSZ(S, Buf);
       If not AnsiCode then AnsiTo437(Buf);
       New(Item);
       If Res = nil
       then DoLoadColorGroups := Item
       else Res^.Next := Item;
       Res := Item;
       with Item^ do
       begin
	 Next := nil;
	 Name := NewStr(StrPas(Buf));
	 Items := DoLoadColorItems
       end
     end
   Until Flags and mf_End <> 0;
 End;

Begin
  P := S.GetPos;
  If SkipToResource(S, MenuName, PChar(rt_Menu))
  then begin
    S.Read(MenuHeader, SizeOf(TMenuHeader));
    case Options of
      mo_ColorGroups:
	LoadMenu := DoLoadColorGroups;
      else
	LoadMenu := DoLoadMenu;
    end;
  end
  else
    LoadMenu := nil;
  S.Seek(P);
End;

{ Dialog template routines
}

type
  PClassCollection = ^TClassCollection;
  TClassCollection = object(TSortedCollection)
    function Compare(Key1, Key2: Pointer): Sw_Integer; virtual;
    procedure FreeItem(Item: Pointer); virtual;
  End;

function TClassCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
var
  C1, C2: PChar;
  Rslt: Integer;
Begin
  Rslt := PClassRec(Key1)^.TypeId - PClassRec(Key2)^.TypeId;
  If Rslt <> 0
  then Compare := Rslt
  else begin
    C1 := PClassRec(Key1)^.ClassId;
    C2 := PClassRec(Key2)^.ClassId;
    If (Seg(C1^) = 0) or (Seg(C2^) = 0) then
      if LongInt(C1) > LongInt(C2) then Compare := +1 else
      if LongInt(C1) < LongInt(C2) then Compare := -1 else Compare := 0
    else Compare := StrIComp(C1, C2)
  end
End;

procedure TClassCollection.FreeItem(Item: Pointer);
Begin
  { don't free (they're static) }
End;

const
  Classes: PSortedCollection = nil;

procedure InitClasses;
Begin
  Classes := New(PClassCollection, Init(8, 32))
End;

procedure DoneClasses;
Begin
  Dispose(Classes, Done);
  Classes := nil
End;

procedure RegisterClass(var ClassRec: TClassRec);
var
  Index: Sw_Integer;
Begin
  If Classes = nil then Begin
    InitClasses;
    If Classes = nil then Exit
  End;
  with Classes^ do Begin
    If Search(@ClassRec, Index) then AtDelete(Index);
    AtInsert(Index, @ClassRec)
  End
End;

function GetClass(ClassName: PChar; ClassTypeId: Integer): PClassRec;
var
  Index: Sw_Integer;
  Rec: TClassRec;
Begin
  Rec.ClassId := ClassName;
  Rec.TypeId := ClassTypeId;
  If Classes^.Search(@Rec, Index)
  then GetClass := Classes^.At(Index)
  else GetClass := nil
End;

function LoadDialog(var S: TStream; DialogName: PChar): pointer;
var
  Header: TDialogBoxHeader;
  Control: TControlData;
  Info: TDialogInfo;
  Buf: array[0..255] of Char;
  DlgClass, ClassId: PClassRec;
  Pos: LongInt;
  i: Byte;
Begin
  Pos := S.GetPos;
  Info.Resource := @S;
  Info.ResTblPos := Pos;
  LoadDialog := nil;
  If SkipToResource(S, DialogName, PChar(rt_Dialog)) then Begin
    S.Read(Header, 13);
    with Header do Begin
      FillChar(szMenuName, SizeOf(TDialogBoxHeader) - 13, 0);
      S.Read(Buf, 1);
      If Buf[0] = #255 then S.Read(szMenuName, 2) else
      if Buf[0] <> #0 then Begin
	ReadSZ(S, PChar(@Buf)+1);
	szMenuName := StrNew(Buf)
      End;
      szClassname := ReadNewSZ(S, Buf);
      szCaption := ReadNewSZ(S, Buf);
      If szCaption <> nil then If not AnsiCode then AnsiTo437(szCaption);
      If lStyle and ds_SetFont <> 0 then Begin
	S.Read(wPointSize, 2);
	szFaceName := ReadNewSZ(S, Buf)
      End;
      If Classes = nil
	then DlgClass := nil
	else DlgClass := GetClass(szClassname, ctDialog);
      If DlgClass = nil
	then Info.Dialog := nil
	else TInitProc(DlgClass^.Init)(@Header, @Info);
      DisposeSZ(szMenuName);
      DisposeSZ(szClassname);
      DisposeSZ(szCaption);
      DisposeSZ(szFaceName);
      If Info.Dialog <> nil then Begin
	For i := 1 to bNumberOfItems do Begin
	  S.Read(Control, 14);
	  with Control do Begin
	    S.Read(Buf, 1);
	    If Buf[0] >= #$80 then LongInt(szClass) := Byte(Buf[0]) else
	    if Buf[0] = #0 then szClass := nil else Begin
	      ReadSZ(S, PChar(@Buf)+1);
	      szClass := StrNew(Buf)
	    End;
	    S.Read(Buf, 1);
	    If Buf[0] = #255
	    then begin
	      szText := nil;
	      S.Read(szText, 2)
	    end else
	    if Buf[0] = #0
	    then szText := nil
	    else begin
	      ReadSZ(S, PChar(@Buf) + 1);
	      szText := StrNew(Buf);
	      If szText <> nil then If not AnsiCode then AnsiTo437(szText)
	    end;
	    S.Read(bExtraSize, 1);
	    If bExtraSize <> 0 then
	    S.Read(bExtra, bExtraSize);
	    ClassId := GetClass(szClass, ctDialog);
	    If ClassId <> nil then
	      TInitProc(ClassId^.Init)(@Control, @Info);
	    DisposeSZ(szClass);
	    DisposeSZ(szText)
	  End
	End;
	If Info.Wake <> nil then
	TWakeProc(Info.Wake)(@Info)
      End
    End;
    LoadDialog := Info.Dialog
  End;
  S.Seek(Pos)
End;

procedure CreateLinks(Info: PDialogInfo; Link: pointer);
var
  N, P: PLinkRec;
Begin
  P := Info^.Links;
  Info^.Links := nil;
  while P <> nil do
    with P^ do Begin
      TLinkProc(proc)(link, control);
      N := Next;
      Dispose(P);
      P := N
    End
End;

procedure InsertLink(Info: PDialogInfo; AProc: pointer; AControl: pointer);
var
  Link: PLinkRec;
Begin
  New(Link);
  with Link^ do Begin
    Next := Info^.Links;
    Proc := AProc;
    Control := AControl
  End;
  Info^.Links := Link
End;

{$ENDIF}

{$ifndef FPK}
{$ifndef Windows}
Begin
  BitmapLoadProc := StdBitmapLoad;
  BitmapFreeProc := StdBitmapFree;
  BitmapStoreProc := StdBitmapStore;
  BitmapAllocProc := StdBitmapAlloc
{$endif Windows}
{$endif}
End.
