Current area: HOME ->

Zip File view

An Icons Editor


This page allows you to view the contents of a file contained inside a ZIP archive available at Programmer's Heaven. This means you can view the code and find what you need from it without having to download the ZIP file first. If the file contains source code for a language we recognize, we have syntax highlighted it.

Filename displayed: WIN95BTN.PAS
Found in file: 48194.zip

Download: wodSSHTunnel 1.6.0 wodSSHTunnel component is server-type component that will add secure tunneling (based on SSH protocol) capabilities to your application. Based on your rules and definitions, it will accept local conn...
unit Win95btn;

interface
  uses Mouse,Graph,Crt;

var
 SD : integer;


const
  maxicobuffsize = 30;
  OSStyle = 43690;

Type

  TMButton  = record
               X,Y,X1,Y1 : integer;
             end;

  TItem1 = record
             B,B2     : TMButton;
             px,py    : integer;
             Ico      : string[12];
             str      : string[80];
             Command  : string;
           end;


  String12 = string[12];
  TitemsP = ^TItems;
  ItemType = record
                X,Y,X1,Y1 : integer;
                S         : String;
                ConT      : Boolean;
                Next      : TItemsP;
             end;


  TItems  = record
               IT    : Array[1..30] of ItemType;
               Count : integer;
               ID    : integer;
              end;
  TButton  = record
               X,Y,X1,Y1 : integer;
               Name      : string;
               Iconfile  : string12;
               IconNum   : Integer;
             end;


  TMRType  = record {TMenu Result Type}
               X,Y : integer;
               ifKey : boolean;
               ifc0  : boolean;
               Key   : Char;
               S     : String;
             end;

  IconType = record
               data : array[1..32,1..32] of Byte;
               mask : array[1..32,1..32] of boolean;
             end;
  Icoinlist = record
                I : IconType;
                D : String;
              end;

  IconsBuff = Object
                NumIcons : byte;
                D        : Array[1..maxicobuffsize] of ^Icoinlist;
                Function  loadico(fname : string) : byte;
                Procedure Init;
              end;

  TIconSize = (R16x16, R32x32);

  TTSingleChr = record
                  Btmp  : Array[1..13,1..13] of boolean;
                  Width : byte;
                end;

  TTFont      = Array[1..94] of TTSingleChr;

var
 Font   : TTFont;


var
 SysIBuf : IconsBuff;

Procedure LoadYTF(fn : string);
Procedure YOutText(s : string);
Procedure YOutTextB(s : string);
Function YTextHeight(s : string) : integer;
Function YTextWidth(s : string) : integer;
{-------------------------------------------------------------------------}
Procedure WButton(x,y,px1,py1 : integer; text : string; Pushed : boolean);
Procedure WButton2(x,y,x1,y1 : integer);
Procedure WinFace(X,Y,X1,Y1 : integer);
Procedure WStatusLine(x,y,x1,y1 : integer);
Procedure DrawX(x,y,x1,y1 : integer; Param : byte);
Procedure WWindow(x,y,x1,y1 : integer; Title : string);
Procedure QMWin(x,y,x1,y1 : integer; Title : string);
Procedure QMButton(x,y,px1,py1 : integer; text : string; Pushed, Def : boolean);
Procedure PerformMenuItems(Items : TItems; ifLeft : boolean; x,y : integer;
                            var R : TMRType; Sy : integer);
Procedure LoadYCO(FN : String; var YCO : IconType);
Procedure Load_Icon(x,y : integer; Fname : string; Size : TIconSize);
Procedure Draw_ListItem(x,y : integer; Text : String; Ico : IconType);
Procedure ShowYCO(x,y : integer; icon1 : IconType; Size : TIconSize);
Procedure InitItem(var I : TItem1; S : String; px,py : integer; ico : string);
Procedure ShowItem(I : TItem1; mesuman : boolean);
{----------------------- Menu Init Procedures ---------------------------}
Procedure MakeFileMenu(var T : TItemsP);
Procedure MakeEditMenu(var T : TItemsP);

implementation

Procedure UpCaseStr(var S:String);
var
 I:integer;
Begin
   for i := 1 to Length(S) do S[i] := UpCase(S[i]);
End;

Procedure LoadYTF(fn : string);
var
 f : file of TTFont;
begin
   Assign(f,fn);
   Reset(f);
   Read(f,Font);
   close(f);
end;

Procedure PutCh(Ch : char);
var
 b : byte;
 x,y,c : integer;
 i,j   : integer;
