dao/DelphiScanner/Utils.pas

unit Utils;

interface
uses
  Controls,
  Graphics //TColor
  ;

type
  TStrArray = array of string;

  TUtils = class
    class function split(input: string; schar: Char; s: Integer): string;
    class function Explode(var a: TStrArray; Border, S: string): Integer;

    class procedure RoundCornerOf(Control: TWinControl);
    class function BarCodeValid (ACode: string): boolean;
    class function CheckSumModulo10(const data:string):string;

    class function TColorToHex(Color : TColor) : string;
    class function HexToTColor(sColor : string) : TColor;


  end;

implementation

uses StrUtils,
  Types, //TRect ,
  Windows,
  Messages,
  SysUtils //IntToStr etc
  ;

{
 VERY fast split function
 this function returns part of a string based on
 constant defineable delimiters, such as ";". So
 SPLIT('this is a test ',' ',3) = 'is' or
 SPLIT('data;another;yet;again;more;',';',4) = 'yet'

 Split function shifts index integer by two to
 be compatible with commonly used PD split function
 gpl 2004 / Juhani Suhonen
}
class function TUtils.split(input: string; schar: Char; s: Integer): string;
var
  c: array of Integer;
  b, t: Integer;
begin
  Dec(s, 2);  // for compatibility with very old & slow split function
  t := 0;     // variable T needs to be initialized...
  setlength(c, Length(input));
  for b := 0 to pred(High(c)) do
  begin
    c[b + 1] := posex(schar, input, succ(c[b]));
    // BREAK LOOP if posex looped (position before previous)
    // or wanted position reached..
    if (c[b + 1] < c[b]) or (s < t) then break
    else
      Inc(t);
  end;
  Result := Copy(input, succ(c[s]), pred(c[s + 1] - c[s]));
end;

class function TUtils.Explode(var a: TStrArray; Border, S: string): Integer;
var
  S2: string;
begin
  Result  := 0;
  S2 := S + Border;
  repeat
    SetLength(A, Length(A) + 1);
    a[Result] := Copy(S2, 0,Pos(Border, S2) - 1);
    Delete(S2, 1,Length(a[Result] + Border));
    Inc(Result);
  until S2 = '';
end;


class procedure TUtils.RoundCornerOf(Control: TWinControl);
var
   R: TRect;
   Rgn: HRGN;
begin
   with Control do
   begin
     R := ClientRect;
//     rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 20, 20) ;
     rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 25, 25) ;
//     rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 30, 30) ;
     Perform(EM_GETRECT, 0, lParam(@r)) ;
     InflateRect(r, - 4, - 4) ;
     Perform(EM_SETRECTNP, 0, lParam(@r)) ;
     SetWindowRgn(Handle, rgn, True) ;
     Invalidate;
   end;
end;


class function TUtils.BarCodeValid (ACode: string): boolean;
var
   I: integer;
   SumOdd, SumEven: integer;
   ADigit, AChecksumDigit: integer;
begin
   SumOdd := 0;
   SumEven := 0;
   for I := 1 to (Length (ACode) - 1) do begin
      ADigit := StrToIntDef (ACode [I], 0);
      if (I MOD 2 = 0) then begin
         SumEven := SumEven + ADigit;
      end else begin
         SumOdd := SumOdd + ADigit;
      end; {if}
   end; {for}
   AChecksumDigit := StrToIntDef (ACode [Length (ACode)], 0);
   Result := ((SumOdd*3 + SumEven + AChecksumDigit) MOD 10 = 0);
end; {--BarCodeValid--}

{ used for EAN 8/13 }
class function TUtils.CheckSumModulo10(const data:string):string;
        var i,fak,sum : Integer;
begin
        sum := 0;
        fak := Length(data);
        for i:=1 to Length(data) do
        begin
                if (fak mod 2) = 0 then
                        sum := sum + (StrToInt(data[i])*1)
                else
                        sum := sum + (StrToInt(data[i])*3);
                dec(fak);
        end;
        if (sum mod 10) = 0 then
                result := data+'0'
        else
                result := data+IntToStr(10-(sum mod 10));
end;


class function TUtils.TColorToHex(Color : TColor) : string;
begin
   Result :=
     IntToHex(GetRValue(Color), 2) +
     IntToHex(GetGValue(Color), 2) +
     IntToHex(GetBValue(Color), 2) ;
end;

class function TUtils.HexToTColor(sColor : string) : TColor;
begin
   Result :=
     RGB(
       StrToInt('$'+Copy(sColor, 1, 2)),
       StrToInt('$'+Copy(sColor, 3, 2)),
       StrToInt('$'+Copy(sColor, 5, 2))
     ) ;
end;


