unit smsp;
{Sammlung diverser allgemeiner Unterprogramme zum Thema
* Zahlen-Konvertierung
* Zahlen-String-Konvertierung
* Meldungsbox mit String-ID
* Mul und Div (eher Selbstzweck)
}
{$C PRELOAD FIXED}
interface
uses WinProcs,WinTypes,Strings,WinDos,SMSH,UMSTEP;
function GetReal(HWindow:HWnd; ID: Word; var Z:TReal):boolean;
function Real2S(Z:TReal; F:Integer; S:PChar):PChar;
function S2Real(S:PChar; var Z: TReal):boolean;
function Hinweis(Wnd:HWnd; ID:Word; var p):Integer;
function Hinweis1(Wnd:HWnd; ID:Word; S:PChar):Integer; {1 arg}
{Notfalls auch 2 Integer-Argumente mit PChar(MakeLong(Par2,Par1)) }
procedure ShortYield;
function LongMul(F1,F2:Integer):LongInt;
inline($5A/$58/$F7/$EA); {pop dx; pop ax; imul dx}
function ULongMul(F1,F2:Word):LongInt;
inline($5A/$58/$F7/$E2); {pop dx; pop ax; mul dx}
function LongDiv(Z:LongInt; N:Integer):Integer;
inline($59/$58/$5A/$F7/$F9); {pop cx; pop ax; pop dx; idiv cx}
function ULongDiv(Z:LongInt; N:Word):Word;
inline($59/$58/$5A/$F7/$F1); {pop cx; pop ax; pop dx; div cx}
function ULongMod(Z:LongInt; N:Word):Word;
inline($59/$58/$5A/$F7/$F1/$87/$C2);
{pop cx; pop ax; pop dx; div cx; xchg ax,dx}
function GetDlgItemHex(Wnd:HWnd; ID:Word; var W:Word):Boolean;
procedure MotorCallback;
const
AMotor:TMotor=(
Handle: 0;
CFlags: MC_Trapeze or MC_Table;
RefW: $0101;
PortHWE: $2C0;
PortA: $2C0;
PortB: $2C1;
CallbackAddr: @MotorCallback;
CallbackDS: Seg(HInstance);
CallbackUser: 0;
MaxSpeed: 48*65536;
RefSpeed: 12*65536;
MaxAccel: 48;
Refpoint: 0;
LeftBound: -MaxLongInt;
RightBound: +MaxLongInt;
EndW: $0303;
BrakeW: $0000);
procedure SetMotorStruc;
function GetFileNamePtr(S:PChar):PChar;
const
ARV_CantRemove = 1;
ARV_CantAdd = 2;
ARV_FailCreateTempFile = -2;
ARV_FailOpenSystemIni = -3;
ARV_FailReadWrite = -4;
ARV_FailDelete = -5;
ARV_FailRename = -6;
function AddRemoveVxD(AddPath,RemovVxD:PChar):Integer;
implementation
function GetReal(HWindow:HWnd; ID: Word; var Z:TReal):boolean;
var
S: TS31;
begin
GetDlgItemText(HWindow,ID,S,sizeof(S));
GetReal:=S2Real(S,Z);
end;
function Real2S(Z:TReal; F:Integer; S:PChar):PChar;
{Diese Funktion arbeitet wie Str(Z:F:F,S), jedoch werden unnötige
Nachkommastellen (Nullen) abgeschnitten}
{STR erwartet String-Längenangabe; daher mit wildem Typecast ruhigstellen}
begin
Str(Z:F:F,TS255(Pointer(S)^)); {mittels Systemfunktion wandeln}
Real2S:=S; {Stringzeiger durchreichen}
S:=StrScan(S,'.'); {Dezimalpunkt enthalten?}
if S<>nil then begin
S:=StrEnd(S); {Auf die Null}
repeat
Dec(S); {Zeiger aufs Stringende (vor die Null)}
if S^='.' then begin {String besteht nur (noch) aus dem Dezimalpunkt?}
S^:=#0; {String kürzen und raus!}
break;
end;
if S^='0' then S^:=#0 {Stringende ist die Null? - Kürzen und weiter}
else break; {sonst raus!}
until false;
end;
end;
function S2Real(S:PChar; var Z: TReal):boolean;
{wie Val(), jedoch vorher Komma zu Punkt wandeln}
{Weißraum (TAB & SPC) am Anfang wird übergangen, Weißraum (#0..' ')
am Ende auch, beim Abhacken wird das Zeichen zwischendurch gemerkt.
Achtung: Bei Fehler wird eine 0.0 in die Variable Z geschrieben!}
var
I:Integer;
SP: PChar;
MemChr: Char;
begin
while (S^=' ') or (S^=#9) do Inc(S); {Weißraum am Anfang übergehen}
SP:=StrScan(S,',');
if SP<>nil then SP^:='.'; {Komma zum Punkt machen}
SP:=S;
while SP^>' ' do Inc(SP); {Ende des Strings suchen}
MemChr:=SP^; SP^:=#0; {Zeichen merken, String abhacken}
Val(S,Z,I);
SP^:=MemChr; {Zeichen zurückschreiben}
S2Real:= (I=0); {false wenn Fehler in Real-Zahl}
end;
function Hinweis(Wnd:HWnd; ID:Word; var p):Integer;
{HINWEIS lädt einen String aus der Resource mit der entsprechenden ID und
zeigt ihn in einer Messagebox an. Da Resourcenstrings ein Längenbyte haben,
dient ein eventuelles #0-Zeichen im String als Trenner zwischen Text und Titel}
var
S,S2: TS255; {2 Puffer; leider so erforderlich}
SPT,SPH: PChar; {Zeiger auf Text und Titel}
I,K: Integer;
TextType:Word;
begin
TextType:=MB_OK or MB_IconExclamation;
I:=LoadString(HInstance,ID,S,sizeof(S)); {I=Anzahl der Zeichen insgesamt}
SPT:=S;
if S[0]='$' then begin
Val(S,TextType,K);
SPT:=StrEnd(S)+1;
end;
SPH:=StrEnd(SPT)+1;
if SPH-S>I then SPH:=AppName;
MessageBeep(TextType);
wvsprintf(S2,SPT,P);
Hinweis:=MessageBox(Wnd,S2,SPH,TextType);
end;
function Hinweis1(Wnd:HWnd; ID:Word; S:PChar):Integer;
begin
Hinweis1:=Hinweis(Wnd,ID,S);
end;
procedure ShortYield;
var
Msg: TMsg;
begin
if PeekMessage(Msg,0,0,0,PM_Remove) then begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
procedure MotorCallback; assembler;
asm
push dx {Window}
push cx {Message}
push ax {wParam=Flags und Handle}
push di
push si {lParam=Position}
call PostMessage
end;
procedure SetMotorStruc;
var
Freq: TReal;
Swap: LongInt absolute Freq;
begin
Freq:=SMGetIntFreq;
with MotorR do begin
AMotor.MaxSpeed:=Round(Abs(MaxSpeed*256*65536*StepsPerUnit/Freq));
AMotor.RefSpeed:=Round(RefSpeed*256*65536*StepsPerUnit/Freq);
AMotor.MaxAccel:=Round(Abs(MaxAccel*256*65536*StepsPerUnit/sqr(Freq)));
AMotor.Refpoint:=Round(RefPoint*256*StepsPerUnit);
AMotor.LeftBound:=Round(LeftBound*256*StepsPerUnit);
AMotor.RightBound:=Round(RightBound*256*StepsPerUnit);
end;
if AMotor.LeftBound>AMotor.RightBound then begin
Swap:=AMotor.LeftBound;
AMotor.LeftBound:=AMotor.RightBound;
AMotor.RightBound:=Swap; {Tauschen der Ränder}
end;
end;
function GetDlgItemHex(Wnd:HWnd; ID:Word; var W:Word):Boolean;
var
S: TS31;
HW: Word;
EC: Integer;
begin
GetDlgItemHex:=false;
GetDlgItemText(Wnd,ID,S+1,sizeof(S)-1);
S[0]:='$';
Val(S,HW,EC);
if EC=0 then begin
W:=HW;
GetDlgItemHex:=true;
end;
end;
function GetFileNamePtr(S:PChar):PChar; assembler;
{** OK für DLL **}
{liefert Zeiger hinter das letzte Auftreten von /\: oder Stringanfang}
asm les si,[S]
cld
@@ME: mov dx,si {Mögliches Ende merken}
@@l: seges lodsb
cmp al,'\'
jz @@ME
cmp al,'/'
jz @@ME
cmp al,':'
jz @@ME
or al,al
jnz @@l
mov ax,es
xchg dx,ax
end;
function AddRemoveVxD(AddPath,RemovVxD:PChar):Integer;
{** OK für DLL **}
const
devkey: array[0..7]of Char='device=';
var
f1,f2: Text; {zum SYSTEM.INI parsen}
S,Line: array[0..255]of Char;
PS,PL: PChar;
InsideSection,CopyLine: Boolean;
W: Word;
begin
WritePrivateProfileString(nil,nil,nil,'SYSTEM.INI'); {Cache leeren}
W:=GetWindowsDirectory(S,sizeof(S));
if S[W-1]<>'\' then begin S[W]:='\'; S[W+1]:=#0; end; {Backslash anhängen}
PS:=S+lStrLen(S); {auf die Null}
lStrCpy(PS,'SYSTEM.IN$'); {Tempname anhängen}
Assign(f2,S); ReWrite(f2); {zum Schreiben öffnen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailCreateTempFile;
exit;
end;
lStrCpy(PS,'SYSTEM.INI'); {Richtigen Namen anhängen}
Assign(f1,S); Reset(f1); {zum Lesen öffnen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailOpenSystemIni;
exit;
end;
InsideSection:=false;
while not eof(f1) do begin
ReadLn(f1,Line); CopyLine:=true;
if Line[0]='[' then begin
InsideSection:=(StrLIComp(Line,'[386Enh]',8)=0);
if InsideSection and (AddPath<>nil) then begin
WriteLn(f2,Line); {Sektionsbeginn beibehalten}
WriteLn(f2,devkey,AddPath); {Neue Zeile hinzufügen}
AddPath:=nil; {Einmal hinzufügen genügt}
CopyLine:=false; {nichts weiter...}
end;
end else begin
if InsideSection
and (RemovVxD<>nil)
and (StrLIComp(Line,devkey,7)=0)
and (lStrCmpi(GetFileNamePtr(Line+7),RemovVxD)=0) then begin
CopyLine:=false;
RemovVxD:=nil; {erledigt}
end;
end;
if CopyLine then WriteLn(f2,Line);
end;
Close(f1); Close(f2);
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailReadWrite;
exit; {Problem! Quelle nicht löschen!}
end;
Erase(f1); {Quelle löschen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailDelete;
exit;
end;
ReName(f2,S); {Ziel umbenennen}
if IOResult<>0 then begin
AddRemoveVxD:=ARV_FailRename;
exit;
end;
AddRemoveVxD:=0;
if RemovVxD<>nil then AddRemoveVxD:=ARV_CantRemove;
if AddPath<>nil then AddRemoveVxD:=ARV_CantAdd;
end;
end.
| Detected encoding: OEM (CP437) | 1
|
|
|