begin
   b := ord(ch);
   b := b-31;
   x := getx;
   y := gety;
   c := GetColor;
   HideMouse;
   for j := 1 to 13 do
    for i := 1 to Font[b].Width do
     if Font[b].btmp[j,i] then
       PutPixel(x+i-1,y+j-1,c);

   MoveTo(x+Font[b].Width,y);
   ShowMouse;
end;

Procedure YOutText(s : string);
var
 i : integer;
begin
   for i := 1 to length(s) do
    PutCh(s[i]);
end;

Function YTextHeight(s : string) : integer;
begin
   YTextHeight := 13;
end;

Function YTextWidth(s : string) : integer;
var
 x,y,i,w,b : integer;
begin
   x:=getx+1;
   y:=gety;
   w:=0;
   for i := 1 to length(s) do
   begin
      b:=ord(s[i]);
      b:=b-31;
      w:=w+font[b].width;
   end;
   YTextWidth := w;
end;

Procedure YOutTextB(s : string);
var
 x,y,i : integer;
begin
   x:=getx+1;
   y:=gety;
   for i := 1 to length(s) do
   begin
      PutCh(s[i]);
      moveto(getx+1,gety);
   end;
   MoveTo(x,y);
   for i := 1 to length(s) do
   begin
      PutCh(s[i]);
      moveto(getx+1,gety);
   end;
end;

Procedure WButton(x,y,px1,py1 : integer; text : string; Pushed : boolean);
var
 X1, Y1 : integer;
begin
   HideMouse;
   X1 := px1;
   Y1 := py1;
   setcolor(15);
   if not Pushed then
   begin
      SetColor(0);
      SetFillStyle(1,7);
      Bar(x,y,x1,y1);
      Rectangle(x,y,x1,y1);
      SetColor(3);
      Line(x+1,y+1,x1-2,y+1);
      Line(x+1,y+1,x+1,y1-2);
      SetColor(15);
      Line(x,y,x1-1,y);
      Line(x,y,x,y1-1);
      SetColor(8);
      Line(x+1,y1-1,x1-1,y1-1);
      Line(x1-1,y+1,x1-1,y1-1);
  {    SetTextStyle(DefaultFont, HorizDir, 1);}
      MoveTo(X+11,((Y+Y1) div 2)-(YTextHeight(text) div 2)-1);
      setcolor(0);
      YOutText(text);
   end
  else
   begin
      SetColor(15);
      SetFillStyle(1,7);
      Bar(x,y,x1,y1);
      Rectangle(x,y,x1,y1);
      SetColor(8);
      Line(x+1,y+1,x1-2,y+1);
      Line(x+1,y+1,x+1,y1-2);
      SetColor(0);
      Line(x,y,x1-1,y);
      Line(x,y,x,y1-1);
      {SetTextStyle(DefaultFont, HorizDir, 1);}
      MoveTo(X+11,((Y+Y1) div 2)-(TextHeight(text) div 2)+1);
      setcolor(0);
      YOutText(text);
   end;
   ShowMouse;
end;

Procedure QMButton(x,y,px1,py1 : integer; text : string; Pushed, Def : boolean);
var
 X1, Y1 : integer;
begin
   HideMouse;
   X1 := px1;
   Y1 := py1;
   setcolor(15);
   if not Pushed then
   begin
      SetColor(0);
      SetFillStyle(1,7);
      Bar(x,y,x1,y1);
      Rectangle(x,y,x1,y1);
      SetColor(15);
      Line(x+1,y+1,x1-2,y+1);
      Line(x+1,y+1,x+1,y1-2);
      SetColor(8);
      Line(x+1,y1-1,x1-1,y1-1);
      Line(x1-1,y+1,x1-1,y1-1);
      SetTextStyle(DefaultFont, HorizDir, 1);
      MoveTo(X+11,((Y+Y1) div 2)-(TextHeight(text) div 2)+3);
      setcolor(0);
      OutText(text);
      MoveTo(X+10,((Y+Y1) div 2)-(TextHeight(text) div 2)+2);
      setcolor(15);
      OutText(text);
   end
  else
   begin
      SetColor(0);
      SetFillStyle(1,7);
      Bar(x,y,x1,y1);
      Rectangle(x,y,x1,y1);
      SetColor(8);
      Line(x+1,y+1,x1-1,y+1);
      Line(x+1,y+1,x+1,y1-1);
      SetColor(15);
      Line(x+2,y1-1,x1-2,y1-1);
      Line(x1-1,y+2,x1-1,y1-1);
      SetTextStyle(DefaultFont, HorizDir, 1);
      MoveTo(X+11,((Y+Y1) div 2)-(TextHeight(text) div 2)+4);
      setcolor(15);
      OutText(text);
      MoveTo(X+10,((Y+Y1) div 2)-(TextHeight(text) div 2)+3);
      setcolor(0);
      OutText(text);
   end;
   if Def then
   begin
      SetColor(0);
      Rectangle(x-1,y-1,x1+1,y1+1);
   end
  else
   begin
      SetColor(7);
      Rectangle(x-1,y-1,x1+1,y1+1);
   end;
   ShowMouse;