end.
1	torben	2682	unit Utils;
2
3			interface
4			uses
5			Controls,
6			Graphics //TColor
7			;
8
9			type
10			TStrArray = array of string;
11
12			TUtils = class
13			class function split(input: string; schar: Char; s: Integer): string;
14			class function Explode(var a: TStrArray; Border, S: string): Integer;
15
16			class procedure RoundCornerOf(Control: TWinControl);
17			class function BarCodeValid (ACode: string): boolean;
18			class function CheckSumModulo10(const data:string):string;
19
20			class function TColorToHex(Color : TColor) : string;
21			class function HexToTColor(sColor : string) : TColor;
22
23
24
25
26			end;
27
28			implementation
29
30			uses StrUtils,
31			Types, //TRect ,
32			Windows,
33			Messages,
34			SysUtils //IntToStr etc
35			;
36
37			{
38			VERY fast split function
39			this function returns part of a string based on
40			constant defineable delimiters, such as ";". So
41			SPLIT('this is a test ',' ',3) = 'is' or
42			SPLIT('data;another;yet;again;more;',';',4) = 'yet'
43
44			Split function shifts index integer by two to
45			be compatible with commonly used PD split function
46			gpl 2004 / Juhani Suhonen
47			}
48			class function TUtils.split(input: string; schar: Char; s: Integer): string;
49			var
50			c: array of Integer;
51			b, t: Integer;
52			begin
53			Dec(s, 2); // for compatibility with very old & slow split function
54			t := 0; // variable T needs to be initialized...
55			setlength(c, Length(input));
56			for b := 0 to pred(High(c)) do
57			begin
58			c[b + 1] := posex(schar, input, succ(c[b]));
59			// BREAK LOOP if posex looped (position before previous)
60			// or wanted position reached..
61			if (c[b + 1] < c[b]) or (s < t) then break
62			else
63			Inc(t);
64			end;
65			Result := Copy(input, succ(c[s]), pred(c[s + 1] - c[s]));
66			end;
67
68			class function TUtils.Explode(var a: TStrArray; Border, S: string): Integer;
69			var
70			S2: string;
71			begin
72			Result := 0;
73			S2 := S + Border;
74			repeat
75			SetLength(A, Length(A) + 1);
76			a[Result] := Copy(S2, 0,Pos(Border, S2) - 1);
77			Delete(S2, 1,Length(a[Result] + Border));
78			Inc(Result);
79			until S2 = '';
80			end;
81
82
83
84			class procedure TUtils.RoundCornerOf(Control: TWinControl);
85			var
86			R: TRect;
87			Rgn: HRGN;
88			begin
89			with Control do
90			begin
91			R := ClientRect;
92			// rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 20, 20) ;
93			rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 25, 25) ;
94			// rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 30, 30) ;
95			Perform(EM_GETRECT, 0, lParam(@r)) ;
96			InflateRect(r, - 4, - 4) ;
97			Perform(EM_SETRECTNP, 0, lParam(@r)) ;
98			SetWindowRgn(Handle, rgn, True) ;
99			Invalidate;
100			end;
101			end;
102
103
104			class function TUtils.BarCodeValid (ACode: string): boolean;
105			var
106			I: integer;
107			SumOdd, SumEven: integer;
108			ADigit, AChecksumDigit: integer;
109			begin
110			SumOdd := 0;
111			SumEven := 0;
112			for I := 1 to (Length (ACode) - 1) do begin
113			ADigit := StrToIntDef (ACode [I], 0);
114			if (I MOD 2 = 0) then begin
115			SumEven := SumEven + ADigit;
116			end else begin
117			SumOdd := SumOdd + ADigit;
118			end; {if}
119			end; {for}
120			AChecksumDigit := StrToIntDef (ACode [Length (ACode)], 0);
121			Result := ((SumOdd*3 + SumEven + AChecksumDigit) MOD 10 = 0);
122			end; {--BarCodeValid--}
123
124			{ used for EAN 8/13 }
125			class function TUtils.CheckSumModulo10(const data:string):string;
126			var i,fak,sum : Integer;
127			begin
128			sum := 0;
129			fak := Length(data);
130			for i:=1 to Length(data) do
131			begin
132			if (fak mod 2) = 0 then
133			sum := sum + (StrToInt(data[i])*1)
134			else
135			sum := sum + (StrToInt(data[i])*3);
136			dec(fak);
137			end;
138			if (sum mod 10) = 0 then
139			result := data+'0'
140			else
141			result := data+IntToStr(10-(sum mod 10));
142			end;
143
144
145			class function TUtils.TColorToHex(Color : TColor) : string;
146			begin
147			Result :=
148			IntToHex(GetRValue(Color), 2) +
149			IntToHex(GetGValue(Color), 2) +
150			IntToHex(GetBValue(Color), 2) ;
151			end;
152
153			class function TUtils.HexToTColor(sColor : string) : TColor;
154			begin
155			Result :=
156			RGB(
157			StrToInt('$'+Copy(sColor, 1, 2)),
158			StrToInt('$'+Copy(sColor, 3, 2)),
159			StrToInt('$'+Copy(sColor, 5, 2))
160			) ;
161			end;
162
163
164			end.