sxskinutils.pas

skin components for design of your applicastions

function GetRelativePath(Main,Changeable:String):String;  //Creates Link from Main to Changeable
var SS,S1,S2:String;
         A,B:Integer;
begin
 SS:=Changeable;
 try
  if not PathIsRelative(SS) then
   begin
    A:=Pos('://',Main);
    B:=Pos('://',Changeable);
    if (A<>0) and (A=B) then
     begin
      Delete(Main,1,A+2);
      Delete(Changeable,1,A+2);
      //Comparison of Servers
      A:=Pos('/',Main);
      if A=0 then
       begin
        S1:=Main;
        Main:='';
       end else
        begin
         S1:=Copy(Main,1,A-1);
         Delete(Main,1,A);
        end;
      A:=Pos('/',Changeable);
      if A=0 then
       begin
        S2:=Changeable;
        Changeable:='/';
       end else
        begin
         S2:=Copy(Changeable,1,A-1);
         Delete(Changeable,1,A);
        end;
      if S1<>S2 then exit; //Servers are Different
      if Main='' then  //Main is Server Root
       begin
        SS:=Changeable;
        exit;
       end;
      repeat
       A:=Pos('/',Main);
       B:=Pos('/',Changeable);
       if (A<>0) and (B<>0) then
        begin
         S1:=Copy(Main,1,A-1);
         S2:=Copy(Changeable,1,B-1);
         if S1<>S2 then break else
          begin
           Delete(Main,1,A);
           Delete(Changeable,1,A);
          end;
        end;
      until (A=0) or (B=0);
      if A=0 then
       begin
        SS:=Changeable;
        exit;
       end;
      //B=0 or S1<>S2
      SS:='';
      repeat
       A:=Pos('/',Main);
       if A<>0 then
        begin
         SS:=SS+'../';
         Delete(Main,1,A);
        end;
      until A=0;
      SS:=SS+Changeable;
      exit;
     end else
      if A<>B then exit;  //Different Protos
    A:=Pos(':\',Main);
    B:=Pos(':\',Changeable);
    if (A<>0) and (A=B) then
     begin
      if SameText(Copy(Main,1,A-1),Copy(Changeable,1,A-1)) then
       begin
        Delete(Main,1,A+1);
        Delete(Changeable,1,A+1);
        if Main='' then  //Main is Drive Root
         begin
          SS:=Changeable;
          exit;
         end;
        repeat
         A:=Pos('\',Main);
         B:=Pos('\',Changeable);
         if (A<>0) and (B<>0) then
          begin
           S1:=Copy(Main,1,A-1);
           S2:=Copy(Changeable,1,B-1);
           if S1<>S2 then break else
            begin
             Delete(Main,1,A);
             Delete(Changeable,1,A);
            end;
          end;
        until (A=0) or (B=0);
        if A=0 then
         begin
          SS:=Changeable;
          exit;
         end;
        //B=0 or S1<>S2
        SS:='';
        repeat
         A:=Pos('\',Main);
         if A<>0 then
          begin
           SS:=SS+'..\';
           Delete(Main,1,A);
          end;
        until A=0;
        SS:=SS+Changeable;
        exit;
       end else Result:=Changeable;
     end else
      if A<>B then exit;  //Different Drives
   end;
 finally
  Result:=SS;
 end;
end;

procedure SetComponentEnabled(A:TWinControl;C:Boolean);
var B:Integer;
begin
 A.Enabled:=C;
 for B:=0 to A.ControlCount-1 do
  if A.Controls[B] is TWinControl then
   SetComponentEnabled(A.Controls[B] as TWinControl,C) else
    A.Controls[B].Enabled:=C;
end;

procedure Save8Flags(Stream:TStream;F1,F2,F3,F4,F5,F6,F7,F8:Boolean);
var B:Byte;
begin
 B:=0;
 if F1 then B:=B or $01;
 if F2 then B:=B or $02;
 if F3 then B:=B or $04;
 if F4 then B:=B or $08;
 if F5 then B:=B or $10;
 if F6 then B:=B or $20;
 if F7 then B:=B or $40;
 if F8 then B:=B or $80;
 Stream.Write(B,1);
end;

procedure Load8Flags(Stream:TStream;out F1,F2,F3,F4,F5,F6,F7,F8:Boolean);
var B:Byte;
begin
 Stream.Read(B,1);
 F1:=B and $01<>0;
 F2:=B and $02<>0;
 F3:=B and $04<>0;
 F4:=B and $08<>0;
 F5:=B and $10<>0;
 F6:=B and $20<>0;
 F7:=B and $40<>0;
 F8:=B and $80<>0;
end;

procedure Load8MaskedFlags(Stream:TStream;out F1,F2,F3,F4,F5,F6,F7,F8:Boolean;
           MF1,MF2,MF3,MF4,MF5,MF6,MF7,MF8:Boolean);
var B:Byte;
begin
 Stream.Read(B,1);
 if MF1 then F1:=B and $01<>0;
 if MF2 then F2:=B and $02<>0;
 if MF3 then F3:=B and $04<>0;
 if MF4 then F4:=B and $08<>0;
 if MF5 then F5:=B and $10<>0;
 if MF6 then F6:=B and $20<>0;
 if MF7 then F7:=B and $40<>0;
 if MF8 then F8:=B and $80<>0;
end;

procedure SaveString(Stream:TStream;const S:String);
var B:Byte;
    W:Word;
begin
 if length(S)<255 then
  begin
   B:=length(S);
   Stream.Write(B,sizeof(B));
   if B<>0 then Stream.Write(S[1],B);
  end else
   begin
    B:=255;
    Stream.Write(B,sizeof(B));
    W:=length(S);
    Stream.Write(W,sizeof(W));
    if W<>0 then Stream.Write(S[1],W);
   end;
end;

procedure LoadString(Stream:TStream;out S:String);
var B:Byte;
    W:Word;
begin
 if Stream.Read(B,sizeof(B))<sizeof(B) then raise EInOutError.Create('');
 if B<>255 then
  begin
   SetLength(S,B);
   if B>0 then Stream.Read(S[1],B);
  end else
   begin
    Stream.Read(W,sizeof(W));
    SetLength(S,W);
    Stream.Read(S[1],W);
   end;
end;

procedure SavePackedInteger(S:TStream;A:Integer);
var B:Byte;
begin
 if (A>=0) and (A<255) then
  begin
   B:=A;
   S.Write(B,sizeof(B));
   exit;
  end;
 B:=255;
 S.Write(B,sizeof(B));
 S.Write(A,sizeof(A));
end;

procedure LoadPackedInteger(S:TStream;out A:Integer);
var B:Byte;
begin
 if S.Read(B,sizeof(B))<>1 then raise EInOutError.Create('');
 if B<255 then A:=B else
  S.Read(A,sizeof(A));
end;

procedure SaveListToStream(Stream:TStream;T:TStringList);
var A:Integer;
begin
 SavePackedInteger(Stream,T.Count);
 for A:=0 to T.Count-1 do
  SaveString(Stream,T[A]);
end;

procedure LoadListFromStream(Stream:TStream;T:TStringList);
var A,C:Integer;
      S:String;
begin
 T.Clear;
 LoadPackedInteger(Stream,C);
 for A:=0 to C-1 do
  begin
   LoadString(Stream,S);
   T.Add(S);
  end;
end;

function PtInRoundRect(PX,PY,X1,Y1,X2,Y2,R:Single):Boolean;
var C,L:Single;
begin
 if (PY<Y1) or (PY>=Y2) or (PX<X1) or (PX>=X2) then
  begin
   Result:=False;
   exit;
  end;
 if PY<Y1+R then
  begin
   L:=PY-Y1+0.5;
   C:=R-Sqrt(L*(2*R-L));
   Result:=(PX>=round(X1+C)) and (PX<=round(X2-C));
   exit;
  end;
 if PY<=Y2-R then
  begin
   Result:=(PX>=X1) and (PX<X2);
   exit;
  end;
 L:=Y2-PY-0.5;
 C:=R-Sqrt(L*(2*R-L));
 Result:=(PX>=round(X1+C)) and (PX<round(X2-C));
end;

function PtInRoundRect(PX,PY,X1,Y1,X2,Y2,R:Integer):Boolean;
var C,L:Single;
begin
 if (PY<Y1) or (PY>=Y2) or (PX<X1) or (PX>=X2) then
  begin
   Result:=False;
   exit;
  end;
 if PY<Y1+R then
  begin
   L:=PY-Y1+0.5;
   C:=R-Sqrt(L*(2*R-L));
   Result:=(PX>=round(X1+C)) and (PX<=round(X2-C));
   exit;
  end;
 if PY<=Y2-R then
  begin
   Result:=(PX>=X1) and (PX<X2);
   exit;
  end;
 L:=Y2-PY-0.5;
 C:=R-Sqrt(L*(2*R-L));
 Result:=(PX>=round(X1+C)) and (PX<round(X2-C));
end;

function PtInEllipse(PX,PY,X1,Y1,X2,Y2:Single):Boolean;
var R1,R2,L:Single;
begin
 if (PY<Y1) or (PY>=Y2) or (PX<X1) or (PX>=X2) then
  begin
   Result:=False;
   exit;
  end;
 R1:=(X2-X1-1)/2; R2:=(Y2-Y1-1)/2;
 if PY-Y1<R2 then
  begin
   L:=PY-Y1+0.5;
   L:=(R2-Sqrt(L*(2*R2-L)))*R1/R2;
  end else
 if PY>Y2-R2 then
  begin
   L:=Y2-PY-0.5;
   L:=(R2-Sqrt(L*(2*R2-L)))*R1/R2;
  end else L:=0;
 Result:=(PX>=round(L+X1)) and (PX<round(X2-L));
end;

function PtInEllipse(PX,PY,X1,Y1,X2,Y2:Integer):Boolean;
var R1,R2,L:Single;
begin
 if (PY<Y1) or (PY>=Y2) or (PX<X1) or (PX>=X2) then
  begin
   Result:=False;
   exit;
  end;
 R1:=(X2-X1-1)/2; R2:=(Y2-Y1-1)/2;
 if PY-Y1<R2 then
  begin
   L:=PY-Y1+0.5;
   L:=(R2-Sqrt(L*(2*R2-L)))*R1/R2;
  end else
 if PY>Y2-R2 then
  begin
   L:=Y2-PY-0.5;
   L:=(R2-Sqrt(L*(2*R2-L)))*R1/R2;
  end else L:=0;
 Result:=(PX>=round(L)+X1) and (PX<X2-round(L));
end;

procedure NormalizeWinPoint(var P:TPoint);
begin
 if P.X>32000 then P.X:=P.X-65536;
 if P.Y>32000 then P.Y:=P.Y-65536;
end;

end.