Source file: /~heha/hs/psfilter.zip/wutils32.pas

unit wutils32;
interface
uses Windows;
const
 StdMBoxTitle: PChar = nil;
 StdMBoxStyle: Word = MB_OK or MB_IconExclamation;
 MB_Sound = $0080;
function MBox(WndParent:HWnd; ID:Word; var p):Integer;
function MBox1(WndParent:HWnd; ID:Word; S:PChar):Integer;
function wvsprintf(s,t:PChar; var v):Integer; stdcall;
function wsprintf0(s,t:PChar):Integer; cdecl;
function wsprintf1(s,t,v1:PChar):Integer; cdecl;
function wsprintf2(s,t,v1,v2:PChar):Integer; cdecl;
function wsprintf3(s,t,v1,v2,v3:PChar):Integer; cdecl;
function wsprintf4(s,t,v1,v2,v3,v4:PChar):Integer; cdecl;
function wsprintf5(s,t,v1,v2,v3,v4,v5:PChar):Integer; cdecl;
function wsprintf6(s,t,v1,v2,v3,v4,v5,v6:PChar):Integer; cdecl;
function wsprintf7(s,t,v1,v2,v3,v4,v5,v6,v7:PChar):Integer; cdecl;
function wsprintf8(s,t,v1,v2,v3,v4,v5,v6,v7,v8:PChar):Integer; cdecl;
type
 TS255=array[0..255] of Char;
 TS127=array[0..127] of Char;
 TS63=array[0..63] of Char;
 TS31=array[0..31] of Char;
 TS15=array[0..15] of Char;
 TS7=array[0..7] of Char;
 TS3=array[0..3] of Char;


function min(I1,I2:Integer):Integer;	{Integer=LongInt}
function max(I1,I2:Integer):Integer;

function Bool2MenuCheck(x:Bool):UInt;
function IfThenElse(i:Boolean; t,e:Integer):Integer;
type Bool2MenuGray=UInt;
procedure ShortYield;

type
 LongRec=record
  lo,hi:Word;
 end;
 WordRec=record
  lo,hi:Byte;
 end;
 PPChar=^PChar;
type
 TCompProc=function(s1,s2:PChar):Integer; stdcall;

function lstrchr(s:PChar; c:Char):PChar; //stdcall;
{Zeichen <c> im String <Str> suchen, Position liefern}
function lstrcmp1(s_short,s_long:PChar;CP:TCompProc):Integer;
{Anfang von <s_long> mit <s_short> vergleichen, entweder strcmpi oder strcmp}
function lstrstr(needle,heap:PChar;CP:TCompProc):PChar;
{einfache Suche von Nadel in Heuhaufen, entweder strcmpi oder strcmp}

function GetRadioCheck(Wnd:HWnd; u,o:UInt):UInt;
function GetCheckboxGroup(Wnd:HWnd; u,o:UInt):UInt;
procedure SetCheckboxGroup(Wnd:HWnd; u,o,x:UInt);

implementation
function MBox(WndParent:HWnd; ID:Word; var p):Integer;
 var
  S,S2: array[0..255]of Char;	{2 Puffer; leider so erforderlich}
  SPT,SPH: PChar;		{Zeiger auf Text und Titel}
  I,K: Integer;
  TextType:Word;
 begin
  TextType:=StdMBoxStyle;
  I:=LoadString(HInstance,ID,S,sizeof(S)); {I=Anzahl der Zeichen insgesamt}
  SPT:=S;
  if S[0]='$' then begin
   Val(S,TextType,K);
   SPT:=S+lStrLen(S)+1;
  end;
  SPH:=SPT+lStrLen(SPT)+1;
  if SPH-S>I then SPH:=StdMBoxTitle;
  wvsprintf(S2,SPT,P);
  if TextType and MB_Sound <>0 then MessageBeep(TextType and $0070);
  MBox:=MessageBox(WndParent,S2,SPH,TextType and not MB_Sound);
 end;

function MBox1(WndParent:HWnd; ID:Word; S:PChar):Integer;
 begin
  MBox1:=MBox(WndParent,ID,S);
 end;

