unit winclip;
{Funkce pro pristup ke schrance Windows z DOSovych programu Freepascalu}

interface

const
WINCLIP_FORMAT_TEXT        =1;
WINCLIP_FORMAT_BITMAP      =2;
WINCLIP_FORMAT_METAFILE    =3;
WINCLIP_FORMAT_SYLK	   =4;
WINCLIP_FORMAT_DIF	   =5;
WINCLIP_FORMAT_TIFF	   =6;
WINCLIP_FORMAT_OEMTEXT     =7;
WINCLIP_FORMAT_DIBBITMAP   =8;
WINCLIP_FORMAT_UNICODETEXT =$0D; {pres rozhrani WinOldApp asi nefunguje}
WINCLIP_FORMAT_WINWRITE    =$80;
WINCLIP_FORMAT_DSPTEXT     =$81;
WINCLIP_FORMAT_DSPBITMAP   =$82;


Winclip_inited:boolean = false;

Function Winclip_valid:boolean;
Function Winclip_version:longint;
Function Winclip_version_string:string;
Function Winclip_open:byte;
Function Winclip_emptyIT:boolean;
Function Winclip_GetSize(format:word):longint;
Function Winclip_Close:boolean;
Function Winclip_GetData(format:word;var buffer:pointer):longint;
Function Winclip_SetData(format:word;buffer:pointer;buffer_size:longint):longint;
Function Winclip_compact(size:longint):longint;

implementation
uses Go32;

const
Winclip_versupported:longint = 0;


Function Winclip_versupported_function:longint;
var r:registers;
    w:word;
begin
FillChar(r,sizeof(r),0);
r.ax:=$1700;
RealIntr($2F,r);
if r.ax=$1700 then Winclip_versupported_function:=0
   else begin
   w:=word(r.al) shl 8 + r.ah;
   Winclip_versupported_function:=w;
   end;
end;


Function Winclip_version:longint;
begin
if winclip_inited then Winclip_version:=winclip_versupported
   else begin
   winclip_inited:=true;
   Winclip_versupported:=Winclip_versupported_function;
   Winclip_version:=Winclip_versupported;
   end;
end;


Function Winclip_valid:boolean;
begin
Winclip_valid:=Winclip_version<>0;
end;


Function MyStr(a:longint):string;
var s:string;
begin
Str(a,s);
MyStr:=s;
end;


Function Winclip_version_string:string;
var l,maj,min:longint;
begin
l:=Winclip_version;
maj:=l shr 8;
min:=l and $ff;
Winclip_version_string:=mystr(maj)+'.'+mystr(min);
end;


Function Winclip_open:byte;
var r:registers;
begin
if not(winclip_valid) then Exit(0);

FillChar(r,sizeof(r),0);
r.ax:=$1701;
RealIntr($2F,r);
if r.ax<>0
   then Exit(1)    {CLIP OPENED}
   else Exit(2);   {CLIP OPENED ALREADY}
end;


Function Winclip_emptyIT:boolean;
var r:registers;
begin
if not(winclip_valid) then Exit(false);

FillChar(r,sizeof(r),0);
r.ax:=$1702;
RealIntr($2F,r);
if r.ax<>0
   then Exit(true)     {Clipboard emptied ok}
   else Exit(false);   {Failed to empty it}
end;


Function Winclip_GetSize_internal(format:word):longint;
var r:registers;
    i:longint;
begin
if not(winclip_valid) then Exit(0);

FillChar(r,sizeof(registers),0);
r.ax:=$1704;
r.dx:=format;
RealIntr($2F,r);
if (r.ax=0) and (r.dx=0) then Winclip_GetSize_internal:=0
   else begin
   i:=longint(r.dx) shl 16 + r.ax;
   Winclip_GetSize_Internal:=i;
   end;
end;


Function Winclip_GetSize(format:word):longint;
begin
if WinClip_Open<>0
   then Winclip_GetSize:=Winclip_GetSize_Internal(format)
   else Winclip_GetSize:=0;