end;


Procedure WButton2(x,y,x1,y1 : integer);
begin
   HideMouse;
   SetColor(0);
   SetFillStyle(1,7);
   Bar(x,y,x1,y1);
   Rectangle(x,y,x1,y1);
   SetColor(7);
   Line(x,y,x1-1,y);
   Line(x,y,x,y1-1);
   SetColor(15);
   Line(x+1,y+1,x1-2,y+1);
   Line(x+1,y+1,x+1,y1-2);
   SetColor(8);
   Line(x+1,y1-1,x1-1,y1-1);
   Line(x1-1,y1-1,x1-1,y+1);
   ShowMouse;
end;

Procedure WinFace(X,Y,X1,Y1 : integer);
begin
   HideMouse;
   SetFillStyle(1,15);
   Bar(x,y,x1,y1);
   SetColor(8);
   Line(x,y,x1-1,y);
   Line(x,y,x,y1-1);
   SetColor(0);
   Line(x+1,y+1,x1-2,y+1);
   Line(x+1,y+1,x+1,y1-2);
   SetColor(7);
   Line(x+1,y1-1,x1-1,y1-1);
   Line(x1-1,y1-1,x1-1,y+1);
   ShowMouse;
end;

Procedure WStatusLine(x,y,x1,y1 : integer);
begin
   SetFillStyle(1,7);
   Bar(x,y,x1,y1);
   SetColor(8);
   Line(x,y,x1-1,y);
   Line(x,y,x,y1-1);
   SetColor(15);
   Line(x,y1,x1,y1);
   Line(x1,y1,x1,y);
   Bar(x1-18, y, x1, y1);
   SetColor(8);
   Line(x1-17,y1,x1,y);
   Line(x1-15,y1,x1,y+2);
   Line(x1-13,y1,x1,y+4);
   Line(x1-11,y1,x1,y+6);
   Line(x1-9,y1,x1,y+8);
   Line(x1-7,y1,x1,y+10);
   Line(x1-5,y1,x1,y+12);
   Line(x1-3,y1,x1,y+14);
   Line(x1-1,y1,x1,y+16);
   SetColor(15);
   Line(x1-16,y1,x1,y+1);
   Line(x1-14,y1,x1,y+3);
   Line(x1-12,y1,x1,y+5);
   Line(x1-10,y1,x1,y+7);
   Line(x1-8,y1,x1,y+9);
   Line(x1-6,y1,x1,y+11);
   Line(x1-4,y1,x1,y+13);
   Line(x1-2,y1,x1,y+15);
end;

Procedure DrawX(X,Y, X1,Y1 : integer; Param : byte);
begin
   setcolor(0);
   case Param of

       1 : begin
              Line(x1-17,y+6,x1-9,y+14);
              Line(x1-17,y+7,x1-9,y+15);
              Line(x1-17,y+14,x1-8,y+6);
              Line(x1-17,y+15,x1-8,y+7);
           end;

       2 : begin
              Rectangle(x1-39,y+6,x1-27,y+15);
              Line(x1-39,y+7,x1-27,y+7); Line(x1-39,y+8,x1-27,y+8);
           end;

       3 : begin
              Line(x1-56,y+15,x1-47,y+15); Line(x1-56,y+14,x1-47,y+14);
           end;
   end;
end;

Procedure WWindow(x,y,x1,y1 : integer; Title : string);
begin
  HideMouse;
  WButton2(x,y,x1,y1);
  SetFillStyle(1,Blue);
  Bar(x+3,y+3,x1-3,y+3+17);
  WButton(x1-21,y+4,x1-21+17,y+4+14,'',False);
  DrawX(X,Y,X1,Y1,1);
  WButton(x1-41,y+4,x1-41+17,y+4+14,'',False);
  DrawX(X,Y,X1,Y1,2);
  WButton(x1-59,y+4,x1-59+17,y+4+14,'',False);
  DrawX(X,Y,X1,Y1,3);
  setcolor(15);
  settextstyle(0,0,1);
  MoveTo(x+7,y+6);
  YOutTextB(title);
  ShowMouse;
end;

