home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / pascal / turbpa / wintools.pa_ / wintools.pa
Encoding:
Text File  |  1993-03-15  |  65.6 KB  |  2,254 lines
  1. {$n+,f+,v+}
  2.  
  3. unit wintools;interface
  4.  
  5. {$ifndef VER70}
  6. uses windos,wintypes,winprocs,wobjects;
  7. {$else}
  8. uses windos,wintypes,winprocs,Objects,OWindows,ODialogs,OMemory;
  9. {$endif}
  10.  
  11. procedure      ASCII                (var s:string);
  12. procedure      Alphanum             (var s:string);
  13. function       BoldFont             (height:word):hfont;
  14. procedure      CalcDialogUnits      (fontname:pchar;height:integer;
  15.                                     var wunitsx,wunitsy:integer);
  16. function       ClipExtension        (s:string):string;
  17. function       CreateDialogChild    (hWindow:hwnd;Class,Text:string;
  18.                                     Style:longint;ID:word;x,y,w,h:integer;
  19.                                     borstyle:boolean):boolean;
  20. function       Continue             (s:string;icon:byte):boolean;
  21. function       Datestring           :string;
  22. procedure      Delay                (ms:word);
  23. procedure      Dispatch             (hw:hwnd);
  24. procedure      DlgPos               (hWindow:hwnd;entry:string;save:boolean);
  25. procedure      DrawBitmap           (dc:HDC;hbm:HBitMap;xStart,yStart:integer);
  26. function       Elapsed_days         :single;
  27. function       Elapsed_hours        :single;
  28. function       Elapsed_minutes      :single;
  29. function       Elapsed_seconds      :longint;
  30. procedure      ErweitertAlphanum    (var s:string);
  31. function       Extread              (var s:string;var wert:extended):boolean;
  32. function       FileExists           (name:string):boolean;
  33. procedure      GetBitmapSize        (hbm:HBitMap;var xRes,yRes:integer);
  34. function       GetElementName       (s:string):string;
  35. function       GetElementID         (s:string):string;
  36. function       GetPath              (s:string):string;
  37. procedure      GetWindowUnits       (var x,y:integer;xUnits,yUnits:integer);
  38. function       GetHeapSpaces        (w:word):longint;
  39. procedure      GetIniBoolean        (Bezeichner:string;default:boolean;
  40.                                     var wert:boolean);
  41. procedure      GetIniExtended       (Bezeichner:string;default:extended;
  42.                                     var wert:extended);
  43. procedure      GetIniInteger        (Bezeichner:string;default:integer;
  44.                                     var wert:integer);
  45. procedure      GetIniLongint        (Bezeichner:string;default:longint;
  46.                                     var wert:longint);
  47. function       GetIniHex            (Section,Bezeichner:string;default:longint):longint;
  48. procedure      GetIniString         (Bezeichner,default:string;
  49.                                     var wert:string);
  50. function       GetInternalWindowPos (hWindow:HWnd;Rect:PRect;Point:PPoint):integer;
  51. function       GetPrinterDC         :THandle;
  52. function       HelpItem            (Item:Integer):integer;
  53. function       HexStr               (w:word):string;
  54. function       HexToLong            (s:string;default:longint):longint;
  55. function       Intread              (var s:string;var wert:integer):boolean;
  56. function       LongDatestring       :string;
  57. function       Lastpos              (ch:char;s:string):integer;
  58. function       LoCase               (ch:char):char;
  59. function       MakeFont             (hoehe:integer;bold,kursiv:boolean;family:byte):hfont;
  60. function       MakeEngineFont       (Fontdescriptor:string):hfont;
  61. function       MakeRotFont          (hoehe,rot:integer;bold,kursiv:boolean;family:byte):hfont;
  62. procedure      Memorymessage        ;
  63. procedure      Message              (s:string;icon:byte);
  64. function       NewFont              (height:word):hfont;
  65. function       Optioncount        (s:string):word;
  66. function       Optionrealval        (s:string;no:word):string;
  67. function       Optionstring         (s:string;no:word):string;
  68. function       Optionval            (s:string;no:word):integer;
  69. function       ReadWindowPosition   (hWindow:HWnd;Flags:Word;Filename,
  70.                                     Section,Entry:string):boolean;
  71. function       RectMeetsDialogObject(R:TRect;hWndDialogObject,
  72.                                     hWndDialogWindow:hWnd):boolean;
  73. function       ResStr               (i:integer):string;
  74. function       ResPChar             (i:integer):pchar;
  75. procedure      Restorecursor;
  76. function       Selectfont           (dc:hdc;height:word):hfont;
  77. procedure      SetIniBoolean        (Bezeichner:string;wert:Boolean);
  78. procedure      SetIniExtended       (Bezeichner:string;wert:extended);
  79. procedure      SetIniInteger        (Bezeichner:string;wert:integer);
  80. procedure      SetIniHex            (Section,Bezeichner:string;wert:longint);
  81. procedure      SetIniLongint        (Bezeichner:string;wert:longint);
  82. procedure      SetIniString         (Bezeichner,wert:string);
  83. function       SetInternalWindowPos (hWindow:HWnd;nCmdShow:integer;Rect:PRect;Point:PPoint):integer;
  84. procedure      SetWallPaper         (BmpName:String;Tiled:boolean);
  85. procedure      Sread                (var l:string;var r:extended;
  86.                                     var fehler:boolean);
  87. procedure      Store_reference      ;
  88. procedure      Str_pas              (var s:string);
  89. function       Timestring           :string;
  90. procedure      Umlaute              (var s:string);
  91. procedure      Up                   (var s:string);
  92. procedure      Upl                  (var s:string);
  93. procedure      Valid                (var s:string);
  94. procedure      Waitcursor;
  95. function       WriteWindowPosition  (hWindow:HWnd;Flags:Word;Filename,
  96.                                     Section,Entry:string):boolean;
  97.  
  98.  
  99. const          IniFile              :string ='Test.ini';
  100.                HelpFile             :string ='Test.hlp';
  101.                IniSequence          :string ='StartUp';
  102.                Programpath          :string ='';
  103.                wt_sound             :boolean=false;
  104.  
  105.                WP_Position          = 1;
  106.                WP_Size              = 2;
  107.                WP_State             = 4;
  108.                WP_Icon              = 8;
  109.                WP_Main              = 7;
  110.                WP_Child             =15;
  111.  
  112.                WP_Load              :boolean=false;
  113.                WP_Save              :boolean=true;
  114.                WP_Restore           :boolean=false;
  115.  
  116.                ch_limit:char        =',';
  117.                ch_paranthesis       ='"';
  118.  
  119.                DialogUnitX          :integer=0;
  120.                DialogUnitY          :integer=0;
  121.  
  122.                ResStrings           :string='';
  123.                wt_language          :integer=0;
  124.  
  125. {------ Constants for Real Time Clock ------------------------------------}
  126.  
  127. const        RTC_AdrPort    =$70;
  128.         RTC_DtaPort    =$71;
  129.                 RTC_StatusB    =11;
  130.             RTC_Second    =0;
  131.             RTC_Minute    =2;
  132.             RTC_Hour    =4;
  133.             RTC_Day        =7;
  134.             RTC_Month    =8;
  135.             RTC_Year    =9;
  136.  
  137. type timerec=record sec,min,hour,day,month:integer end;
  138.  
  139. var          Reference:    Timerec;
  140.  
  141.  
  142. type         ml        =array[1..12] of byte;
  143. const        monthlength    :ml=(
  144.                   {January}         31,
  145.                   {February}        28,
  146.                   {March}           31,
  147.                   {April}           30,
  148.                   {May}             31,
  149.                   {June}            30,
  150.                   {July}            31,
  151.                   {August}          31,
  152.                   {September}       30,
  153.                   {October}         31,
  154.                   {November}        30,
  155.                   {December}        31);
  156.  
  157. const {Stilkonstanten der neuen Datentypen}
  158.  
  159.       es_bell              =1;
  160.       es_box               =2;
  161.       es_german            =4;
  162.       es_name              =8;
  163.  
  164.       cm_allchars          =0;
  165.       cm_ExtAlphaNum       =1;
  166.       cm_alphanum          =2;
  167.       cm_User              =3;
  168.  
  169.  
  170. type PWatchEdit=^TWatchEdit;
  171.      TWatchEdit=object(TEdit)
  172.        AllowedChars:string;                              {erlaubte Zeichen}
  173.        value:string;                                     {aktueller String}
  174.        maxlength:integer;                                  {maximale LΣnge}
  175.        warning:integer;                                {aktuelle Warnstufe}
  176.        german,                                            {Umlaute erlaubt}
  177.        bell,                                             {akustisch warnen}
  178.        box,                                    {Warnbox bei zweitem Fehler}
  179.        name:boolean;                                {erster Buchstabe gro▀}
  180.        charmode:integer;                      {welche Zeichen sind erlaubt}
  181.        intern:boolean;
  182.  
  183.        constructor InitResource(AParent:PWindowsObject;ID:Word;
  184.          max:integer;style:word;_charmode:integer);
  185.        constructor Init(AParent:PWindowsObject;ID:Word;x,y,w,h:integer;
  186.          max:integer;style:word;_charmode:integer);
  187.        procedure SetupWindow;virtual;
  188.        function  GetText(var s:string):boolean;virtual;
  189.        procedure SetText(s:string);virtual;
  190.        procedure SetCharset(s:string);
  191.        procedure wmdblclk(var msg:tmessage);virtual wm_lbuttondblclk;
  192.        function Control:boolean;virtual;
  193.      end;
  194.  
  195.   PFloat=^TFloat;
  196.   TFloat=object(TEdit)
  197.                  value,default,minimum,maximum:extended;
  198.                  stellen,komma:word;
  199.                  constructor initresource(AParent:PWindowsObject;ID:Word;d,min,max:extended;n,m:word);
  200.                  constructor init(AParent:PWindowsObject;ID:Word;x,y,w,h:integer;
  201.                    d,min,max:extended;n,m:word);
  202.                  procedure GetMinMax(var min,max:extended);
  203.                  procedure Delta(step:extended);
  204.                  procedure setval(v:extended);
  205.                  function legal(var v:extended):boolean;
  206.                  procedure control(var msg:tmessage);
  207.                  function getval(var v:extended):boolean;
  208.                  procedure wmdblclk(var msg:tmessage);virtual wm_lbuttondblclk;
  209.                  end;
  210.  
  211.   PTWord=^TWord;
  212.   TWord=object(TEdit)
  213.           value,default,minimum,maximum,
  214.           stellen:integer;
  215.           constructor initresource(AParent:PWindowsObject;ID:Word;d,min,max,n:integer);
  216.           constructor init(AParent:PWindowsObject;ID:Word;x,y,w,h:integer;
  217.             d,min,max,n:integer);
  218.           procedure wmdblclk(var msg:tmessage);virtual wm_lbuttondblclk;
  219.           procedure GetMinMax(var min,max:integer);
  220.           procedure Delta(step:integer);
  221.           function legal(var v:integer):boolean;
  222.           procedure setval(v:integer);
  223.           function getval(var v:integer):boolean;
  224.         end;
  225.  
  226.   PEnterEdit=^TEnterEdit;
  227.   TEnterEdit=object(Tedit)
  228. {$ifdef ver70}
  229.           procedure wmchar(var msg:tmessage);virtual wm_char;
  230. {$else}
  231.           procedure wmchar(var msg:tmessage);virtual wm_keydown;
  232. {$endif}
  233.         end;
  234.  
  235. const bsh_borshade  =0;
  236.       bsh_HBump     =2;
  237.       bsh_VBump     =3;
  238.       bsh_HDip      =4;
  239.       bsh_VDip      =5;
  240.  
  241. type PBorShade=^TBorShade;
  242.      TBorShade=object(TButton)
  243.        constructor Init(Aparent:Pwindowsobject;AnID:integer;
  244.          Atext:pchar;x,y,w,h:integer;default:boolean;astyle:byte);
  245.        function GetClassName:pchar;virtual;
  246.        end;
  247.  
  248.      PBorButton=^TBorButton;
  249.      TBorButton=object(TButton)
  250.        function GetClassName:pchar;virtual;
  251.        end;
  252.  
  253.      PBorRadio=^TBorRadio;
  254.      TBorRadio=object(TRadioButton)
  255.        function GetClassName:pchar;virtual;
  256.        end;
  257.  
  258.      PBorCheck=^TBorCheck;
  259.      TBorCheck=object(TCheckbox)
  260.        function GetClassName:pchar;virtual;
  261.        end;
  262.  
  263. var   curs:array[0..9] of hcursor;
  264.       waitcur:hcursor;
  265.  
  266. const curindex:shortint=-1;
  267.  
  268. implementation
  269.  
  270. uses strings;
  271.  
  272.  
  273. procedure waitcursor;
  274.   begin
  275.     If curindex<9 then inc(curindex);
  276.     curs[curindex]:=setcursor(waitcur);
  277.   end;
  278.  
  279. procedure restorecursor;
  280.   begin
  281.     setcursor(curs[curindex]);
  282.     if curindex>0 then dec(curindex);
  283.   end;
  284.  
  285. procedure delay(ms:word);
  286.   var i,j:longint;
  287.   begin
  288.     for i:=0 to ms do
  289.       for j:=0 to 100 do;
  290.   end;
  291.  
  292.  
  293. function Selectfont(dc:hdc;height:word):hfont;
  294.   var font,oldfont:hfont;
  295.   begin
  296.     font:=CreateFont(
  297.              height,               {H÷he}
  298.              0,                    {Breite}
  299.              0,                    {Rotation der Textbasislinie}
  300.              0,                    {Kippung der Zeichen gegen die Textlinie}
  301.              fw_dontcare,          {weight=normal}
  302.              0,                    {nicht kursiv}
  303.              0,                    {nicht unterstreichen}
  304.              0,                    {nicht durchstreichen}
  305.              0,                    {ANSI-Zeichensatz}
  306.              out_default_precis,   {ZeichenprΣzision n.i.}
  307.              clip_default_precis,  {Standard Clip-PrΣzision}
  308.              proof_quality,        {QualitΣt}
  309.              variable_pitch        {Proportional erlauben}
  310.              or ff_dontcare,       {keine Fontfamilie vorschreiben}
  311.              'Helvetica');
  312.     if font=0 then SelectFont:=0 else
  313.       begin
  314.         oldfont:=selectobject(dc,font);
  315.         SelectFont:=oldfont;
  316.       end;
  317.   end;
  318.  
  319. function Newfont(height:word):hfont;
  320.   var font,oldfont:hfont;
  321.   begin
  322.     Newfont:=CreateFont(
  323.              height,               {H÷he}
  324.              0,                    {Breite}
  325.              0,                    {Rotation der Textbasislinie}
  326.              0,                    {Kippung der Zeichen gegen die Textlinie}
  327.              fw_dontcare,          {weight=normal}
  328.              0,                    {nicht kursiv}
  329.              0,                    {nicht unterstreichen}
  330.              0,                    {nicht durchstreichen}
  331.              0,                    {ANSI-Zeichensatz}
  332.              out_default_precis,   {ZeichenprΣzision n.i.}
  333.              clip_default_precis,  {Standard Clip-PrΣzision}
  334.              proof_quality,        {QualitΣt}
  335.              variable_pitch        {Proportional erlauben}
  336.              or ff_swiss,       {keine Fontfamilie vorschreiben}
  337.              nil);
  338.   end;
  339.  
  340.  
  341. function BoldFont(height:word):hfont;
  342.   var font,oldfont:hfont;
  343.   begin
  344.     Boldfont:=CreateFont(
  345.              height,               {H÷he}
  346.              0,                    {Breite}
  347.              0,                    {Rotation der Textbasislinie}
  348.              0,                    {Kippung der Zeichen gegen die Textlinie}
  349.              fw_bold,              {weight=fett}
  350.              0,                    {nicht kursiv}
  351.              0,                    {nicht unterstreichen}
  352.              0,                    {nicht durchstreichen}
  353.              0,                    {ANSI-Zeichensatz}
  354.              out_default_precis,   {ZeichenprΣzision n.i.}
  355.              clip_default_precis,  {Standard Clip-PrΣzision}
  356.              proof_quality,        {QualitΣt}
  357.              variable_pitch        {Proportional erlauben}
  358.              or ff_swiss,       {keine Fontfamilie vorschreiben}
  359.              nil);
  360.   end;
  361.  
  362.  
  363. procedure valid(var s:string);
  364.   var sh:string;i:integer;paran:boolean;
  365.   begin
  366.     sh:='';
  367.     paran:=false;
  368.     for i:=1 to length(s) do
  369.       begin
  370.       If s[i]=ch_paranthesis then
  371.         begin
  372.           paran:=not paran;
  373.           sh:=sh+ch_paranthesis;
  374.         end else
  375.         begin
  376.           If paran then sh:=sh+s[i] else
  377.             begin
  378.               if s[i] in [',','@','=','#','.','/','\','_','|','+','-',
  379.                          '0'..'9','A'..'Z','a'..'z',#0,':']
  380.                 then sh:=sh+s[i];
  381.             end;
  382.         end;
  383.       end;
  384.     s:=sh;
  385.   end;
  386.  
  387.  
  388. procedure ErweitertAlphanum(var s:string);
  389.   var sh:string;i:integer;
  390.   begin
  391.     sh:='';
  392.     for i:=1 to length(s) do
  393.       if s[i] in [',','=','.','/','\','_','|','+','-',
  394.                   'ⁿ','▄','Σ','─','÷','╓','▀',
  395.                   '0'..'9','A'..'Z','a'..'z',':']
  396.         then sh:=sh+s[i];
  397.     s:=sh;
  398.   end;
  399.  
  400.  
  401. procedure ASCII(var s:string);
  402.   var sh:string;i:integer;
  403.   begin
  404.     sh:='';
  405.     for i:=1 to length(s) do
  406.       if s[i] in ['0'..'9','A'..'Z','a'..'z','ⁿ','▄','Σ','─','÷','╓','▀']
  407.         then sh:=sh+s[i];
  408.     s:=sh;
  409.   end;
  410.  
  411. procedure Umlaute(var s:string);
  412.   var sh:string;i:integer;
  413.   begin
  414.     sh:='';
  415.     for i:=1 to length(s) do
  416.       if s[i] in ['ⁿ','▄','Σ','─','÷','╓','▀']
  417.         then
  418.           begin
  419.             case s[i] of
  420.               'ⁿ':sh:=sh+'ue';
  421.               '▄':sh:=sh+'Ue';
  422.               '÷':sh:=sh+'oe';
  423.               '╓':sh:=sh+'Oe';
  424.               'Σ':sh:=sh+'ae';
  425.               '─':sh:=sh+'Ae';
  426.               '▀':sh:=sh+'ss';
  427.               end;
  428.           end else
  429.           sh:=sh+s[i];
  430.     s:=sh;
  431.   end;
  432.  
  433.  
  434. procedure DrawBitmap(dc:HDC;hbm:HBitMap;xStart,yStart:integer);
  435.   var HMemDc:HDC;
  436.       bmRec:TBitMap;
  437.       dwSize:longint;
  438.       pt:TPoint;
  439.  
  440.   begin
  441.     HMemDc:=CreateCompatibleDC(DC);
  442.     selectobject(HMemDc,hbm);
  443.     setmapmode(hmemdc,getmapmode(dc));
  444.     getobject(hbm,sizeof(bmrec),@bmrec);
  445.     pt.x:=bmrec.bmwidth;
  446.     pt.y:=bmrec.bmheight;
  447.     dptolp(dc,pt,1);
  448.     bitblt(dc,xstart,ystart,pt.x,pt.y,hmemdc,0,0,srccopy);
  449.     deletedc(hmemdc);
  450.   end;
  451.  
  452. procedure GetBitmapSize(hbm:HBitMap;var xRes,yRes:integer);
  453.   var bmRec:TBitMap;
  454.   begin
  455.     getobject(hbm,sizeof(bmrec),@bmrec);
  456.     xRes:=bmrec.bmwidth;
  457.     yRes:=bmrec.bmheight;
  458.   end;
  459. function    RTC_Read(Adresse:integer):integer;
  460.  
  461.   begin
  462.     port[RTC_Adrport]:=Adresse;
  463.     RTC_Read:=Port[RTC_Dtaport];
  464.   end;
  465.  
  466. function    RTC_Get(Adresse:integer):integer;
  467.  
  468.   var Wert:Integer;
  469.   begin
  470.     if (RTC_Read(RTC_StatusB) and 2 =0) then RTC_Get:=RTC_Read(Adresse)
  471.       else
  472.         begin
  473.           Wert:=RTC_Read(Adresse);
  474.           RTC_Get:=(Wert shr 4)*10 + Wert and 15
  475.         end;
  476.   end;
  477.  
  478.  
  479. procedure set_reference(var Reference:Timerec);
  480.  
  481.   begin
  482.     with reference do
  483.       begin
  484.         Sec    :=RTC_get(RTC_Second);
  485.         Min    :=RTC_get(RTC_Minute);
  486.         Hour    :=RTC_get(RTC_Hour);
  487.         Day    :=RTC_get(RTC_Day);
  488.         Month    :=RTC_get(RTC_Month);
  489.       end;
  490.   end;
  491.  
  492. function elapsed_seconds:longint;
  493.   var ActTime:Timerec;secs:longint;i,days:integer;
  494.   begin
  495.     set_reference(ActTime);
  496.     with reference do
  497.       begin
  498.         secs:=acttime.sec-sec;
  499.         if acttime.min<>min then
  500.           secs:=secs+60*(acttime.min-min);
  501.         if acttime.hour<>hour then
  502.           secs:=secs+3600*longint(acttime.hour-hour);
  503.         if acttime.day>day then
  504.           secs:=secs+86400*(acttime.day-day);
  505.         if acttime.day<day then
  506.           secs:=secs+86400*(acttime.day+31-day-monthlength[month]);
  507.         if acttime.month>month then
  508.           secs:=secs+86400*monthlength[month];
  509.         if acttime.month<month then
  510.           begin
  511.             days:=0;
  512.             for i:=month to 12 do days:=days+monthlength[i];
  513.             for i:=1 to pred(acttime.month) do days:=days+monthlength[i];
  514.             secs:=secs+days*86400;
  515.           end;
  516.       end;
  517.      elapsed_seconds:=secs;
  518.    end;
  519.  
  520.  
  521. function elapsed_minutes:single;
  522.   begin elapsed_minutes:=elapsed_seconds/60; end;
  523.  
  524. function elapsed_hours:single;
  525.   begin elapsed_hours:=elapsed_seconds/3600 end;
  526.  
  527. function elapsed_days:single;
  528.   begin    elapsed_days:=elapsed_seconds/86400 end;
  529.  
  530. procedure store_reference;
  531.   begin set_reference(reference) end;
  532.  
  533.     function changecharacters(s:string):string;
  534.       var i:integer;s1:string;
  535.       begin
  536.         s1:='';
  537.         for i:=1 to length(s) do
  538.           if s[i]=' ' then s1:=s1+'0' else s1:=s1+s[i];
  539.         changecharacters:=s1;
  540.       end;
  541.  
  542.     function timestring:string;
  543.       var i_stunde,i_minute,i_sek,i_sek100:word;
  544.           s_stunde,s_minute,s_sek:string[2];
  545.           tr:timerec;
  546.  
  547.       begin
  548.         set_reference(tr);
  549.         i_stunde:=tr.hour;
  550.         i_minute:=tr.min;
  551.         i_sek:=tr.sec;
  552.         {gettime(i_stunde,i_minute,i_sek,i_sek100);}
  553.         str(i_stunde:2,s_stunde);
  554.         str(i_minute:2,s_minute);
  555.         str(i_sek:2,s_sek);
  556.         timestring:=changecharacters(s_stunde)+':'
  557.                    +changecharacters(s_minute)+':'+
  558.                     changecharacters(s_sek);
  559.       end;
  560.  
  561.     function datestring:string;
  562.       var i_Jahr,i_monat,i_tag,i_wochentag:Word;
  563.           s_Jahr,s_monat,s_tag,s_wochentag:string[4];
  564.       type wt=array[0..6] of string[2];
  565.       const tage:wt=('So','Mo','Di','Mi','Do','Fr','Sa');
  566.       begin
  567.         getdate(i_jahr,i_monat,i_tag,i_wochentag);
  568.         str(i_jahr:4,s_jahr);
  569.         str(i_monat:2,s_monat);
  570.         str(i_tag:2,s_tag);
  571.         s_wochentag:=tage[i_wochentag];
  572.         datestring:=s_wochentag+' '+
  573.                     changecharacters(s_tag)+'.'+
  574.                     changecharacters(s_monat)+'.'+
  575.                     s_jahr;
  576.       end;
  577.  
  578.     function longdatestring:string;
  579.       var i_Jahr,i_monat,i_tag,i_wochentag:Word;
  580.           s_Jahr,s_monat,s_tag,s_wochentag:string[4];
  581.       type wt=array[0..6] of string[15];
  582.            mo=array[1..12] of string[15];
  583.  
  584.       const tage:wt=('Sonntag','Montag','Dienstag','Mittwoch','Donnerstag',
  585.                      'Freitag','Sonnabend');
  586.             monate:mo=('Januar','Februar','MΣrz','April','Mai','Juni','Juli',
  587.                        'August','September','Oktober','November','Dezember');
  588.       begin
  589.         getdate(i_jahr,i_monat,i_tag,i_wochentag);
  590.         str(i_jahr:4,s_jahr);
  591.         str(i_monat:2,s_monat);
  592.         str(i_tag:2,s_tag);
  593.         longdatestring:=tage[i_wochentag]+', den '+
  594.                     changecharacters(s_tag)+'. '+
  595.                     monate[i_monat]+' '+
  596.                     s_jahr;
  597.       end;
  598.  
  599. procedure str_pas(var s:string);
  600.   var i:integer;
  601.   begin
  602.     i:=1;
  603.     while (s[i]<>#0) and (i<255) do
  604.       begin
  605.         inc(i);
  606.       end;
  607.     s[0]:=char(i-1);
  608.   end;
  609.  
  610.  
  611. {------------------------------------------------------------------}
  612.  
  613.  
  614. procedure GetIniString(Bezeichner,default:string;var wert:string);
  615.  
  616.   var  applicationname,def,st,keyname,filename:string;
  617.        result:boolean;erg:integer;
  618.  
  619.   begin
  620.     Applicationname:=IniSequence+#0;
  621.     Keyname        :=bezeichner+#0;
  622.     Filename       :=Inifile+#0;
  623.     def            :=Default+#0;
  624.     erg:=GetPrivateProfileString(
  625.            @applicationname[1],
  626.            @keyname[1],
  627.            @def[1],
  628.            @st[1],
  629.            255,
  630.            @filename[1]);
  631.     st[0]:=char(erg);
  632.     wert:=st;
  633.     If wert<>'' then
  634.       begin
  635.         erg:=pos(';',wert);
  636.         If erg<>0 then wert:=copy(wert,1,erg-1);
  637.       end;
  638.   end;
  639.  
  640. procedure SetIniString(Bezeichner,wert:string);
  641.  
  642.   var  applicationname,def,st,keyname,filename:string;
  643.        result:boolean;erg:integer;
  644.  
  645.   begin
  646.     Applicationname:=IniSequence+#0;
  647.     Keyname        :=bezeichner+#0;
  648.     Filename       :=Inifile+#0;
  649.     st             :=wert+#0;
  650.     result:=WritePrivateProfileString(
  651.            @applicationname[1],
  652.            @keyname[1],
  653.            @st[1],
  654.            @filename[1]);
  655.   end;
  656.  
  657. procedure GetIniExtended;
  658.   var sd,sw:string;c:integer;
  659.   begin
  660.     str(default:8:3,sd);
  661.     GetIniString(Bezeichner,sd,sw);valid(sw);
  662.     val(sw,wert,c);
  663.   end;
  664.  
  665. procedure SetIniExtended;
  666.   var sd:string;
  667.   begin
  668.     str(wert:8:3,sd);
  669.     SetIniString(Bezeichner,sd);
  670.   end;
  671.  
  672. function HexToLong(s:string;default:longint):longint;
  673.  
  674.   const hexval='0123456789ABCDEF';
  675.  
  676.   function hexok(s:string):boolean;
  677.     var i:integer;
  678.     begin
  679.       hexok:=false;
  680.       if length(s)=0 then exit;
  681.       If length(s)>8 then exit;
  682.       for i:=1 to length(s) do
  683.       If pos(s[i],hexval)=0 then exit;
  684.       hexok:=true;
  685.     end;
  686.  
  687.   var sd:string;c,i:integer;v:longint;
  688.   begin
  689.     sd:=s;valid(sd);up(sd);
  690.     if not hexok(sd) then
  691.       begin
  692.         hextolong:=default;
  693.       end else
  694.       begin
  695.         v:=0;
  696.         for i:=1 to length(sd) do
  697.           begin
  698.             c:=pos(sd[i],hexval)-1;
  699.             v:=v+(longint(c) shl (4*(length(sd)-i)));
  700.             hextolong:=v;
  701.           end;
  702.       end;
  703.   end;
  704.  
  705. procedure GetIniLongint;
  706.   var sd,sw:string;c:integer;
  707.   begin
  708.     str(default:14,sd);
  709.     GetIniString(Bezeichner,sd,sw);valid(sw);
  710.     val(sw,wert,c);
  711.   end;
  712.  
  713. function GetIniHex;
  714.   var sd,sw,si:string;c:integer;
  715.   begin
  716.     si:=inisequence;inisequence:=section;
  717.     str(default:14,sd);
  718.     GetIniString(Bezeichner,sd,sw);valid(sw);
  719.     GetIniHex:=HexToLong(sw,default);
  720.     inisequence:=si;
  721.   end;
  722.  
  723. procedure SetIniHex;
  724.   var sd,sw,si:string;c:integer;
  725.   begin
  726.     si:=inisequence;inisequence:=section;
  727.     sd:=hexstr(lo(wert));
  728.     while length(sd)<4 do sd:='0'+sd;
  729.     sd:=hexstr(hi(wert))+sd;
  730.     valid(sd);
  731.     SetIniString(Bezeichner,sd);
  732.     inisequence:=si;
  733.   end;
  734.  
  735.  
  736. procedure SetIniLongint;
  737.   var sd:string;
  738.   begin
  739.     str(wert:8,sd);
  740.     SetIniString(Bezeichner,sd);
  741.   end;
  742.  
  743. procedure GetIniInteger;
  744.   var sd,sw:string;c:integer;
  745.   begin
  746.     str(default:8,sd);
  747.     GetIniString(Bezeichner,sd,sw);valid(sw);
  748.     val(sw,wert,c);
  749.   end;
  750.  
  751. procedure SetIniInteger;
  752.   var sd:string;
  753.   begin
  754.     str(wert:8,sd);
  755.     SetIniString(Bezeichner,sd);
  756.   end;
  757.  
  758. procedure GetIniBoolean;
  759.   var sd,sw:string;c:integer;
  760.   begin
  761.     If default then sd:='1' else sd:='0';
  762.     GetIniString(Bezeichner,sd,sw);valid(sw);
  763.     If sw='1' then wert:=true else
  764.     If sw='0' then wert:=false else
  765.     wert:=default;
  766.   end;
  767.  
  768. procedure SetIniBoolean;
  769.   var sd:string;
  770.   begin
  771.     If wert then sd:='1' else sd:='0';
  772.     SetIniString(Bezeichner,sd);
  773.   end;
  774.  
  775.  
  776. function  FileExists(name:string):boolean;
  777.   var f:file;io:integer;
  778.   begin
  779.     assign(f,name);
  780.     {$i-}reset(f);{$i+}
  781.     io:=ioresult;
  782.     if io<>0 then FileExists:=false else
  783.       begin
  784.         fileExists:=true;close(f);
  785.       end;
  786.   end;
  787.  
  788. function     StrTok ( Src : PChar; Sep: PChar ): PChar;
  789. const
  790.     STSrc: PChar = NIL;
  791. var
  792.     l : Integer;
  793.     i : Integer;
  794.     Temp : PChar;
  795. begin
  796.     StrTok := NIL;
  797.     if Src <> NIL then
  798.         STSrc := Src;
  799.     if STSrc = NIL then
  800.         Exit;
  801.  
  802.     l := StrLen ( Sep );
  803.     for i := 0 to l-1 do
  804.     begin
  805.         Temp := StrScan ( STSrc, Sep[i] );
  806.         if Temp <> NIL then
  807.         begin
  808.             StrTok := STSrc;
  809.             Temp^ := #0;
  810.             STSrc := Temp + 1;
  811.             Exit;
  812.         end;
  813.     end;
  814.     StrTok := STSrc;
  815.     STSrc := NIL;
  816. end;
  817.  
  818.  
  819. function    GetPrinterDC : THandle;
  820. var
  821.     szPrinter : array[0..64] of Char;
  822.     szDevice, szDriver, szOutput : PChar;
  823. begin
  824.     GetProfileString ( 'windows','device','', szPrinter, 64 );
  825.     szDevice := StrTok ( szPrinter, ',' );
  826.     szDriver := StrTok ( NIL, ',' );
  827.     szOutput := StrTok ( NIL, ',' );
  828.     if (szDevice <> NIL ) and
  829.          (szDriver <> NIL ) and
  830.          (szOutput <> NIL ) then
  831.          GetPrinterDC := CreateDC ( szDriver, szDevice, szOutput, NIL )
  832.     else
  833.          GetPrinterDC := 0;
  834. end;
  835.  
  836. const spi_SetDeskWallPaper   =20;
  837.       spif_UpdateIniFile     =1;
  838.       spif_SendWinIniChange  =2;
  839.  
  840. function optionstring(s:string;no:word):string;
  841.     var i,count:integer;sh,s1:string;paran:boolean;
  842.         posit:array[0..30] of integer;
  843.     begin
  844.       sh:=s;
  845.       count:=1;
  846.       paran:=false;
  847.       posit[0]:=1;
  848.       for i:=1 to 30 do posit[i]:=length(sh)+1;
  849.       for i:=1 to length(sh) do
  850.         begin
  851.           if sh[i]=ch_paranthesis then paran:=not paran else
  852.           If not paran then
  853.             begin
  854.               if sh[i]=ch_limit then
  855.                 begin
  856.                   posit[count]:=i;
  857.                   inc(count);
  858.                 end;
  859.             end;
  860.         end;
  861.       If no=0 then
  862.         s1:=copy(sh,1,posit[1]-1) else
  863.         s1:=copy(sh,posit[no]+1,posit[no+1]-posit[no]-1);
  864.  
  865.       count:=1;
  866.       while (s1[count]=#32) and (length(s1)>count) do inc(count);
  867.       If (s1[count]='"') and (length(s1)>count) then inc(count);
  868.       if length(s1)>count then delete(s1,1,count-1);
  869.  
  870.       count:=length(s1);
  871.       while (count>0) and (s1[count]=#32) do dec(count);
  872.       If (count>0) and (s1[count]='"') then dec(count);
  873.       if count>0 then s1:=copy(s1,1,count);
  874.       If s1='"' then s1:='';
  875.       optionstring:=s1;
  876.     end;
  877.  
  878. function optionval(s:string;no:word):integer;
  879.     var i,j:integer;sh:string;
  880.     begin
  881.       sh:=s;
  882.       for i:=1 to no do
  883.         if pos(ch_limit,sh)<>0 then delete(sh,1,pos(ch_limit,sh));
  884.       if pos(ch_limit,sh)=0 then sh:=copy(sh,1,255) else
  885.         sh:=copy(sh,1,pos(ch_limit,sh)-1);
  886.       val(sh,j,i);
  887.       if i=0 then optionval:=j else optionval:=0;
  888.     end;
  889.  
  890. function optionrealval(s:string;no:word):string;
  891.     var i:integer;r:extended;sh:string;
  892.     begin
  893.       sh:=s;
  894.       for i:=1 to no do
  895.         if pos(ch_limit,sh)<>0 then delete(sh,1,pos(ch_limit,sh));
  896.       if pos(ch_limit,sh)=0 then sh:=copy(sh,1,255) else
  897.         sh:=copy(sh,1,pos(ch_limit,sh)-1);
  898.       valid(sh);
  899.       optionrealval:=sh;
  900.     end;
  901.  
  902. function optioncount(s:string):word;
  903.     var i,count:integer;sh:string;paran:boolean;
  904.         posit:array[0..30] of integer;
  905.     begin
  906.       sh:=s;
  907.       count:=0;
  908.       paran:=false;
  909.       for i:=0 to 30 do posit[i]:=length(sh);
  910.       for i:=1 to length(sh) do
  911.         begin
  912.           if sh[i]=ch_paranthesis then paran:=not paran else
  913.           If not paran then
  914.             begin
  915.               if sh[i]=ch_limit then
  916.                 begin
  917.                   posit[count]:=i;
  918.                   inc(count);
  919.                 end;
  920.             end;
  921.         end;
  922.       optioncount:=count;
  923.     end;
  924.  
  925.  
  926. {********** Positionsroutinen **********************************************}
  927.  
  928. function GetInternalWindowPos(hWindow:HWnd;Rect:PRect;Point:PPoint):integer;
  929.   external 'USER' index 460;
  930.  
  931. function SetInternalWindowPos(hWindow:HWnd;nCmdShow:integer;Rect:PRect;Point:PPoint):integer;
  932.   external 'USER' index 461;
  933.  
  934. function ReadWindowPosition(hWindow:HWnd;Flags:Word;Filename,Section,Entry:string):boolean;
  935.   var si,s:string;nCmdShow,nWidth,nHeight:integer;Rect:TRect;Point:TPoint;
  936.   begin
  937.     si:=IniSequence;
  938.     ReadWindowPosition:=False;
  939.     {If GetVersion=3 then exit;}
  940.     IniFile:=Filename;
  941.     IniSequence:=Section;
  942.     If not IsWindow(hWindow) then begin IniSequence:=si;exit;end;
  943.     GetIniString(entry,'',s);
  944.     If s='' then begin IniSequence:=si;exit;end;
  945.  
  946.     nCmdShow:=GetInternalWindowPos(hWindow,@Rect,@Point);
  947.     nWidth:=Rect.Right-Rect.Left;
  948.     nHeight:=Rect.Bottom-Rect.Top;
  949.  
  950.     If Optioncount(s)<>6 then exit;
  951.  
  952.     if (Flags and WP_Size)<>0 then
  953.       begin
  954.         nWidth      :=Optionval(s,0);
  955.         nHeight     :=Optionval(s,1);
  956.       end;
  957.  
  958.     if (Flags and WP_Position)<>0 then
  959.       begin
  960.         Rect.left  :=Optionval(s,2);
  961.         Rect.top   :=Optionval(s,3);
  962.       end;
  963.  
  964.     if (Flags and WP_State)<>0 then
  965.       begin
  966.         nCmdShow    :=Optionval(s,4);
  967.       end;
  968.  
  969.     if (Flags and WP_Icon)<>0 then
  970.       begin
  971.         Point.x     :=Optionval(s,5);
  972.         Point.y     :=Optionval(s,6);
  973.       end;
  974.  
  975.     Rect.Right      :=Rect.Left+nWidth;
  976.     Rect.Bottom     :=Rect.Top +nHeight;
  977.  
  978.     SetInternalWindowPos(hWindow,nCmdShow,@Rect,@Point);
  979.     ReadWindowPosition:=true;
  980.     IniSequence:=si;
  981.   end;
  982.  
  983.  
  984. function WriteWindowPosition(hWindow:HWnd;Flags:Word;Filename,Section,Entry:string):boolean;
  985.   var s,sh,si:string;nCmdShow,nWidth,nHeight:integer;Rect:TRect;Point:TPoint;
  986.   begin
  987.     WriteWindowPosition:=false;
  988.     {If GetVersion=3 then exit;}
  989.     si:=Inisequence;
  990.     IniFile:=Filename;
  991.     IniSequence:=Section;
  992.     If not IsWindow(hWindow) then begin IniSequence:=si;exit;end;
  993.     nCmdShow:=GetInternalWindowPos(hWindow,@Rect,@Point);
  994.     s:='';
  995.     nWidth:=Rect.Right-Rect.Left;
  996.     nHeight:=Rect.Bottom-Rect.Top;
  997.     str(nWidth,sh);s:=sh+',';
  998.     str(nHeight,sh);s:=s+sh+',';
  999.     str(Rect.left,sh);s:=s+sh+',';
  1000.     str(Rect.top,sh);s:=s+sh+',';
  1001.     str(nCmdShow,sh);s:=s+sh+',';
  1002.     str(Point.x,sh);s:=s+sh+',';
  1003.     str(Point.y,sh);s:=s+sh;
  1004.     SetIniString(entry,s);
  1005.     IniSequence:=si;
  1006.     WriteWindowPosition:=true;
  1007.   end;
  1008.  
  1009. {********** Unterstⁿtzung fⁿr SetDeskWallPaper *****************************}
  1010.  
  1011. function SystemParametersInfo(wAction,wParam:word;
  1012.                               lpParam:pointer;fWfnIni:word):boolean;far;
  1013.          external 'USER' index 483;
  1014.  
  1015. function SetDeskWallPaper(s:pchar):boolean;far;
  1016.          external 'USER' index 285;
  1017.  
  1018. procedure SetWallPaper(BmpName:String;Tiled:boolean);
  1019.   var s:string;aktHdl:hwnd;
  1020.   begin
  1021.     s:=BmpName+#0;
  1022.     if Tiled then
  1023.       WriteProfileString('Desktop','TileWallPaper','1') else
  1024.       WriteProfileString('Desktop','TileWallPaper','0');
  1025.     if Getversion=0003 then
  1026.       begin
  1027.         SetDeskWallPaper(@s[1]);
  1028.         WriteProfileString('Desktop','WallPaper',@s[1]);
  1029.         s:='Desktop'+#0;
  1030.         Sendmessage($FFFF,wm_WinIniChange,0,longint(@s[1]));
  1031.       end else
  1032.       begin
  1033.         SystemParametersInfo(
  1034.           spi_SetDeskWallPaper,0,@s[1],
  1035.           spif_UpdateIniFile+
  1036.           spif_SendWinIniChange);
  1037.       end;
  1038.    AktHdl:=GetDesktopWindow;
  1039.    InvalidateRect(akthdl,nil,true);
  1040.    akthdl:=getWindow(akthdl,gw_child);
  1041.    while akthdl<>0 do
  1042.      begin
  1043.        If IsIconic(AktHdl) then
  1044.          InvalidateRect(akthdl,nil,true);
  1045.        AktHdl:=GetWindow(akthdl,gw_hwndnext);
  1046.      end;
  1047.  end;
  1048.  
  1049. procedure DlgPos(hWindow:hwnd;entry:string;save:boolean);
  1050.   var hw:hwnd;
  1051.   begin
  1052.     {If GetVersion=3 then exit;}
  1053.     If Save then
  1054.       begin
  1055.         if not WriteWindowPosition(hWindow,wp_position,inifile,'Dialogs',Entry) then
  1056.           message('Schreibfehler bei der Sicherung der Position von '+ entry+'!',17);
  1057.       end else
  1058.       begin
  1059.         ReadWindowPosition(hWindow,wp_position,inifile,'Dialogs',Entry);
  1060.       end;
  1061.   end;
  1062.  
  1063. (*************************************************************************
  1064. constructor TEngineDlgWindow.init(AParent:PWindowsObject;AName:Pchar;
  1065.                     FirstDelay,StandardDelay:Integer);
  1066.   begin
  1067.     TDlgWindow.Init(AParent,AName);
  1068.     move(aname^,ResName[1],strlen(aname)+1);
  1069.     str_pas(ResName);
  1070.     FirstPeriod:=FirstDelay;
  1071.     TimerPeriod:=Standarddelay;
  1072.     FirstTimer:=True;
  1073.     TimerEvent:=$ff;
  1074.     Timer:=0;
  1075.     AutoPosition:=True;
  1076.   end;
  1077.  
  1078. procedure TEngineDlgWindow.SetupWindow;
  1079.   begin
  1080.     TDlgWindow.SetupWindow;
  1081.     {If AutoPosition then DlgPos(hWindow,resname,wp_restore);}
  1082.     if FirstPeriod>0 then Timer:=settimer(hwindow,TimerEvent,FirstPeriod,nil);
  1083.   end;
  1084.  
  1085. procedure TEngineDlgWindow.quit;
  1086.   begin
  1087.     If Timer>0 then Killtimer(hWindow,Timer);
  1088.     If AutoPosition then
  1089.       begin
  1090.         {DlgPos(hWindow,resname,wp_save);}
  1091.       end;
  1092.   end;
  1093.  
  1094. procedure TEngineDlgWindow.wmtimer;
  1095.   var s,sa,sb:string;i,j,anz:integer;cst:tcomstat;
  1096.  
  1097.   begin
  1098.     if firsttimer then
  1099.       begin
  1100.         firsttimer:=false;
  1101.         killtimer(hwindow,timer);
  1102.         message('First Timer',17);
  1103.         FirstTimerEvent(msg);
  1104.         If TimerPeriod>0 then timer:=settimer(hwindow,TimerEvent,TimerPeriod,nil);
  1105.       end
  1106.      else
  1107.       begin
  1108.         StandardTimerEvent(msg);
  1109.         messagebeep(0);
  1110.       end;
  1111.   end;
  1112.  
  1113. procedure TEngineDlgWindow.FirstTimerEvent(var msg:TMessage);
  1114.   begin
  1115.   end;
  1116.  
  1117. procedure TEngineDlgWindow.StandardTimerEvent(var msg:Tmessage);
  1118.   begin
  1119.   end;
  1120.  
  1121. **************************************************************************)
  1122.  
  1123. procedure message;
  1124.   var sh:string;c,l,t:integer;
  1125.   begin
  1126.     sh:=s+#0;
  1127.     c:=icon div 16;
  1128.     l:=icon and 15;
  1129.     t:=mb_taskmodal;
  1130.     case l of
  1131.       0:t:=t or mb_iconstop;
  1132.       1:t:=t or mb_iconinformation;
  1133.       end;
  1134.     case c of
  1135.       0:messagebox(0,@sh[1],'Fehler',t);
  1136.       1:messagebox(0,@sh[1],'Zur Beachtung',t);
  1137.       2:messagebox(0,@sh[1],'Information',t);
  1138.       end;
  1139.   end;
  1140.  
  1141. function Continue;
  1142.   var sh:string;c,l,t:integer;
  1143.   begin
  1144.     sh:=s+#0;
  1145.     c:=icon div 16;
  1146.     l:=icon and 15;
  1147.     t:=mb_taskmodal;
  1148.     case l of
  1149.       0:t:=t or mb_iconstop or mb_YesNo;
  1150.       1:t:=t or mb_iconinformation or mb_YesNo;
  1151.       end;
  1152.     case c of
  1153.       0:t:=messagebox(0,@sh[1],'Fehler',t);
  1154.       1:t:=messagebox(0,@sh[1],'Zur Beachtung',t);
  1155.       2:t:=messagebox(0,@sh[1],'Information',t);
  1156.       end;
  1157.     Continue:=t=IdYes;
  1158.   end;
  1159.  
  1160. function RectMeetsDialogObject(R:TRect;hWndDialogObject,hWndDialogWindow:hWnd):boolean;
  1161.     var p:tpoint;graphrect:trect;
  1162.     begin
  1163.       RectMeetsDialogObject:=false;
  1164.       getclientrect(hWndDialogObject,graphrect);
  1165.  
  1166.       p.x:=graphrect.left;
  1167.       p.y:=graphrect.top;
  1168.       clienttoscreen(hWndDialogObject,p);
  1169.       screentoclient(hWndDialogWindow,p);
  1170.       graphrect.left:=p.x;
  1171.       graphrect.top :=p.y;
  1172.  
  1173.       p.x:=graphrect.right;
  1174.       p.y:=graphrect.bottom;
  1175.       clienttoscreen(hWndDialogObject,p);
  1176.       screentoclient(hWndDialogWindow,p);
  1177.       graphrect.right :=p.x;
  1178.       graphrect.bottom:=p.y;
  1179.  
  1180.       if ((r.right>graphrect.left) and (r.right<graphrect.right)) or
  1181.          ((r.left >graphrect.left) and (r.left <graphrect.right)) or
  1182.          ((r.left <graphrect.left) and (r.right>graphrect.right))
  1183.          then
  1184.         begin
  1185.           if ((r.top   >graphrect.top) and (r.top   <graphrect.bottom)) or
  1186.              ((r.bottom>graphrect.top) and (r.bottom<graphrect.bottom)) or
  1187.              ((r.top   <graphrect.top) and (r.bottom>graphrect.bottom))
  1188.              then RectMeetsDialogObject:=true;
  1189.         end;
  1190.     end;
  1191.  
  1192. procedure up(var s:string);
  1193.   var i:word;
  1194.   begin
  1195.     for i:=1 to length(s) do s[i]:=upcase(s[i]);
  1196.   end;
  1197.  
  1198. procedure upl(var s:string);
  1199.   var i:word;
  1200.   begin
  1201.     if s='' then exit;
  1202.     i:=0;
  1203.     repeat
  1204.       inc(i);
  1205.       s[i]:=upcase(s[i]);
  1206.     until (s[i]='@') or (i=length(s));
  1207.   end;
  1208.  
  1209. procedure alphanum(var s:string);
  1210.   var sh:string;i:integer;
  1211.   begin
  1212.     sh:='';
  1213.     for i:=1 to length(s) do if s[i] in ['0'..'9','_','A'..'Z','a'..'z'] then sh:=sh+s[i];
  1214.     s:=sh;
  1215.   end;
  1216.  
  1217. procedure sread;
  1218.   const   gueltige_zeichen:set of char=['+','-','0'..'9','.','E','e'];
  1219.   var     zahl:string[40];exponent,punkt  :boolean;c:char;
  1220.           p,e:byte;i:integer;result:extended;
  1221.   label   sp0,sp1,sp2;
  1222.   begin
  1223.     zahl:='';fehler:=false;
  1224.     sp0:
  1225.     if l='' then
  1226.       begin
  1227.         fehler:=true;exit
  1228.       end;
  1229.     if not (l[1] in gueltige_zeichen) then
  1230.       begin
  1231.         delete(l,1,1);goto sp0
  1232.       end;
  1233.     punkt:=false;exponent:=false;
  1234.     sp2:
  1235.     c:=upcase(l[1]);delete(l,1,1);
  1236.     if c='E' then
  1237.       begin
  1238.         if length(zahl)=0 then goto sp0;
  1239.         if exponent then goto sp1 else exponent:=true;
  1240.       end;
  1241.     if c='.' then
  1242.       begin
  1243.         if punkt or exponent  then l:=c+l;
  1244.         if exponent then goto sp1;
  1245.         if punkt    then goto sp1 else punkt:=true;
  1246.       end;
  1247.     zahl:=zahl+c;
  1248.     if l='' then goto sp1;
  1249.     if l[1] in gueltige_zeichen then goto sp2;
  1250.     sp1:
  1251.     p:=pos('.',zahl);e:=pos('E',zahl);
  1252.     if e=1 then zahl:='1'+zahl;
  1253.     if (p=1) and (length(zahl)=1) then zahl:=zahl+'0';
  1254.     if (p>0) and (p=pred(e)) then insert('0',zahl,p+1);
  1255.     val(zahl,result,i);
  1256.     if i=0 then
  1257.       begin
  1258.         r:=result;fehler:=false
  1259.       end
  1260.      else fehler:=true;
  1261.   end; (* sread .. *)
  1262.  
  1263. function intread(var s:string;var wert:integer):boolean;
  1264.   var r:extended;error:boolean;
  1265.   begin
  1266.     sread(s,r,error);
  1267.     intread:=error;
  1268.     wert:=trunc(r);
  1269.   end;
  1270.  
  1271. function extread(var s:string;var wert:extended):boolean;
  1272.   var r:extended;error:boolean;
  1273.   begin
  1274.     sread(s,r,error);
  1275.     extread:=error;
  1276.     wert:=r;
  1277.   end;
  1278.  
  1279. function HelpItem (Item:Integer):integer;
  1280.   begin
  1281.     if item=0 then
  1282.     winhelp(0,@helpfile[1],help_index,0) else
  1283.     winhelp(0,@helpfile[1],help_context,item);
  1284.   end;
  1285.  
  1286. function MakeEngineFont(Fontdescriptor:string):hfont;
  1287.   var font,oldfont:hfont;ff,fw,italic:word;faktor:extended;dc:hdc;
  1288.       s,fn:string;fp:pchar;
  1289.       vHoehe,j,c:integer;vFett,vKursiv:boolean;vSwiss:longint;
  1290.   begin
  1291.     if optioncount(fontdescriptor)<3 then
  1292.       begin
  1293.         vHoehe:=10;
  1294.         vFett:=true;
  1295.         vKursiv:=false;
  1296.         vSwiss:=1 shl 5;
  1297.       end
  1298.      else
  1299.       begin
  1300.         s:=optionstring(fontdescriptor,1);
  1301.         valid(s);val(s,j,c);
  1302.         If c=0 then vHoehe:=j else vHoehe:=10;
  1303.         s:=optionstring(fontdescriptor,2);
  1304.         valid(s);val(s,j,c);
  1305.         If (c=0) and (j=0) then vFett:=false else vfett:=true;
  1306.         s:=optionstring(fontdescriptor,3);
  1307.         valid(s);val(s,j,c);
  1308.         If (c=0) and (j=1) then vkursiv:=true else vkursiv:=false;
  1309.         s:=optionstring(fontdescriptor,4);
  1310.         valid(s);val(s,j,c);
  1311.         If c=0 then vSwiss:=1 shl j else vSwiss:=5 shl j;
  1312.       end;
  1313.  
  1314.     faktor:=vhoehe;
  1315.     case vSwiss of
  1316.       1:begin ff:=ff_swiss;fp:=nil end;
  1317.       2:begin ff:=ff_roman;fp:=nil end;
  1318.       4:begin ff:=ff_dontcare;fn:='Modern'#0;fp:=@fn[1] end;
  1319.       8:begin ff:=ff_dontcare;fn:='Courier'#0;fp:=@fn[1];
  1320.         end;
  1321.     16:begin ff:=ff_dontcare;fn:='Symbol'#0;fp:=@fn[1]; end;
  1322.       else
  1323.         begin ff:=ff_dontcare;fn:='System'#0;fp:=@fn[1]; end;
  1324.       end;
  1325.     If vfett then fw:=fw_bold else fw:=fw_normal;
  1326.     If vkursiv then italic:=word(true) else italic:=word(false);
  1327.     font:=CreateFont(
  1328.              round(faktor),        {H÷he}
  1329.              0,                    {Breite}
  1330.              0,                    {Rotation der Textbasislinie}
  1331.              0,                    {Kippung der Zeichen gegen die Textlinie}
  1332.              fw,                   {weight}
  1333.              italic,               {kursiv}
  1334.              0,                    {nicht unterstreichen}
  1335.              0,                    {nicht durchstreichen}
  1336.              0,                    {ANSI-Zeichensatz}
  1337.              out_character_precis, {ZeichenprΣzision n.i.}
  1338.              clip_character_precis,{Standard Clip-PrΣzision}
  1339.              proof_quality,        {QualitΣt}
  1340.              default_pitch         {Proportional nicht erlauben}
  1341.              or ff,                {Fontfamilie vorschreiben}
  1342.              fp);
  1343.     If font<>0 then
  1344.       begin
  1345.         MakeEngineFont:=font;
  1346.       end else begin MakeEngineFont:=0; end;
  1347.   end;
  1348.  
  1349. function MakeFont(hoehe:integer;bold,kursiv:boolean;family:byte):hfont;
  1350.   var font,oldfont:hfont;
  1351.       ff,fw,italic:word;faktor:extended;
  1352.       dc:hdc;
  1353.       s,fn:string;
  1354.       fp:pchar;
  1355.       vHoehe,j,c:integer;
  1356.       vFett,vKursiv:boolean;
  1357.       vSwiss:longint;
  1358.   begin
  1359.     vHoehe:=hoehe;
  1360.     vFett:=bold;
  1361.     vKursiv:=kursiv;
  1362.     vSwiss:=1 shl family;
  1363.  
  1364.     faktor:=vhoehe;
  1365.     case vSwiss of
  1366.       1:begin ff:=ff_swiss;fp:=nil end;
  1367.       2:begin ff:=ff_roman;fp:=nil end;
  1368.       4:begin ff:=ff_dontcare;fn:='Modern'#0;fp:=@fn[1] end;
  1369.       8:begin ff:=ff_dontcare;fn:='Courier'#0;fp:=@fn[1];
  1370.         end;
  1371.     16:begin ff:=ff_dontcare;fn:='Symbol'#0;fp:=@fn[1]; end;
  1372.       else
  1373.         begin ff:=ff_dontcare;fn:='System'#0;fp:=@fn[1]; end;
  1374.       end;
  1375.     If vfett then fw:=fw_bold else fw:=fw_normal;
  1376.     If vkursiv then italic:=word(true) else italic:=word(false);
  1377.     font:=CreateFont(
  1378.              round(faktor),        {H÷he}
  1379.              0,                    {Breite}
  1380.              0,                    {Rotation der Textbasislinie}
  1381.              0,                    {Kippung der Zeichen gegen die Textlinie}
  1382.              fw,                   {weight}
  1383.              italic,               {kursiv}
  1384.              0,                    {nicht unterstreichen}
  1385.              0,                    {nicht durchstreichen}
  1386.              0,                    {ANSI-Zeichensatz}
  1387.              out_character_precis, {ZeichenprΣzision n.i.}
  1388.              clip_character_precis,{Standard Clip-PrΣzision}
  1389.              proof_quality,        {QualitΣt}
  1390.              default_pitch         {Proportional nicht erlauben}
  1391.              or ff,                {Fontfamilie vorschreiben}
  1392.              fp);
  1393.     If font<>0 then
  1394.       begin
  1395.         MakeFont:=font;
  1396.       end else begin MakeFont:=0; end;
  1397.   end;
  1398.  
  1399. function MakeRotFont(hoehe,rot:integer;bold,kursiv:boolean;family:byte):hfont;
  1400.   var font,oldfont:hfont;
  1401.       ff,fw,italic:word;faktor:extended;
  1402.       dc:hdc;
  1403.       s,fn:string;
  1404.       fp:pchar;
  1405.       vHoehe,j,c:integer;
  1406.       vFett,vKursiv:boolean;
  1407.       vSwiss:longint;
  1408.   begin
  1409.     vHoehe:=hoehe;
  1410.     vFett:=bold;
  1411.     vKursiv:=kursiv;
  1412.     vSwiss:=1 shl family;
  1413.  
  1414.     faktor:=vhoehe;
  1415.     case vSwiss of
  1416.       1:begin ff:=ff_swiss;fp:=nil end;
  1417.       2:begin ff:=ff_roman;fp:=nil end;
  1418.       4:begin ff:=ff_dontcare;fn:='Modern'#0;fp:=@fn[1] end;
  1419.       8:begin ff:=ff_dontcare;fn:='Courier'#0;fp:=@fn[1];
  1420.         end;
  1421.     16:begin ff:=ff_dontcare;fn:='Symbol'#0;fp:=@fn[1]; end;
  1422.       else
  1423.         begin ff:=ff_dontcare;fn:='System'#0;fp:=@fn[1]; end;
  1424.       end;
  1425.     If vfett then fw:=fw_bold else fw:=fw_normal;
  1426.     If vkursiv then italic:=word(true) else italic:=word(false);
  1427.     font:=CreateFont(
  1428.              round(faktor),        {H÷he}
  1429.              0,                    {Breite}
  1430.              rot*10,               {Rotation der Textbasislinie}
  1431.              rot*10,               {Kippung der Zeichen gegen die Textlinie}
  1432.              fw,                   {weight}
  1433.              italic,               {kursiv}
  1434.              0,                    {nicht unterstreichen}
  1435.              0,                    {nicht durchstreichen}
  1436.              0,                    {ANSI-Zeichensatz}
  1437.              out_character_precis, {ZeichenprΣzision n.i.}
  1438.              clip_character_precis,{Standard Clip-PrΣzision}
  1439.              proof_quality,        {QualitΣt}
  1440.              default_pitch         {Proportional nicht erlauben}
  1441.              or ff,                {Fontfamilie vorschreiben}
  1442.              fp);
  1443.  
  1444.     If font<>0 then
  1445.       begin
  1446.         MakeRotFont:=font;
  1447.       end else begin MakeRotFont:=0; end;
  1448.   end;
  1449.  
  1450. procedure dispatch(hw:hwnd);
  1451.   var msg:tmsg;
  1452.   begin
  1453.     while peekmessage(msg,hw,0,0,pm_remove) do
  1454.       begin
  1455.         translatemessage(msg);
  1456.         dispatchmessage(msg);
  1457.       end;
  1458.   end;
  1459.  
  1460. function LoCase(ch:char):char;
  1461.   const offset=ord('a')-ord('A');
  1462.   begin
  1463.     case ch of
  1464.       'A'..'Z':ch:=char(ord(ch)+offset);
  1465.       '─':ch:='Σ';
  1466.       '▄':ch:='ⁿ';
  1467.       '╓':ch:='÷';
  1468.       end;
  1469.   end;
  1470.  
  1471. function GetHeapSpaces(w:word):longint;external 'KERNEL' index 138;
  1472.  
  1473. procedure memorymessage;
  1474.   var freekb,freegdi,freeuser:word;space:longint;
  1475.       s,s1,s2:string;
  1476.   begin
  1477.     freekb:=getfreespace(0) div 1024;
  1478.     str(freekb,s);s:='Speicherbelegung:'#13#10#13#10'Globaler Speicher: '+s +' KB'#13#10;
  1479.     space:=getheapspaces(getmodulehandle('GDI'));
  1480.     str(loword(space),s1);str(hiword(space),s2);
  1481.     s:=s+'GDI: '+s1+' von '+s2+#13#10;
  1482.     space:=getheapspaces(getmodulehandle('USER'));
  1483.     str(loword(space),s1);str(hiword(space),s2);
  1484.     s:=s+'USER: '+s1+' von '+s2;
  1485.     message(s,33);
  1486.   end;
  1487.  
  1488. function hexstr(w:word):string;
  1489.  
  1490.   function hexb(b:byte):string;
  1491.  
  1492.     function  hex(nibble:byte):char;
  1493.       begin if nibble>9 then hex:=char(nibble+55) else hex:=char(nibble+48) end;
  1494.  
  1495.     begin hexb:=hex(b shr 4)+hex(b and 15) end;
  1496.  
  1497.   begin hexstr:=hexb(hi(w))+hexb(lo(w)) end;
  1498.  
  1499.  
  1500. Function DlgToClientX (x, Units: Integer): Integer;
  1501. {DlgToClientX:= x*Units Div 4}
  1502. Inline($59/$58/    {Pop Cx Ax}
  1503.        $F7/$E1/    {Mul Cx}
  1504.        $D1/$E8/    {Shr Ax,1}
  1505.        $D1/$E8);   {Shr Ax,1}
  1506.  
  1507. Function DlgToClientY (y, Units: Integer): Integer;
  1508. {DlgToClientY:= y*Units Div 8}
  1509. Inline($59/$58/    {Pop Cx Ax}
  1510.        $F7/$E1/    {Mul Cx}
  1511.        $D1/$E8/    {Shr Ax,1}
  1512.        $D1/$E8/    {Shr Ax,1}
  1513.        $D1/$E8);   {Shr Ax,1}
  1514.  
  1515. procedure CalcDialogUnits(fontname:pchar;height:integer;
  1516.                           var wunitsx,wunitsy:integer);
  1517.  
  1518.   {-create the dialog font and calculate dialog units based on font}
  1519.  
  1520.   Const aWidthString =
  1521.         'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  1522.  
  1523.   Var   aDC: hDC;
  1524.         anOldFont,font: hFont;
  1525.         aLogFont: tLogFont;
  1526.         aTextMetric: tTextMetric;
  1527.  
  1528.   Begin
  1529.     aDC:= GetDC(0);
  1530.     If FontName=Nil Then Font:= GetStockObject(System_Font)
  1531.       else
  1532.       Begin
  1533.         FillChar(aLogFont,SizeOf(aLogFont),0);
  1534.         With aLogFont Do
  1535.           Begin
  1536.             StrCopy(lfFaceName,FontName);
  1537.             lfHeight:=-MulDiv(height,
  1538.                        GetDeviceCaps(aDC, LogPixelsY),72);
  1539.             lfWeight:= FW_BOLD
  1540.           End;
  1541.         Font:= CreateFontIndirect(aLogFont)
  1542.       End;
  1543.     anOldFont:= SelectObject(aDC, Font);
  1544.     GetTextMetrics(aDC, aTextMetric);
  1545.     {-use the Microsoft recommended way to retrieve average width}
  1546.     wUnitsX:= Word(GetTextExtent(aDC, aWidthString,
  1547.               Length(aWidthString))) Div Length(aWidthString);
  1548.     wUnitsY:= aTextMetric.tmHeight;
  1549.     SelectObject(aDC, anOldFont);
  1550.     ReleaseDC(0, aDC)
  1551.   End;
  1552.  
  1553. procedure GetWindowUnits(var x,y:integer;xUnits,yUnits:integer);
  1554.   begin
  1555.     x:=DlgToClientX (x, xUnits);
  1556.     y:=DlgToClientY (y, yUnits);
  1557.   end;
  1558.  
  1559. function CreateDialogChild(hWindow:hwnd;
  1560.             Class,Text:string;
  1561.             Style:longint;
  1562.             ID:word;
  1563.             x,y,w,h:integer;borstyle:boolean):boolean;
  1564.  
  1565.   Var aCtl:hWnd;szClass,szTitle:array[0..100] of char;
  1566.   Begin
  1567.     if not borstyle then
  1568.       begin
  1569.         If (class='BorBtn') or (class='BorCheck') or
  1570.            (class='BorRadio') or (class='BorShade') then class:='BUTTON';
  1571.       end;
  1572.     strpcopy(szclass,class);
  1573.     strpcopy(sztitle,text);
  1574.     aCtl:= CreateWindowEx(
  1575.               ws_Ex_NoParentNotify,
  1576.               @szClass,
  1577.               @szTitle,
  1578.               Style,
  1579.               x,y,w,h,
  1580.               hWindow,ID,System.hInstance,nil);
  1581.     CreateDialogChild:=actl<>0;
  1582.   End;
  1583.  
  1584. var pbuffer:string;
  1585.  
  1586. constructor TBorShade.Init(Aparent:Pwindowsobject;
  1587.   AnID:integer;Atext:pchar;x,y,w,h:integer;default:boolean;astyle:byte);
  1588.   begin
  1589.     tbutton.init(Aparent,AnID,Atext,x,y,w,h,default);
  1590.     attr.style:=(attr.style and $fffffff0) or astyle;
  1591.   end;
  1592.  
  1593. function TBorShade.GetClassName;
  1594.   begin
  1595.     strcopy(@pbuffer,'borshade');
  1596.     GetClassName:=@pbuffer;
  1597.   end;
  1598.  
  1599. function TBorButton.GetClassName;
  1600.   begin
  1601.     strcopy(@pbuffer,'borbtn');
  1602.     GetClassName:=@pbuffer;
  1603.   end;
  1604.  
  1605. function TBorRadio.GetClassName;
  1606.   begin
  1607.     strcopy(@pbuffer,'borradio');
  1608.     GetClassName:=@pbuffer;
  1609.   end;
  1610.  
  1611. function TBorCheck.GetClassName;
  1612.   begin
  1613.     strcopy(@pbuffer,'borcheck');
  1614.     GetClassName:=@pbuffer;
  1615.   end;
  1616.  
  1617. function GetElementID(s:string):string;
  1618.   var sh:string;p,l:byte;
  1619.   const OK:set of char=['0'..'9'];
  1620.   begin
  1621.     sh:=s;valid(sh);
  1622.     p:=pos('/',sh)+1;
  1623.     l:=0;
  1624.     while (sh[p+l] in ok) and ((p+l)<=length(sh)) do inc(l);
  1625.     GetElementID:=copy(sh,p,l);
  1626.   end;
  1627.  
  1628. function GetElementName(s:string):string;
  1629.   var sh:string;p:integer;
  1630.   begin
  1631.     sh:=s;valid(sh);
  1632.     p:=pos('=',sh)-1;
  1633.     if p>0 then
  1634.     GetElementName:=copy(sh,1,p) else GetElementName:='';
  1635.   end;
  1636.  
  1637. function ClipExtension(s:string):string;
  1638.   var
  1639.      Dir: array[0..fsDirectory] of Char;
  1640.      Name: array[0..fsFileName] of Char;
  1641.      Ext: array[0..fsExtension] of Char;
  1642.      path:string;
  1643.   begin
  1644.     path:=s+#0;
  1645.     FileSplit(@Path[1], Dir, Name, Ext);
  1646.     strcopy(@path[1],dir);
  1647.     strcat(@path[1],name);
  1648.     str_pas(path);
  1649.     ClipExtension:=path;
  1650.   end;
  1651.  
  1652. function GetPath(s:string):string;
  1653.   var
  1654.      Dir: array[0..fsDirectory] of Char;
  1655.      Name: array[0..fsFileName] of Char;
  1656.      Ext: array[0..fsExtension] of Char;
  1657.      path:string;
  1658.   begin
  1659.     path:=s+#0;
  1660.     FileSplit(@Path[1], Dir, Name, Ext);
  1661.     strcopy(@path[1],dir);
  1662.     str_pas(path);
  1663.     GetPath:=path;
  1664.   end;
  1665.  
  1666. function Lastpos(ch:char;s:string):integer;
  1667.   var i:integer;
  1668.   begin
  1669.     Lastpos:=0;for i:=1 to length(s) do If s[i]=ch then LastPos:=i;
  1670.   end;
  1671.  
  1672. function ResStr(i:integer):string;
  1673.   var s:string;
  1674.   begin
  1675.     s:='';
  1676.     If LoadString(hinstance,i+1000*wt_language,@s[1],255)>0 then str_pas(s);
  1677.     ResStr:=s;
  1678.   end;
  1679.  
  1680. function ResPChar(i:integer):pchar;
  1681.   begin
  1682.     strcopy(@ResStrings,'');
  1683.     LoadString(hinstance,i+1000*wt_language,@ResStrings,255);
  1684.     ResPChar:=@ResStrings;
  1685.   end;
  1686.  
  1687. constructor TWatchEdit.init;
  1688.   var i:integer;s:string;
  1689.   begin
  1690.     tedit.init(aparent,id,'',x,y,w,h,15,false);
  1691.     maxlength:=max;
  1692.     value:='';
  1693.     german:=es_german and style<>0;
  1694.     bell:=es_bell and style<>0;
  1695.     box:=es_box and style<>0;
  1696.     name:=es_name and style<>0;
  1697.     warning:=0;
  1698.     intern:=false;
  1699.     charmode:=_charmode;
  1700.     case charmode of
  1701.       0:begin {....................................... alle Zeichen erlaubt}
  1702.  
  1703.           for i:=0 to 255 do allowedchars[i]:=#1;
  1704.  
  1705.         end;
  1706.       1:begin {......................... erweiterte alphanumerische Zeichen}
  1707.  
  1708.           s:='';for i:=32 to  255 do s:=s+char(i);valid(s);
  1709.           for i:=0 to 255 do allowedchars[i]:=#0;
  1710.           for i:=1 to length(s) do allowedchars[ord(s[i])]:=#1;
  1711.  
  1712.         end;
  1713.       2:begin {.................................... alphanumerische Zeichen}
  1714.  
  1715.           s:='';for i:=32 to  255 do s:=s+char(i);ASCII(s);
  1716.           for i:=0 to 255 do allowedchars[i]:=#0;
  1717.           for i:=1 to length(s) do allowedchars[ord(s[i])]:=#1;
  1718.  
  1719.         end;
  1720.       3:begin {................................... Nutzerdefinierte Zeichen}
  1721.  
  1722.           for i:=0 to 255 do allowedchars[i]:=#1;
  1723.  
  1724.         end;
  1725.  
  1726.       end;
  1727.   end;
  1728.  
  1729. constructor TWatchEdit.initresource(AParent:PWindowsObject;ID:Word;
  1730.        max:integer;style:word;_charmode:integer);
  1731.   var i:integer;s:string;
  1732.   begin
  1733.  
  1734.     tedit.initresource(aparent,id,max+1);
  1735.     maxlength:=max;
  1736.     value:='';
  1737.     german:=es_german and style<>0;
  1738.     bell:=es_bell and style<>0;
  1739.     box:=es_box and style<>0;
  1740.     name:=es_name and style<>0;
  1741.     warning:=0;
  1742.     intern:=false;
  1743.     charmode:=_charmode;
  1744.     case charmode of
  1745.       0:begin {....................................... alle Zeichen erlaubt}
  1746.  
  1747.           for i:=0 to 255 do allowedchars[i]:=#1;
  1748.  
  1749.         end;
  1750.       1:begin {......................... erweiterte alphanumerische Zeichen}
  1751.  
  1752.           s:='';for i:=32 to  255 do s:=s+char(i);valid(s);
  1753.           for i:=0 to 255 do allowedchars[i]:=#0;
  1754.           for i:=1 to length(s) do allowedchars[ord(s[i])]:=#1;
  1755.  
  1756.         end;
  1757.       2:begin {.................................... alphanumerische Zeichen}
  1758.  
  1759.           s:='';for i:=32 to  255 do s:=s+char(i);ASCII(s);
  1760.           for i:=0 to 255 do allowedchars[i]:=#0;
  1761.           for i:=1 to length(s) do allowedchars[ord(s[i])]:=#1;
  1762.  
  1763.         end;
  1764.       3:begin {................................... Nutzerdefinierte Zeichen}
  1765.  
  1766.           for i:=0 to 255 do allowedchars[i]:=#1;
  1767.  
  1768.         end;
  1769.  
  1770.       end;
  1771.   end;
  1772.  
  1773. procedure TWatchEdit.SetupWindow;
  1774.   var l:word;rect:trect;pt:tpoint;
  1775.   begin
  1776.     TEdit.SetupWindow;
  1777.   end;
  1778.  
  1779. function  TWatchEdit.Control:boolean;
  1780.   var s,s1,old:string;i,j,k:integer;
  1781.       gr,refresh,found:boolean;error:integer;ch:char;
  1782.  
  1783.   procedure MakeName(var s:string);
  1784.     var i:integer;modified:boolean;
  1785.     function upc(ch:char):char;
  1786.       begin
  1787.         case ch of
  1788.           'ⁿ':upc:='▄';
  1789.           'Σ':upc:='─';
  1790.           '÷':upc:='╓';
  1791.           else
  1792.           upc:=upcase(ch);
  1793.           end;
  1794.       end;
  1795.     begin
  1796.       If s='' then exit;
  1797.       modified:=false;
  1798.       If (s[1] in ['a'..'z','Σ','ⁿ','÷']) then
  1799.         begin
  1800.           modified:=true;
  1801.           s[1]:=upc(s[1]);
  1802.         end;
  1803.       s[1]:=upcase(s[1]);
  1804.       for i:=2 to length(s) do
  1805.         begin
  1806.           If (not (upc(s[i-1]) in ['A'..'Z','─','╓','▄'])) and
  1807.                   (s[i] in ['a'..'z','Σ','÷','ⁿ']) then
  1808.             begin
  1809.               error:=3;
  1810.               modified:=true;
  1811.               s[i]:=upc(s[i]);
  1812.             end;
  1813.         end;
  1814.       if modified and (not found) then
  1815.         begin
  1816.           refresh:=true;
  1817.         end;
  1818.     end;
  1819.  
  1820.   begin
  1821.     If not IsModified then exit;
  1822.     If intern then exit;
  1823.     intern:=true;
  1824.     refresh:=false;found:=false;error:=0;ch:=#0;control:=false;
  1825.     gr:=false;
  1826.     getwindowtext(hwindow,@s[1],255);str_pas(s);s1:=s;
  1827.     If s='' then
  1828.       begin
  1829.         intern:=false;
  1830.         control:=false;
  1831.         exit;
  1832.       end;
  1833.  
  1834.     old:=s;
  1835.     if length(s)>maxlength then
  1836.       begin
  1837.         inc(warning);
  1838.         found:=true;
  1839.         error:=1;
  1840.         s:=system.copy(s,1,maxlength);
  1841.         refresh:=true;
  1842.       end;
  1843.     for i:=1 to length(s) do if (allowedchars[ord(s[i]) and $ff]=#0) then
  1844.       begin
  1845.         error:=2;
  1846.         found:=true;
  1847.         If ch=#0 then ch:=s[i];
  1848.         refresh:=true;
  1849.         system.delete(s,i,1);
  1850.         inc(warning);
  1851.       end;
  1852.     If german then
  1853.       begin
  1854.         umlaute(s1);
  1855.         if s<>s1 then
  1856.           begin
  1857.             refresh:=true;
  1858.             gr:=true;
  1859.           end;
  1860.         s:=s1;
  1861.         if length(s)>maxlength then
  1862.           begin
  1863.             inc(warning);
  1864.             found:=true;
  1865.           end;
  1866.       end;
  1867.     If name then  MakeName(s);
  1868.     If not found then begin value:=s;warning:=0 end else
  1869.       begin
  1870.         If (warning>0) and bell then
  1871.           begin
  1872.             messagebeep(0);
  1873.             If not box then warning:=0;
  1874.           end;
  1875.         If (warning>2) and box then
  1876.           begin
  1877.             str(maxlength,s1);
  1878.             case error of
  1879.               1:s:='Es wurden zu viele Zeichen eingegeben.'#13#10#13#10+
  1880.                    '(maximal '+s1+' Zeichen zugelassen)';
  1881.               2:s:='Es wurde mindestens ein nicht zugelassenes Zeichen'+
  1882.                    ' gefunden. Das erste war '''+ch+'''!';
  1883.               end;
  1884.             If error>0 then message(s,33);
  1885.             warning:=0;
  1886.           end;
  1887.       end;
  1888.     If refresh then
  1889.       begin
  1890.         s:=value+#0;
  1891.         setwindowtext(hwindow,@s[1]);
  1892.         Control:=true;
  1893.         setfocus(hwindow);
  1894.         i:=length(value);
  1895.         k:=0;
  1896.         for i:=1 to length(value) do
  1897.           If (old[i]<>value[i]) and (k=0) then k:=i+1;
  1898.         If gr then inc(k,1);
  1899.         if (k>succ(length(value))) or (error>0) then k:=length(value)+1;
  1900.         setselection(k-1,k-1);
  1901.       end;
  1902.     intern:=false;
  1903.   end;
  1904.  
  1905. procedure TWatchEdit.Settext(s:string);
  1906.   var sh:string;
  1907.   begin
  1908.     sh:=s+#0;
  1909.     SetWindowText(hwindow,@sh[1]);
  1910.   end;
  1911.  
  1912. function TWatchEdit.GetText(var s:string):boolean;
  1913.   begin
  1914.     GetWindowText(hwindow,@s[1],255);
  1915.     str_pas(s)
  1916.   end;
  1917.  
  1918. procedure TWatchEdit.SetCharSet(s:string);
  1919.   var i:integer;
  1920.   begin
  1921.     If charmode<>cm_user then exit;
  1922.     for i:=0 to 255 do allowedchars[i]:=#0;
  1923.     for i:=1 to length(s) do allowedchars[ord(s[i])]:=#1;
  1924.   end;
  1925.  
  1926. procedure TWatchEdit.wmDblClk;
  1927.   var s,s1,s2:string;
  1928.   begin
  1929.     str(maxlength,s);
  1930.     s:='In dieses Feld k÷nnen Sie maximal '+s+' Zeichen eingeben.'#13#10#13#10+
  1931.        'Weiteres:'#13#10;
  1932.     if german then
  1933.        s:=s+'- Umlaute werden ersetzt'#13#10;
  1934.     If name then
  1935.        s:=s+'- Anfangsbuchstaben sind gro▀'#13#10;
  1936.     case charmode of
  1937.       0:s:=s+'- alle Zeichen zugelassen';
  1938.       1:s:=s+'- erweiterte alphanum. Zeichen zugelassen';
  1939.       2:s:=s+'- alphanumerische Zeichen zugelassen';
  1940.       3:s:=s+'- zugelassene Zeichen siehe Handbuch';
  1941.       end;
  1942.     message(s,33);
  1943.     defwndproc(msg);
  1944.   end;
  1945.  
  1946. constructor TFloat.initresource(AParent:PWindowsObject;ID:Word;
  1947.     d,min,max:extended;n,m:word);
  1948.   begin
  1949.     tedit.initresource(aparent,id,15);
  1950.     default:=d;
  1951.     minimum:=min;
  1952.     maximum:=max;
  1953.     stellen:=n;komma:=m;
  1954.   end;
  1955.  
  1956.  
  1957. constructor TFloat.init(AParent:PWindowsObject;ID:Word;x,y,w,h:integer;
  1958.     d,min,max:extended;n,m:word);
  1959.   begin
  1960.     tedit.init(aparent,id,'',x,y,w,h,15,false);
  1961.     default:=d;
  1962.     minimum:=min;
  1963.     maximum:=max;
  1964.     stellen:=n;komma:=m;
  1965.   end;
  1966.  
  1967.  
  1968. procedure TFloat.GetMinMax;
  1969.   begin
  1970.     min:=minimum;
  1971.     max:=maximum;
  1972.   end;
  1973.  
  1974.  
  1975. procedure TFloat.SetVal(v:extended);
  1976.   var s:string;
  1977.   begin
  1978.     value:=v;str(v:stellen:komma,s);s:=s+#0;
  1979.     valid(s);
  1980.     settext(@s[1]);
  1981.   end;
  1982.  
  1983.  
  1984. procedure TFloat.Delta(step:extended);
  1985.   var s:string;neu,r:extended;i:integer;
  1986.   begin
  1987.     GetText(@S[1],255);str_pas(S);
  1988.     val(s,r,i);
  1989.     if i<>0 then
  1990.       begin
  1991.         if wt_sound then messagebeep(0);
  1992.         exit
  1993.       end;
  1994.     GetVal(value);
  1995.     neu:=value+step;
  1996.     if (minimum>neu) or (maximum<neu) then
  1997.       begin if wt_sound then messagebeep(0) end else setval(neu);
  1998.   end;
  1999.  
  2000.  
  2001. function TFloat.legal(var v:extended):boolean;
  2002.   var s:string;neu,r:extended;i:integer;
  2003.   begin
  2004.     legal:=false;v:=value;
  2005.     GetText(@S[1],255);str_pas(S);
  2006.     val(s,r,i);
  2007.     if i<>0 then begin v:=minimum;if wt_sound then messagebeep(0);exit end;
  2008.     value:=r;
  2009.     v:=r;
  2010.     legal:=true;
  2011.   end;
  2012.  
  2013.  
  2014. function TFloat.GetVal(var v:extended):boolean;
  2015.   var i:integer;r:extended;sh,sl:string;error:boolean;s:string;
  2016.   begin
  2017.     GetText(@S[1],255);str_pas(S);valid(s);
  2018.     if s='' then
  2019.       begin v:=Value;GetVal:=false;exit end;
  2020.     val(s,r,i);
  2021.     error:=false;
  2022.     if i<>0 then
  2023.       begin
  2024.         if wt_sound then messagebeep(0);
  2025.         str(r:stellen:komma,sh);
  2026.         sl:='Illegales Zeichen im Text fⁿr eine Flie▀kommazahl!'#13#10#13#10+
  2027.            'Text   : >'+s+'<'+#13#10#13#10+
  2028.            'Zeichen: >'+s[i]+'<'#0;
  2029.         Message(sl,1);
  2030.         r:=default;
  2031.         setval(value);
  2032.         error:=true;
  2033.       end else
  2034.     if (r<minimum) or (r>maximum) then
  2035.       begin
  2036.         if wt_sound then messagebeep(0);
  2037.         s:='Zahl au▀erhalb des  zulΣssigen Bereiches!'#10#13#10#13;
  2038.         str(r:stellen:komma,sh);
  2039.         s:=s+'Wert: '+sh+#10#13;
  2040.         str(minimum:stellen:komma,sh);
  2041.         s:=s+'Bereich: '+sh;
  2042.         str(maximum:stellen:komma,sh);
  2043.         s:=s+' ... ' +sh+#10#13;
  2044.         str(default:stellen:komma,sh);
  2045.         s:=s+'Neuer Wert: '+sh+#0;
  2046.  
  2047.         Message(s,1);
  2048.         r:=default;
  2049.         setval(r);
  2050.         error:=true;
  2051.       end else v:=r;
  2052.     GetVal:=error;
  2053.   end;
  2054.  
  2055. procedure tfloat.wmdblclk;
  2056.   var s,s1,s2:string;
  2057.  
  2058.   procedure short(var s:string);
  2059.     var i:integer;
  2060.     begin
  2061.       valid(s);
  2062.       while (s[length(s)]='0') and (pos('.',s)<>0) do s[0]:=char(pred(length(s)));
  2063.       repeat
  2064.         i:=pos('0E',s);
  2065.         If i<>0 then delete(s,i,1);
  2066.       until i=0;
  2067.       i:=pos('.E',s);
  2068.       If i<>0 then delete(s,i,1);
  2069.       repeat
  2070.         i:=pos('+0',s);
  2071.         If i<>0 then delete(s,i+1,1);
  2072.       until i=0;
  2073.       repeat
  2074.         i:=pos('-0',s);
  2075.         If i<>0 then delete(s,i+1,1);
  2076.       until i=0;
  2077.       if s[length(s)]='.' then s[0]:=char(pred(length(s)));
  2078.     end;
  2079.  
  2080.   begin
  2081.     str(minimum:stellen:komma,s);short(s);
  2082.     str(maximum:stellen:komma,s1);short(s1);
  2083.     str(default:stellen:komma,s2);short(s2);
  2084.     message('Fⁿr diese Zahl ist der Bereich von'#13#10+
  2085.             'minimal '+s+' bis maximal '+s1+' zugelassen.'#13#10+
  2086.             'Als Standardwert wird '+s2+' verwendet.',33);
  2087.     defwndproc(msg);
  2088.   end;
  2089.  
  2090. procedure TFloat.Control(var msg:tmessage);
  2091.   begin
  2092.     {Install your own message handler here!}
  2093.   end;
  2094.  
  2095. procedure TWord.GetMinMax;
  2096.   begin
  2097.     min:=minimum;
  2098.     max:=maximum;
  2099.   end;
  2100.  
  2101.  
  2102. procedure TWord.Delta(step:integer);
  2103.   var s:string;neu,r:extended;i:integer;
  2104.   begin
  2105.     GetText(@S[1],255);str_pas(S);
  2106.     val(s,r,i);
  2107.     if (i<>0) or (abs(r-round(r))>1e-1) then
  2108.       begin
  2109.         if wt_sound then messagebeep(0);
  2110.         exit
  2111.       end;
  2112.     GetVal(value);
  2113.     neu:=value+step;
  2114.     if (minimum>neu) or (maximum<neu) then
  2115.       begin if wt_sound then messagebeep(0) end else setval(trunc(neu));
  2116.   end;
  2117.  
  2118.  
  2119. function Tword.legal(var v:integer):boolean;
  2120.   var s:string;i:integer;r,neu:extended;
  2121.   begin
  2122.     legal:=false;v:=value;
  2123.     GetText(@S[1],255);str_pas(S);
  2124.     val(s,neu,i);
  2125.     if (i<>0) or (abs(neu-round(neu))>1e-1) then
  2126.       begin
  2127.         v:=minimum;
  2128.         if wt_sound then messagebeep(0);
  2129.         exit
  2130.       end;
  2131.     if (neu>minimum) and (neu<maximum) then
  2132.       begin
  2133.         value:=trunc(neu);
  2134.         v:=round(neu);
  2135.         legal:=true;
  2136.       end;
  2137.   end;
  2138.  
  2139.  
  2140. constructor TWord.initresource;
  2141.   begin
  2142.     tedit.initresource(aparent,id,15);
  2143.     default:=d;
  2144.     minimum:=min;
  2145.     maximum:=max;
  2146.     stellen:=n;
  2147.   end;
  2148.  
  2149. constructor TWord.init;
  2150.   begin
  2151.     tedit.init(aparent,id,'',x,y,w,h,15,false);
  2152.     default:=d;
  2153.     minimum:=min;
  2154.     maximum:=max;
  2155.     stellen:=n;
  2156.   end;
  2157.  
  2158. procedure TWord.SetVal;
  2159.   var s:string;
  2160.   begin
  2161.     value:=v;str(v:stellen,s);valid(s);s:=s+#0;
  2162.     settext(@s[1]);
  2163.   end;
  2164.  
  2165. function TWord.GetVal;
  2166.   var i:integer;r:extended;sh:string;error:boolean;s:string;
  2167.   begin
  2168.     GetText(@S[1],255);str_pas(S);
  2169.     if s='' then begin v:=Value;GetVal:=false;exit end;
  2170.     val(s,r,i);
  2171.     error:=false;
  2172.     if (i<>0) then
  2173.       begin
  2174.         if wt_sound then messagebeep(0);
  2175.         sh:='Illegales Zeichen im Text einer ganzen Zahl!'#13#10#13#10+
  2176.            'Text: >'+s+'<'#10#13#0;
  2177.         Message(sh,1);
  2178.         r:=default;
  2179.         setval(default);
  2180.         error:=true;
  2181.       end else
  2182.     {
  2183.     if (abs(r-round(r))>0.1) then
  2184.       begin
  2185.         if wt_sound then messagebeep(0);
  2186.         sh:='This is not a positive integer:'#13#10#13#10'Value: >'+s+'<'#10#13#0;
  2187.         Message(s,1);
  2188.         r:=default;
  2189.         setval(default);
  2190.         error:=true;
  2191.       end else
  2192.     }
  2193.     if (r<minimum) or (r>maximum) then
  2194.       begin
  2195.         if wt_sound then messagebeep(0);
  2196.         s:='Zahl au▀erhalb des zulΣssigen Bereiches!'#10#13#10#13;
  2197.         if (r>-32000) and (r<50000) then str(r:5:0,sh) else str(r:stellen,sh);
  2198.         s:=s+'Wert: '+sh+#10#13;
  2199.         str(minimum:stellen,sh);
  2200.         s:=s+'Bereich: '+sh;
  2201.         str(maximum:stellen,sh);
  2202.         s:=s+' ... ' +sh+#10#13;
  2203.         str(value:stellen,sh);
  2204.         s:=s+'Neuer Wert: '+sh+#0;
  2205.         Message(s,1);
  2206.         r:=value;
  2207.         setval(round(r));
  2208.         error:=true;
  2209.       end else v:=round(r);
  2210.     GetVal:=error;
  2211.   end;
  2212.  
  2213. procedure tword.wmdblclk;
  2214.   var s,s1,s2:string;
  2215.  
  2216.   procedure short(var s:string);
  2217.     begin
  2218.       valid(s);
  2219.       while (s[length(s)]='0') and (pos('.',s)<>0) do s[0]:=char(pred(length(s)));
  2220.       if s[length(s)]='.' then s[0]:=char(pred(length(s)));
  2221.     end;
  2222.  
  2223.   begin
  2224.     str(minimum:stellen,s);short(s);
  2225.     str(maximum:stellen,s1);short(s1);
  2226.     str(default:stellen,s2);short(s2);
  2227.     message('Fⁿr diese Zahl ist der Bereich von'#13#10+
  2228.             'minimal '+s+' bis maximal '+s1+' zugelassen.'#13#10+
  2229.             'Als Standardwert wird '+s2+' verwendet.',33);
  2230.     defwndproc(msg);
  2231.   end;
  2232.  
  2233. procedure TenterEdit.wmchar(var msg:tmessage);
  2234.   var von,bis:integer;
  2235.   begin
  2236.     If msg.wparam=vk_return then
  2237.       begin
  2238.         getselection(von,bis);
  2239.         setselection(bis,bis);
  2240.         insert(#13#10);
  2241.       end else
  2242.     defwndproc(msg);
  2243.   end;
  2244.  
  2245. begin
  2246.   inifile:=ClipExtension(paramstr(0))+'.ini';
  2247.   Programpath:=GetPath(inifile);
  2248.   set_reference(reference);
  2249.   waitcur:=loadcursor(0,idc_wait);
  2250.   helpfile:=ClipExtension(paramstr(0))+'.hlp';
  2251.   valid(helpfile);
  2252.   helpfile:=helpfile+#0;
  2253.   CalcDialogUnits(nil,16,DialogUnitx,Dialogunity);
  2254. end.