Source file: /~heha/vt/viewers/vt080.zip/src/VTGRABW.PAS

program VTGrabW;
uses WinProcs,WinTypes,Win31,WinCRT,WUtils;

function VGInit:Boolean; external;
procedure VGRun; external;
procedure VGDone; external;
{$L VTGrab}
const
 MyTimer:Word=0;

procedure TimerProc(w,m,i: Integer; time:LongInt); export;
 begin
  Inc(MyTimer);
 end;

function ShortYield:Boolean;
 var
  Msg:TMsg;
 begin
  ShortYield:=true;
  if PeekMessage(Msg,0,0,0,PM_Remove) then begin
   if Msg.message=WM_KeyDown then begin
    ShortYield:=false;
   end;
   TranslateMessage(Msg);
   DispatchMessage(Msg);
  end;
 end;

{Auf den Schirm: Tabelle mit 4 Spalten, Akquisitor-Arbeiten anzeigen}
{Für jeden Akq. bleiben 18 Zeichen Platz für Text}
var
 acqcursor: array[0..4] of TPoint;	{in Bildschirmkoordinaten}

procedure Message(acq:Integer; Msg:PChar; New:Word);
{acq = 0..3 Akquisitor-Nummer, New Bit 0=1: neue Zeile anfangen,
 New Bit 1=1: Gleiche Zeile von vorn}
 begin
  asm pusha; push es; shr [acq],8 end;
  with acqcursor[acq] do begin
   if New and 3 <>0 then x:=acq*20;
   if New and 1 <>0 then begin
    CursorTo(x,y);
    Write(' ');			{Zeiger-Sternchen wegnehmen}
    y:=(y+1)mod 24;		{Neue Zeile, notfalls oben anfangen}
   end;
   CursorTo(x,y);		{bei gespeicherter Position fortsetzen}
   if New and 3 <>0 then begin
    Write('*                   '); {Zeiger-Sternchen setzen, Zeile löschen}
    CursorTo(x+1,y);
   end;
   Write(Msg);
   acqcursor[acq]:=Cursor;	{Position speichern}
   if x=0 then Dec(y);		{Zeilenumbruch abschalten}
  end;
  asm pop es; popa end;
 end;

procedure MessageStat(Msg:PChar; New:Boolean);
{New=true: neue Zeile anfangen}
 begin
  asm pusha; push es end;
  with acqcursor[4] do begin
   y:=24;			{y initialisieren}
   if New then begin
    x:=0;
    CursorTo(x,y);
    ClrEol;			{Zeile komplett löschen}
   end else CursorTo(x,y);	{bei gespeicherter Position fortsetzen}
   Write(Msg);
   acqcursor[4]:=Cursor;	{Position speichern}
   Write(' ');			{Luft zum alten Text lassen}
   if x>75 then x:=0;		{Statuszeile sollte kein Scrollen auslösen}
  end;
  asm pop es; popa end;
 end;

var
 hTimer: Word;
 i: Integer;
{$Q-,R-}

begin
 lstrcpy(WindowTitle,'VTGrabW');
 WindowOrg.x:=10; WindowOrg.y:=10;
 WindowSize.x:=10000; WindowSize.y:=10000; {verkleinert Windows sowieso}
 AutoTracking:=false;
 if not VGInit then halt;
 WriteLn;
 hTimer:=SetTimer(0,0,54,@TimerProc);
 if hTimer=0 then WriteLn('Kann Timer nicht anfordern!')
 else begin
  WriteLn('=== Drⁿcke Taste fuer Abbruch! ===');
  for i:=0 to 3 do acqcursor[i].y:=6;
  Message($000,'Acq0 (sammelt)',1);
  Message($100,'Acq1 (sammelt)',1);
  Message($200,'Acq2 (sammelt)',1);
  Message($300,'Acq3 (testet)',1);	{Sternchen plazieren}
  repeat VGRun until ShortYield=false;
  KillTimer(0,hTimer);
 end;
 for i:=23 downto 15 do begin
  CursorTo(0,i);
  ClrEol;
 end;
 WriteLn;
 VGDone;
end.