//function lstrchr; external 'msvcrt.dll' name 'strchr';
function wvsprintf; external 'user32.dll' name 'wvsprintfA';
function wsprintf0; external 'user32.dll' name 'wsprintfA';
function wsprintf1; external 'user32.dll' name 'wsprintfA';
function wsprintf2; external 'user32.dll' name 'wsprintfA';
function wsprintf3; external 'user32.dll' name 'wsprintfA';
function wsprintf4; external 'user32.dll' name 'wsprintfA';
function wsprintf5; external 'user32.dll' name 'wsprintfA';
function wsprintf6; external 'user32.dll' name 'wsprintfA';
function wsprintf7; external 'user32.dll' name 'wsprintfA';
function wsprintf8; external 'user32.dll' name 'wsprintfA';

function min(I1,I2:Integer):Integer;
 begin if I1<I2 then Result:=I1 else Result:=I2; end;
function max(I1,I2:Integer):Integer;
 begin if I1>I2 then Result:=I1 else Result:=I2; end;
function Bool2MenuCheck(x:Bool):UInt;
 begin if x then Result:=MF_Checked else Result:=MF_UnChecked; end;
function IfThenElse(i:Boolean; t,e:Integer):Integer;
 begin if i then Result:=t else Result:=e; end;

procedure ShortYield;
 var
  Msg: TMsg;
 begin
  if PeekMessage(Msg,0,0,0,PM_Remove) then begin
   TranslateMessage(Msg);
   DispatchMessage(Msg);
  end;
 end;

function GetRadioCheck(Wnd:HWnd; u,o:UInt):UInt;
 begin
  Result:=0;
  while u<=o do begin
   if IsDlgButtonChecked(Wnd,u)=1 then exit;
   Inc(u);
   Inc(Result);
  end;
 end;

function GetCheckboxGroup(Wnd:HWnd; u,o:UInt):UInt;
 var
  Mask:UInt;
 begin
  Result:=0;
  Mask:=1;
  while u<=o do begin
   if IsDlgButtonChecked(Wnd,u)=1 then Result:=Result or Mask;
   Inc(u);
   Mask:=Mask shl 1;
  end;
 end;
 
procedure SetCheckboxGroup(Wnd:HWnd; u,o,x:UInt);
 begin
  while u<=o do begin
   CheckDlgButton(Wnd,u,x and 1);
   Inc(u);
   x:=x shr 1;
  end;
 end;

procedure SetCheckboxGroup2(Wnd:HWnd; u,o,x:UInt);
{wie oben, beläßt jedoch Felder im dritten Zustand unverändert}
 begin
  while u<=o do begin
   if IsDlgButtonChecked(Wnd,u)<2 
   then CheckDlgButton(Wnd,u,x and 1);
   Inc(u);
   x:=x shr 1;
  end;
 end;

function lstrchr(s:PChar; c:Char):PChar;
 begin
  repeat
   if s^=c then begin Result:=s; exit; end;
   if s^=#0 then break;
   s:=AnsiNext(s);
  until false;
  Result:=nil;
 end;

function lstrcmp1(s_short,s_long:PChar;CP:TCompProc):Integer;
 var
  rp: PChar;
  cm: Char;
 begin
  rp:=s_long+lstrlen(s_short);
  cm:=rp^;
  rp^:=#0;			{patchen}
  Result:=CP(s_short,s_long);
  rp^:=cm;			{zurckpatchen}
 end;

function lstrstr(needle,heap:PChar; CP:TCompProc):PChar;
 var
  ln,lh,cc,cr:Integer;
  cm: Char;
  h_end,rp: PChar;
 begin
  ln:=lstrlen(needle);
  lh:=lstrlen(heap);
  cc:=lh-ln;
  if cc<0 then begin Result:=nil; exit; end;
			{Nadel l„nger als Heu: kann nicht sein!}
  h_end:=heap+cc;
  while heap<=h_end do begin
   rp:=heap+ln;
   cm:=rp^;
   rp^:=#0;		{Patch!}
   cr:=CP(heap,needle);
   rp^:=cm;		{Rckpatch!}
   if cr=0 then begin Result:=heap; exit; end;
   heap:=AnsiNext(heap);
  end;
  Result:=nil;
 end;

end.
(*
function min(I1,I2:Integer):Integer;	{Integer=LongInt}
 inline($58/$59/$39/$C8/$7C/$01/$91);
	{pop eax; pop ecx; cmp eax,ecx; jl $+3; xchg ecx,eax}
function max(I1,I2:Integer):Integer;
 inline($58/$59/$39/$C8/$7F/$01/$91);
	{pop eax; pop ecx; cmp eax,ecx; jg $+3; xchg ecx,eax}
*)