Procedure QMWin(x,y,x1,y1 : integer; Title : string);
begin
  HideMouse;
  SetFillStyle(1,0);
  Bar(x,y,x1,y1);
  SetColor(0);
  Rectangle(x,y,x1,y1);
  Rectangle(x+10,y+10,x1-10,y1-10);
  setcolor(15);
  Rectangle(x+1,y+1,x1-1,y1-1);
  Rectangle(x+9,y+9,x1-9,y1-9);
  SetFillStyle(1,3);
  FloodFill(x+5,y+5,15);
  SetColor(8);
  Rectangle(x+1,y+1,x1-1,y1-1);
  Rectangle(x+9,y+9,x1-9,y1-9);
  SetColor(15);
  Line(x+1,y+1,x+1,y1-1);
  Line(x+1,y1-1,x1-1,y1-1);
  Line(x+9,y+9,x1-9,y+9);
  Line(x1-9,y+9,x1-9,y1-9);
  PutPixel(x+1,y+1,7);
  PutPixel(x1-1,y1-1,7);
  PutPixel(x+9,y+9,7);
  PutPixel(x1-9,y1-9,7);
  SetFillStyle(1,7);
  Bar(x+11,y+11,x1-11,y1-11);
  SetFillStyle(1,Yellow);
  WButton(x+10,y+10,x1-10,y+29,title,False);
  ShowMouse;
end;


Procedure PerformMenuItems(Items : TItems; ifLeft : boolean; x,y : integer;var R : TMRType; Sy : integer);
var
 P        : Pointer;
 Size     : integer;
 I        : integer;
 L,ly     : integer;
 Saman    : integer;
 Mlx, Mly : integer;
 RR       : TMRType;
 ButtonDn : boolean;
 Mpressed : Boolean;

Procedure DrawItem(Index : integer; Selected : Boolean);
begin
   if not ((Index >= 1) and (index <= Items.Count)) then Exit;
   HideMouse;
   if Items.IT[index].S = '-' then
   begin
      setcolor(0);
      with Items.IT[index] do
        Line(x-6,y+3,x1+6,y+3);

      setcolor(15);
       with Items.IT[index] do
         Line(x-6,y+4,x1+6,y+4);
   end
  else
   begin
      if Selected then
      begin
         SetFillStyle(1,Blue);
         SetColor(15);
      end
     else
      begin
         SetFillStyle(1,7);
         SetColor(0);
      end;

      with Items.IT[index] do
        Bar(X-7,Y,X1+7,Y1);

      moveto(Items.IT[Index].X+2,Items.IT[Index].Y+2);
      YOutText(Items.IT[Index].S);
   end;
   ShowMouse;
end;

var
 Ex : boolean;
 CC : boolean;
Procedure CheckContinewate;
begin
   cc := false;
   if not ((Saman > 0) and (Saman <= Items.Count)) then Exit;
   if Items.it[Saman].Cont then
   Begin
      cc := true;
      inc(r.x);
      PerformMenuitems(Items.it[saman].Next^,False,x+L,Items.it[saman].y,r,Items.it[saman].y1);
      if r.y <= 0 then
      begin
         Dec(r.x);
         MPressed := False;
         ButtonDn := False;
      end
      else
       begin
          Ex := True;
          Exit;
       end;
   end;
end;

Procedure CheckItems;
var
 i      : integer;
 SamanP : integer;

begin
   SamanP := 0;
   for i := 1 to Items.Count do
   begin
      with Items.IT[i] do
      begin
         if (X <= GetMouseX) and ((X1+6) >= GetMouseX) and
            (Y <= GetMouseY) and (Y1 >= GetMouseY) then
            begin
               SamanP := i;
            end;
      end;
   end;
   if SamanP = Saman then Exit;
   if (SamanP = 0) and (Saman = 0) then Exit;
   if SamanP = 0 then
   begin
      DrawItem(Saman,False);
      Saman := 0;
      Exit;
   end;
   if saman <> 0 then DrawItem(Saman,False);
   DrawItem(SamanP,True);
   Saman := SamanP;
   CheckContinewate;
end;

var
 LLy : integer;
 Ch  : Char;
 LastSaman : integer;
 B         : TMButton;
 mx,my     : integer;
