ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/GRAPHICS/MISC/POSTOGRF.ZIP/EXTRAMEN.INC

Text File | 1990-05-31 | 5.6 KB | 154 lines

{ ExtraMen.inc include file for Postogrf
  14 Dec 89
}

procedure ExtraMenu;
const HelpStr =
'F1 expand    F2 contract    F5 rotate label           F10 VG Format';

   { -------------------------------------------------------------------
      Draw box centered at screen center + (x,y).
      Expand.ScrnW, Expand.ScrnH.  The size equals the (scaled down) size
      that the screen will have AFTER this expansion operation is
      completed.  x, y are actual screen coordinates.
     ------------------------------------------------------------------- }
   Procedure CenterBox(x,y:integer);
   var x1, x2, y1, y2, tSF: integer;
   begin
      if VidCol = color then SetColor(yellow) else SetColor(white);
      with Expand do begin
         x1 := x + GetMaxX div 4;
         y1 := y + GetMaxY div 4;
         x2 := x1 + GetMaxX div 2;
         y2 := y1 + GetMaxY div 2;
       end;
      Rectangle( x1, y1, x2, y2);
   end;

  { ------------------------------------------------------------------
     Show crosshairs, move them with cursor keys, to select new center
     for expansion of view.  User quits with <ESC> or <CR>.
     Return false if user exited by <ESC>, true otherwise.
     Changes Expand.XCent, Expand.YCent.
    ------------------------------------------------------------------ }
   function NewCenter: boolean;
   const HelpStr =
       'move crosshairs to new viewpoint.  <ENTER> to change, <ESC> to quit';
   var tcolor: word;
       tx, ty, offset: integer;
       key: char;
       moving: boolean;
   begin
     clrscr;
     Write(HelpStr);
     offset := 0;
     with Expand do begin
        tx := 0;
        ty := 0;
        SetWriteMode(XorPut);
        CenterBox(tx, ty);            {show box - the 1st time}
        repeat
           key := readkey;
           moving := false;
           if key = #0 then repeat
               if not moving then key := readkey;
               CenterBox(tx, ty);     {erase box}
               case key of      {function keys}
                  RightArrow: begin inc(tx);
                               end;
                  LeftArrow: begin dec(tx);
                               end;
                  UpArrow: begin dec(ty);
                              end;
                  DownArrow: begin inc(ty);
                              end;
        (* CNTRL -> *) #116: tx := tx + 10;
        (* CNTRL <- *) #115: tx := tx - 10;
        (* page up  *) #73 : ty := ty - 10;
       (* page down *) #81 : ty := ty + 10;
                      Home : begin
                                tx := 0; ty := 0;
                              end;
                end; {case}
               CenterBox(tx, ty);              {show box in new place}
               if keypressed then begin
                  repeat key := readkey; until (not keypressed) ;
                  moving := true;
                end else begin
                  delay(50);
                  if keypressed then begin
                      key := readkey; moving := true;
                   end else moving := false;
                 end;
            until not moving ;
         until (key = ESC) or (key = CR);
        CenterBox(tx, ty);                       {kill box for final time}
        SetWriteMode(CopyPut);
         if key = CR then begin
            XCent := XCent + tx div SF;
            YCent := YCent + ty div SF;
            NewCenter := true;
          end else NewCenter := false;
      end; {with Expand do...}
   end; {NewCenter}

begin
   clrscr;
   Write(HelpStr);
   repeat key := readkey;
   until (key = #0) or (key = ESC) or (key = CR);
   if key = #0 then key := readkey;
   with Expand do
   case key of      {function keys}
        PF1: if NewCenter then begin
                   clrscr;
                   SF := SF * 2;
                   ScrnW := ScrnW div 2; ScrnH := ScrnH div 2;
                   ClearViewPort; RePaint;
                 end;
        PF2: if SF > 1 then begin
                  clrscr;
                  SF := SF div 2;
                  ScrnW := ScrnW * 2;
                  ScrnH := ScrnH * 2;
                  ClearViewPort; RePaint;
               end else begin
                  clrscr;
                  Sf := 1;
                  Xcent := GetMaxX div 2; Ycent := GetMaxY div 2;
                  ScrnW := GetMaxX div 2;
                  ScrnH := GetMaxY div 2;
                  ClearViewPort; Repaint;
                end;
        PF5:  begin
                  if select = nil then exit;
                  select^ := tempText;
                  ShowLabel(select, black);
                  UnBoxLabel(select);
                  ChangeDirection(select);
                  tempText := select^;
                  HighLight(select);
               end;
        PF10: begin LCOnfig.DoBar := not Lconfig.DOBar;
                  if not noshow then begin
                       {SetWriteMode(XORPut);}
                       SetWriteMode(copyput);
                       setcolor(black);
                       ShowCopyBlock;
                       if vidcol = color then SetColor(yellow);
                   end;
                   SetWriteMode(CopyPut);
                   VGFormat;
                   SetCopyBlockDef;
                   noshow := false;
                   {SetWriteMode(XORPut);}
                   if vidcol = color then setcolor(yellow);
                   ShowCopyBLock;
                   SetWriteMode(CopyPut);
                   setcolor(white);
                   saved := false;
               end;
     end; {case}
     key := #0;
end;