#pas
unit HiAsmUnit;

interface

uses Share,Debug,Windows,ActiveX,KOLComObj,KOL;

const

 IMGCHG_SIZE         = $0001;
 IMGCHG_VIEW         = $0002;
 IMGCHG_COMPLETE     = $0004;
 IMGCHG_ANIMATE      = $0008;
 IMGCHG_MASK         = $000F;

 IMGLOAD_NOTLOADED   = $00100000;
 IMGLOAD_LOADING     = $00200000;
 IMGLOAD_STOPPED     = $00400000;
 IMGLOAD_ERROR       = $00800000;
 IMGLOAD_COMPLETE    = $01000000;
 IMGLOAD_MASK        = $01F00000;

 IMGBITS_NONE        = $02000000;
 IMGBITS_PARTIAL     = $04000000;
 IMGBITS_TOTAL       = $08000000;
 IMGBITS_MASK        = $0E000000;

 IMGANIM_ANIMATED    = $10000000;
 IMGANIM_MASK        = $10000000;

 IMGTRANS_OPAQUE     = $20000000;
 IMGTRANS_MASK       = $20000000;

 DWN_COLORMODE       = $0000003F;
 DWN_DOWNLOADONLY    = $00000040;
 DWN_FORCEDITHER     = $00000080;
 DWN_RAWIMAGE        = $00000100;

type

 IImgCtx = interface(IUnknown)
    ['{3050f3d7-98b5-11cf-bb82-00aa00bdce0b}']
    // Initialization/Download methods
    function Load(pszUrl:PWChar; dwFlags:DWORD): HResult; stdcall;
    function SelectChanges(ulChgOn:DWORD; ulChgOff:DWORD; fSignal:DWORD): HResult; stdcall;
    function SetCallback(pCallback:pointer; pUserData:pointer): HResult; stdcall;
    function Disconnect: HResult; stdcall;

 // Query methods
    function GetUpdateRects(prc:PRect; var prcImg:TRect; var pcrc:integer): HResult; stdcall;
    function GetStateInfo(var pulState:DWORD; var pSize:TSize; fClearChanges:DWORD): HResult; stdcall;
    function GetPalette(var phpal:HPalette): HResult; stdcall;

    // Rendering methods
    function Draw(_hdc:HDC; var prcBounds:TRect): HResult; stdcall;
    function Tile(_hdc:HDC; var pptBackOrg:TPoint; var prcClip:TRect; var psize:TSize): HResult; stdcall;
    function StretchBlt(_hdc:HDC; dstX,dstY,dstXE,dstYE,srcX,srcY,srcXE,srcYE:integer; dwROP:DWORD): HResult; stdcall;
 end;

 THiAsmClass = class(TDebug)
   private
     wsz : integer;
     hsz : integer;
   public
     FImgCtx : IImgCtx;
     hOK     : THandle;
     Width   : THI_Event;
     Height  : THI_Event; 
     onLoad  : THI_Event;
     procedure doLoad(var dt:TData; idx:word);
 end;

implementation

const
 CLSID_IImgCtx:TGUID = '{3050f3d6-98b5-11cf-bb82-00aa00bdce0b}';
 IID_IImgCtx:TGUID   = '{3050f3d7-98b5-11cf-bb82-00aa00bdce0b}';

procedure MyCallback(pCtx:pointer; pUserData:pointer); stdcall;
var pCls:THiAsmClass; stat:DWORD; sz:TSize; bmp:PBitmap;
begin
  pCls := THiAsmClass(pUserData);
  pCls.FImgCtx.GetStateInfo(stat, sz, 0);
  if (sz.cx * 100) div sz.cy > (pCls.wsz * 100) div pCls.hsz then begin
     bmp := NewDIBBitmap(pCls.wsz, (pCls.wsz * sz.cy) div sz.cx, pf32bit);
     bmp.PixelFormat:= pf32bit;
     pCls.FImgCtx.StretchBlt(bmp.Canvas.Handle, 0, 0, pCls.wsz, (pCls.wsz * sz.cy) div sz.cx, 0, 0, sz.cx, sz.cy, SRCCOPY);
  end
  else begin
     bmp := NewDIBBitmap((pCls.hsz * sz.cx) div sz.cy, pCls.hsz, pf32bit);
     bmp.PixelFormat:= pf32bit;
     pCls.FImgCtx.StretchBlt(bmp.Canvas.Handle, 0, 0, (pCls.hsz * sz.cx) div sz.cy, pCls.hsz, 0, 0, sz.cx, sz.cy, SRCCOPY);
  end;
  _hi_OnEvent(pCls.onLoad, bmp);
  bmp.Free;
  SetEvent(pCls.hOK);
end;

procedure THiAsmClass.doLoad;
var wName:WideString; m:TMsg;
begin
  hOK := CreateEvent(nil,false,false,nil);
  wsz := ToIntegerEvent(Width);
  hsz := ToIntegerEvent(Height);  
  if (wsz = 0) or (hsz = 0 ) then exit; 
  wName := ToString(dt);
  if not FileExists(wName) then exit;
  FImgCtx := CreateComObject(CLSID_IImgCtx) as IImgCtx;
  FImgCtx.Load(PWChar(wName), 0);
  FImgCtx.SetCallback(@MyCallback, pointer(Self));
  FImgCtx.SelectChanges(IMGCHG_COMPLETE,0,1);
  while WaitForSingleObject(hOK,0)<>WAIT_OBJECT_0 do begin
    if not GetMessage(m,0,0,0) then break;
    TranslateMessage(m);
    DispatchMessage(m);
  end;
  CloseHandle(hOK);
end;

initialization
  CoInitialize(nil);
finalization
  CoUninitialize;

end.