begin
   r.ifkey := False;
   r.Key := ' ';
   Mlx := GetMouseX; Mly := GetMouseY;
   ButtonDn := false;
   MPressed := False;
   Saman := 0;
   if r.x > 0 then
      Saman := 1;
   ex := false;
   SetColor(0);
   L := 0;
   Ly := 0;
   for i := 1 to Items.Count do
   begin
      if YTextWidth(Items.IT[i].S) > L then
        L := YTextWidth(Items.IT[i].S);

      if Items.IT[i].S = '-' then
      begin
         Inc(Ly,10);
      end
     else
      Inc(Ly,YTextHeight(Items.IT[i].S)+5);
   end;
   Inc(L,20);
   Inc(Ly,1);
   SetColor(0);
   LLy := y+3;
   for i := 1 to Items.Count do
   begin
      if Items.IT[i].S <> '-' then
      begin
         Items.IT[i].X := x+10;
         Items.IT[i].Y := LLy;
         Items.IT[i].X1 := Items.IT[i].X + L-20;
         Items.IT[i].Y1 := Items.IT[i].Y + YTextHeight('H')+3;
         LLy := Items.IT[i].Y1 + 1;
      end
     else
      begin
         Items.IT[i].X := x+10;
         Items.IT[i].Y := LLy;
         Items.IT[i].X1 := Items.IT[i].X + L-20;
         Items.IT[i].Y1 := Items.IT[i].Y +5;
         LLy := LLy+10;
      end;
   end;

   Size := ImageSize(x,y,x+L,Items.IT[Items.Count].Y1+3);
   GetMem(P, size);
   HideMouse;
   GetImage(x,y,x+L,Items.IT[Items.Count].Y1+3, P^);
   ShowMouse;
   WButton2(x,y,x+L,Items.IT[Items.Count].Y1+3);
   B.X := x;
   B.Y := y;
   B.X1 := x+l;
   B.Y1 := Items.IT[Items.Count].Y1+3;

   for i := 1 to Items.Count do
   begin
      DrawItem(i, False);
      if I = Saman then DrawItem(i, True);
   end;

   Repeat
      if (Mlx <> GetMouseX) or (Mly <> GetMouseY) then
      begin
         Mlx := GetMouseX;
         Mly := GetMouseY;
         CheckItems;
         if r.x > 0 then
         begin
            if (Mlx < x) and ((Mly < y) or (Mly > Sy)) then
            begin
               HideMouse;
               PutImage(x,y,P^,NormalPut);
               FreeMem(P,Size);
               ShowMouse;
               r.y := 0;
               Exit;
            end;
         end;
      end;

      if KeyPressed then
      begin
         LastSaman := Saman;
         Ch := Readkey;
         if Ch = #0 then
         begin
            Ch := Readkey;
            case ch of

               #72 : begin
                        if Saman > 1 then
                        begin
                           Dec(Saman);
                           if Items.IT[Saman].S = '-' then
                           begin
                              if Saman > 1 then
                                Dec(Saman)
                               else
                                Saman := Items.Count;
                           end;
                        end
                       else
                        Saman := Items.Count;
                     end; {UP}

               #80 : begin
                        if Saman < Items.Count then
                        begin
                           Inc(Saman);
                           if Items.IT[Saman].S = '-' then
                           begin
                              if Saman < Items.Count then
                                Inc(Saman)
                               else
                                Saman := 1;
                           end;
                        end
                       else
                        Saman := 1;
                     end;{Down}

               #77 : begin
                        CheckContinewate;
                        if (not cc) and (ifleft) then
                        begin
                           r.ifkey := true;
                           r.key := 'l';
                           Ex := true;
                        end;
                     end;{Right}

               #75 : begin{Left}
                        if r.x > 0 then Ex := true;
                        if ifLeft then
                        begin
                           r.ifkey := true;
                           r.Key := 'r';
                           Ex := true;
                        end;
                     end;
              {72, 80, 77, 75}
            end;
         end
        else
         begin
            case Ch of

                #13 : begin
                         if ((Saman > 0) and (Saman <= Items.Count)) then
                         begin
                            if (Items.IT[Saman].S <> '-') then
                              if (not Items.IT[Saman].ConT)
                                then
                                 begin
                                    r.y := Saman;
                                    R.S := Items.it[Saman].s;
                                    Ex := True;
                                 end
                                else CheckContinewate;

                         end;
                      end;{Enter}

                #27 : begin
                         Ex := true
                      end

            end;
         end;
         if Saman <> LastSaman then
         Begin
            DrawItem(LastSaman,False);
            DrawItem(Saman,True);
         end;
      end;

      if ((mouse.ButtonDown)) and (not MPressed) then
      begin
         mx := GetMouseX;
         my := GetMouseY;
         if not((mx >= b.x) and (mx <= b.x1) and
                (my >= b.y) and (my <= b.y1)) then
                begin
                   HideMouse;
                   PutImage(x,y,P^,NormalPut);