Winclip_Close;
end;


Function Winclip_Close:boolean;
var r:registers;
    i:longint;
begin
if not(winclip_valid) then Exit(false);

FillChar(r,sizeof(r),0);
r.ax:=$1708;
RealIntr($2F,r);
if r.ax<>0 then Winclip_Close:=true     {Clipboard closed ok}
           else Winclip_Close:=false;   {Failed to close it}

end;



Function Winclip_GetData_internal(format:word;buffer:pointer;buffer_size:longint):longint;
var clipsize:longint;
    lowmemptr:longint;
    selector,segment:word;
    r:registers;

begin
clipsize:=Winclip_getsize_internal(format);
{Get clipboard size - fail if this fails, or the supplied buffer is too small}

if clipsize=0 then Exit(-1);
if clipsize<buffer_size then Exit(-2);

{Allocate a buffer for the library}
LowMemPtr:= Global_DOS_Alloc(clipsize);     {DOS block allocation}
if lowmemptr=0 then Exit(-3);

selector:=word(lowmemptr);
segment:=word(lowmemptr shr 16);

FillChar(r,sizeof(r),0);

r.ax:=$1705;
r.dx:=format;
r.es:=segment;
r.bx:=0;        {Already done by memset anyway, but do it again}
RealIntr($2F,r);

{Success?}
if r.ax=0 then begin Global_DOS_free(selector);Exit(-4);end;

{Copy the data & free the DOS memory}
DOSMemGet(segment,0,buffer^,clipsize);
Global_DOS_free(selector);
Winclip_GetData_internal:=clipsize;
end;


Function Winclip_GetData(format:word;var buffer:pointer):longint;
var a,b:longint;
begin
buffer:=nil;
a:=Winclip_Getsize(format);
if a=0 then Winclip_GetData:=-1
   else begin
   Winclip_Open;
   GetMem(buffer,a);
   b:=Winclip_GetData_internal(format,buffer,a);
   if b<=0 then
      begin
      FreeMem(buffer,a);
      buffer:=nil;
      a:=b;
      end;
   Winclip_Close;
   Winclip_GetData:=a;
   end;
end;


Function Winclip_SetData(format:word;buffer:pointer;buffer_size:longint):longint;
var lowmemptr:longint;
    selector,segment:word;
    r:registers;

begin
if not(winclip_valid) then Exit(-1);
{Allocate a buffer for the library}
LowMemPtr:= Global_DOS_Alloc(buffer_size);     {DOS block allocation}
if lowmemptr=0 then Exit(-2);

selector:=word(lowmemptr);
segment:=word(lowmemptr shr 16);

DOSMemPut(segment,0,buffer^,buffer_size);

FillChar(r,sizeof(r),0);

r.ax:=$1703;
r.dx:=format;
r.es:=segment;
r.bx:=0;        {Already done by memset anyway, but do it again}
r.si:=buffer_size shr 16;
r.cx:=buffer_size and $FFFF;
RealIntr($2F,r);
Global_DOS_free(selector);        {Free the DOS memory}

{Success?}
if r.ax=0
   then Winclip_SetData:=-2
   else Winclip_SetData:=0;
end;


Function Winclip_compact(size:longint):longint;
{I'm not entirely sure what's meant by "compacting" the clipboard, but I
   think it discovers whether the clipboard is the size wanted. I.e. you call
   with desired size in bytes, and it returns the actual size in bytes.}

var r:registers;
    i:longint;
begin
if not(winclip_valid) then Exit(-1);
FillChar(r,sizeof(r),0);  {Perform the call}
r.ax:=$1709;
r.si:=size shr 16;
r.cx:=size and $FFFF;
RealIntr($2F,r);

{Return the size of the largest block free}
i:=longint(r.dx shl 16)+r.ax;
WinClip_compact:=i;
end;

end.
