unit wutils;
{Statische Bibliothek für Windows-typische Problemchen}
{$C MOVEABLE PRELOAD PERMANENT} {gleiche Attribute wie Unit SYSTEM}
interface
uses WinProcs,WinTypes,ShellAPI;
{MessageBox-Funktionen auf Basis von unterteilten Ressourcen-Strings}
const
StdMBoxTitle: PChar = nil;
StdMBoxStyle: Word = MB_OK or MB_IconExclamation;
StdProfile: PChar = nil; {Vorgabe: WIN.INI}
MB_Sound = $0080;
HKCR=HKEY_Classes_Root;
function MBox(WndParent:HWnd; ID:Word; var p):Integer;
function MBox1(WndParent:HWnd; ID:Word; S:PChar):Integer;
procedure StrDisposeNoDS(var SP: PChar);
function lStrChr(Str:PChar; C:Char):PChar;
function GetPrfXX(Section,Key:PChar; var P; Size:Word):Boolean;
function SetPrfXX(Section,Key:PChar; const P; T:PChar):Boolean;
function GetWndXX(Wnd:HWnd; var P; Size:Word):Boolean;
function GetDlgItemXX(Wnd:HWnd; ID:Word; var P; Size:Word):Boolean;
function GetModuleDescription(FName,Descript:PChar):Boolean;
{extrahiert aus Windows-EXE Modulbeschreibung, max. 255 Zeichen, ANSI-Font
FName kann auch ein Dateihandle einer offenen Datei sein}
procedure memmove(d,s:Pointer; l:Word); {prüft auf Überlappung, rep movsb}
const
GX_PChar =$0000;
GX_Int =$FFF9;
GX_Word =$FFF8;
GX_Long =$FFFB;
OFN_LongNames =$200000;
{Hinzufügen oder Entfernen von VxD's zur/aus SYSTEM.INI}
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;
{AddPath bezeichnet ein neues VxD samt Pfad; NIL wenn kein neues}
{RemovVxD bezeichnet ein zu entfernendes VxD (kein Pfad erforderlich)}
{Registrierungs-Hilfen}
function RegSetRoot(Path,Value:PChar):Boolean;
function RegGetRoot(Path,Value:PChar; VL:Word):Boolean;
function RegSetVal(Key:HKey;Path,Value:PChar):Boolean;
function RegGetVal(Key:HKey;Path,Value:PChar; VL:Word):Boolean;
function WriteProfileInt(Section,Key:PChar; Value:Integer):Bool;
{Dateifunktionen}
procedure AnsiDosFunc;
function _ldelete(S: PChar):Integer;
function ExecAndWait(CmdLine:PChar; CmdShow:Word; Wnd:HWnd):Word;
{liefert um $4000 verschobenes WinExec-Resultat bei Fehler,
sonst Exitcode (im wesentlichen: LoByte auswerten!) des Programms}
function SetExeTermNotify(Wnd: HWnd; Msg:Word):Bool;
{Rückruf erfolgt mit PostMessage, wParam=Child-Instanz und lParam=Exit-Code.
Aufruf mit Wnd<>0 schaltet Callback ein, Wnd=0 schaltet Callback aus.
Kann nicht verschachtelt werden!}
procedure ShortYield;
function GetFileNamePtr(S:PChar):PChar;
{liefert Zeiger hinter das letzte Auftreten von /\: oder Stringanfang}
function GetFileNameExt(S:PChar):PChar;
{liefert Zeiger AUF DEN PUNKT oder AUF DIE NULL, niemals NIL}
function RemoveTrailSlash(S:PChar):PChar;
{liefert Zeiger AUF DIE NULL, entfernt ggf. mehr als 1 Slash}
procedure TransparentBlt(DC:HDC; x,y:Integer; HBM:HBitmap; cr:TColorRef);
const
Drive_CDROM =5;
Drive_RAM =6;
function GetDriveTypeEx(Drv:Integer):Word;
{Zip/Unzip-Hilfe - Start von unsichtbaren DOS-Boxen}
type
TPIF=record
rsv000: Byte; {=$00}
Checksum: Byte; {Prüfsumme, Summe der Bytes von Offset 002..170}
Title: array[0..29] of Char; {Titel, mit Leerzeichen aufgefüllt}
rsv020: Word; {=$0080}
ReqConvK: Word; {Erforderlicher konventioneller Speicher}
ExeFile: array[0..62] of Char; {Ausführbarer Dateiname, nullterminiert,
MIT PFAD & ENDUNG!}
SmFlag1: Word; {=$0010,
{ Bit4=Fenster schließen beim Beenden}
{ Bit}
WorkDir: array[0..63] of Char; {Arbeitsverzeichnis, nullterminiert}
SMParams: array[0..63] of Char; {Programm-Parameter, nullterminiert, Standard Mode}
rsv0E5: Word; {=$0100}
rsv0E7: Word; {=$FF00}
rsv0E9: Word; {=$5019}
rsv0EB: Word; {=$0000}
SmFlag2: Word; {=$0007}
{ Bit4=Grafik/Mehrfachtext}
rsv0EF: array[0..63] of Word; {lauter Nullen}
SmFlag3: Word; {=$60E0}
{Hier beginnt die Enhanced-Mode-Sektion}
Magic1: array[0..15] of Char; {"MICROSOFT PIFEX"}
rsv181: Word; {=$0187}
rsv183: Word; {=$0000}
rsv185: Word; {=$0171}
Magic2: array[0..15] of Char; {"WINDOWS 386 3.0"}
rsv197: Word; {=$0205}
rsv199: Word; {=$019D}
rsv19B: Word; {=$0068}
V86MaxK: Word; {=$0280}
V86MinK: Word; {=$0080}
PriFore: Word; {=$0064 Vordergrundpriorität}
PriBack: Word; {=$0032 Hintergrundpriorität}
EmsMaxK: Word; {=$FFFF Max EMS (386Enh)}
EmsMinK: Word; {=$0000 Min EMS}
XmsMaxK: Word; {=$FFFF Max XMS}
XmsMinK: Word; {=$0000 Min XMS}
InfoShell: LongInt; {=$00025002}
InfoVDD: LongInt; {=$0000001F}
VKD_ScanCode: Word; {=$0000}
VKD_Mask: LongInt; {=$00000000}
rsv1BB: array[0..4] of Word; {lauter Nullen}
EMParams: array[0..63] of Char; {Programm-Parameter, nullterminiert, Enhanced Mode}
{Hier beginnt die Standard-Mode-Erweiterung}
Magic3: array[0..15]of Char; {"WINDOWS 286 3.0"}
rsv215: Word; {=$FFFF}
rsv217: Word; {=$021B}
rsv219: Word; {=$0006}
SmXmsMaxK: Word; {=$FFFF Max XMS}
SmXmsMinK: Word; {=$0000 Min XMS}
SmFlag4: Word; {=$0000}
end;
{***************
;VDD PIF_State service definitions
;
; These definitions cannot change without changing the PIF editor!!!
;}
const
fVidTxtEmulate = $00000001; { Do INT 10h TTY and cursor emulation}
fVidNoTrpTxt = $00000002; { Do not trap text mode apps}
fVidNoTrpLRGrfx= $00000004; { Do not trap lo res graphics mode apps}
fVidNoTrpHRGrfx= $00000008; { Do not trap hi res graphics mode apps}
fVidTextMd = $00000010; { Allocate text mode mem}
fVidLowRsGrfxMd= $00000020; { Allocate lo res graphics mode mem}
fVidHghRsGrfxMd= $00000040; { Allocate hi res graphics mode mem}
fVidRetainAllo = $00000080; { Never deallocate once allocated}
{
Bits of returned EAX flags for SHELL_GetVMInfo service
}
{ SGVMI_Windowed = $00000004 { Is Windowed}
VMI_CloseOnExit = $00000001;
VMI_RunBackground= $00000002;
VMI_RunExclusive = $00000004;
VMI_RunFullscreen= $00000008;
SGVMI_ALTTABdis = $00000020; { Alt+Tab is reserved}
SGVMI_ALTESCdis = $00000040; { Alt+Esc is reserved}
SGVMI_ALTSPACEdis= $00000080; { Alt+Space is reserved}
SGVMI_ALTENTERdis= $00000100; { Alt+Enter is reserved}
SGVMI_ALTPRTSCdis= $00000200; { Alt+PrtSc is reserved}
SGVMI_PRTSCdis = $00000400; { PrtSc is reserved}
SGVMI_CTRLESCdis = $00000800; { Ctrl+Esc is reserved}
SGVMI_Polling = $00001000; { Polling detection Enab}
SGVMI_NoHMA = $00002000; { No HMA}
SGVMI_HasHotKey = $00004000; { Has a shortcut key}
SGVMI_EMS_Lock = $00008000; { EMS Hands Locked}
SGVMI_XMS_Lock = $00010000; { XMS Hands Locked}
SGVMI_FastPaste = $00020000; { Allow Fast paste Enab}
SGVMI_V86_Lock = $00040000; { V86 Memory Locked}
VKD_ShiftMask = $000F0003;
VKD_CtrlMask = $000F0004;
VKD_AltMask = $000F0008;
F1_GraphicsSave= $0002;
F1_NoTaskswitch= $0004;
F1_NoPRTSC = $0008;
F1_CloseOnExit = $0010;
F1_COM2_Lock = $0040;
F1_COM1_Lock = $0080;
F2_Default = $0007;
F2_GraphicsSave= $0010;
F3_Default = $60E0;
F3_Modify_Kbd = $0010;
F4_ALTTABdis = $0001;
F4_ALTESCdis = $0002;
F4_ALTPRTSCdis = $0004;
F4_PRTSCdis = $0008;
F4_CTRLESCdis = $0010;
F4_COM3_Lock = $4000;
F4_COM4_Lock = $8000;
function CreatePIF(Title,ExeFile,Params,WorkDir:PChar;
var PIF:TPif):Integer;
{WorkDir ist das TEMP-Verzeichnis, wenn NIL}
{FileName liefert(!) den Dateinamen im TEMP-Verzeichnis, falls leer}
{Title kann eine String-Ressource-ID sein: mit MakeIntResource() übergeben!}
type HFile=Integer; {fehlt bei BP7}
const HFile_Error=-1; {fehlt bei BP7}
type
LongRec=record
Lo,Hi:Word;
end;
PtrRec=record
Ofs,Sel:Word;
end;
WordRec=record
Lo,Hi:Byte;
end;
PDropFileStruct=^TDropFileStruct;
TDropFileStruct=record
wSize: Word;
MPos: TPoint;
InNcArea: Bool;
FNames: array[0..1] of Char;
end;
function GetDragClientFromPos(const P:TPoint):HWnd;
function PerformDrop(ToWnd:HWnd;argc:Integer;const argv:PChar):Bool;
{Arbeit mit "Huge"-Zeigern auf Speicher mit mehr als 64 KB}
procedure IncHP(var P:PChar; By: Word);
procedure DecHP(var P:PChar; By: Word);
procedure IncHPL(var P:PChar; By: LongInt);
{Minimum und Maximum, vzb. und vzl.}
function min(I1,I2:Integer):Integer;
inline($58/$5A/$39/$D0/$7C/$01/$92);
{pop ax; pop dx; cmp ax,dx; jl $+3; xchg dx,ax}
function minW(W1,W2:Word):Word;
inline($58/$5A/$39/$D0/$72/$01/$92);
{pop ax; pop dx; cmp ax,dx; jb $+3; xchg dx,ax}
function max(I1,I2:Integer):Integer;
inline($58/$5A/$39/$D0/$7F/$01/$92);
{pop ax; pop dx; cmp ax,dx; jg $+3; xchg dx,ax}
function maxW(W1,W2:Word):Word;
inline($58/$5A/$39/$D0/$77/$01/$92);
{pop ax; pop dx; cmp ax,dx; ja $+3; xchg dx,ax}
function Parity(W:Word):Boolean;
inline($58/$09/$C0/$B0/$00/$7B/$02/$B0/$01);
{pop ax; or ax,ax; mov al,0; jpo $+4; mov al,1}
function LongMul(A,B:Integer):LongInt;
inline($5A/$58/$F7/$EA);
{pop dx; pop ax; imul dx}
function LongMulW(A,B:Word):LongInt;
inline($5A/$58/$F7/$E2);
{pop dx; pop ax; mul dx}
function LongDiv(A:LongInt;B:Integer):Integer;
inline($5B/$58/$5A/$F7/$FB);
{pop bx; pop ax; pop dx; idiv bx - rundet nicht}
function LongDivR(A:LongInt;B:Integer):LongInt;
inline($5B/$58/$5A/$F7/$FB);
{pop bx; pop ax; pop dx; idiv bx - mit Restrückgabe im High-Teil}
function LongDivW(A:LongInt;B:Word):Word;
inline($5B/$58/$5A/$F7/$F3);
{pop bx; pop ax; pop dx; div bx - rundet nicht}
function LongDivWR(A:LongInt;B:Word):LongInt;
inline($5B/$58/$5A/$F7/$F3);
{pop bx; pop ax; pop dx; div bx - mit Restrückgabe im High-Teil}
function MulDivW(A,B,C:Word):Word;
inline($5B/$58/$5A/$F7/$E2/$F7/$F3);
{pop bx; pop ax; pop dx; mul dx; div bx - rundet nicht}
procedure SortRect(var R:TRect);
{sortiert die Koordinaten in R so um,
daß top/left links oben und bottom/right rechts unten ist}
function FirstWord(var S:PChar;Delim:Word):PChar;
{Abspalten des ersten Wortes von Zeichenkette SP
LoByte(Delim) enthält Trennzeichen, HighByte div. Flags}
const
FW_TrimLeft =$0100;
FW_TrimRight =$0200;
FW_DblQuote =$0400;
FW_SglQuote =$0800;
FW_CRLFisWS =$4000;
FW_NeverNIL =$8000;
FW_CmdLine =Ord(' ') or FW_TrimLeft or FW_DblQuote;
FW_Path =Ord(';') or FW_DblQuote;
{Nützliche Funktionen der Windows-API}
procedure __AHShift;
procedure __AHIncr;
procedure __0000H;
procedure __0040H;
procedure __A000H;
procedure __B000H;
procedure __B800H;
procedure __C000H;
procedure __D000H;
procedure __E000H;
procedure __F000H;
procedure __RomBios;
procedure __WinFlags;
function _hread(f:HFile;Buf:PChar;BufLen:LongInt):LongInt;
function _hwrite(f:HFile;Buf:PChar;BufLen:LongInt):LongInt;
function _LocalLock(Mem: THandle): Word;
function LocalLock(Mem: THandle): Pointer; {wegen Segmentdefinition!}
function SendMessageWW(Wnd: HWnd; Msg, wParam, lParHi, lParLo: Word): LongInt;
function SendMessageP(Wnd: HWnd; Msg, wParam: Word; lParam: Pointer): LongInt;
function SendDlgItemMsgWW(Dlg: HWnd; IDDlgItem: Integer; Msg, wParam,
lParHi, lParLo: Word): LongInt;
function SendDlgItemMsgP(Dlg: HWnd; IDDlgItem: Integer; Msg, wParam: Word;
lParam: Pointer): LongInt;
{Korrekturen fehlerhaft implementierter API-Funktionen}
procedure CopyRect(var DestRect: TRect; const SourceRect: TRect);
function CreatePolygonRgn(const Points; Count, PolyFillMode: Integer): HRgn;
function CreatePolyPolygonRgn(const Points; const PolyCounts; Count,
PolyFillMode: Integer): HRgn;
function CreateRectRgnIndirect(const Rect: TRect): HRgn;
function EqualRect(const Rect1, Rect2: TRect): Bool;
function FillRect(DC: HDC; const Rect: TRect; Brush: HBrush): Integer;
procedure FrameRect(DC: HDC; const Rect: TRect; Brush: HBrush);
function IntersectRect(var DestRect: TRect; const Src1Rect, Src2Rect: TRect): Integer;
procedure InvertRect(DC: HDC; const Rect: TRect);
function IsRectEmpty(const Rect: TRect): Bool;
function Polygon(DC: HDC; const Points; Count: Integer): Bool;
function Polyline(DC: HDC; const Points; Count: Integer): Bool;
function PolyPolygon(DC: HDC; const Points; const PolyCounts;
Count: Integer): Bool;
function PtInRect(const Rect: TRect; Point: TPoint): Bool;
function RectInRegion(Rgn: HRgn; const Rect: TRect): Bool;
function RectVisible(DC: HDC; const Rect: TRect): Bool;
function RegisterClass(const WndClass: TWndClass): Bool;
function ScrollDC(DC: HDC; dx, dy: Integer; const Scroll, Clip: TRect;
UpdateRgn: HRgn; UpdateRect: PRect): Bool;
function SetDIBits(DC: HDC; Bitmap: THandle; StartScan, NumScans: Word;
Bits: Pointer; const BitsInfo: TBitmapInfo; Usage: Word): Integer;
function SetDIBitsToDevice(DC: HDC; DestX, DestY, Width, Height, SrcX, SrcY,
nStartScan, NumScans: Word; Bits: Pointer; const BitsInfo: TBitmapInfo;
Usage: Word): Integer;
procedure SetSysColors(Changes: Integer; const SysColor; const ColorValues);
function StretchDIBits(DC: HDC; DestX, DestY, DestWidth, DestHegiht, SrcX,
SrcY, SrcWidth, SrcHeight: Word; Bits: Pointer; const BitsInfo: TBitmapInfo;
Usage: Word; Rop: LongInt): Integer;
function TabbedTextOut(HC: HDC; X, Y: Integer; Str: PChar; Count: Integer;
TabPositions: Integer; const TabStopPositions; TabOrigin: Integer): LongInt;
procedure Throw(const CatchBuf: TCatchBuf; ThrowBack: Integer);
function UnionRect(var DestRect: TRect; const Src1Rect, Src2Rect: TRect):
Integer;
function wvsprintf(DestStr, Format: PChar; const ArgList): Integer;
function waveInClose(hWaveIn: Word): Word; {Bösartiger Bug!!}
{Umdefinition des Rückgabewertes}
function GetProfileInt(Sec,Key:PChar; Def: Integer): Integer;
function GetPrivateProfileInt(Sec,Key:PChar; Def: Integer; FileName: PChar):
Integer;
function MMTaskCreate(Proc:TFarProc; var Task: THandle; Data:LongInt):Integer;
{liefert womöglich Fehlercode, 0 wenn OK}
function MMTaskBlock: Word;
function MMTaskSignal: Bool;
function MMGetCurrentTask: THandle;
function MMTaskYield: Word;
implementation
uses Strings,Win31,ToolHelp;
function MBox(WndParent:HWnd; ID:Word; var p):Integer;
{** NICHT OK für DLL **}
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;
{** NICHT OK für DLL **}
begin
MBox1:=MBox(WndParent,ID,S);
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;
function RegSetRoot(Path,Value:PChar):Boolean;
begin {** OK für DLL **}
RegSetRoot:=(RegSetValue(HKCR,Path,REG_SZ,Value,
lstrlen(Value))=ERROR_SUCCESS);
end;
function RegGetRoot(Path,Value:PChar; VL:Word):Boolean;
var {** OK für DLL **}
cb: LongInt;
begin
cb:=VL;
RegGetRoot:=(RegQueryValue(HKCR,Path,Value,cb)=ERROR_SUCCESS);
end;
function RegSetVal(Key:HKey;Path,Value:PChar):Boolean;
begin {** OK für DLL **}
RegSetVal:=(RegSetValue(Key,Path,REG_SZ,Value,
lstrlen(Value))=ERROR_SUCCESS);
end;
function RegGetVal(Key:HKey;Path,Value:PChar; VL:Word):Boolean;
var {** OK für DLL **}
cb: LongInt;
begin
cb:=VL;
RegGetVal:=(RegQueryValue(Key,Path,Value,cb)=ERROR_SUCCESS);
end;
function WriteProfileInt(Section,Key:PChar; Value:Integer):Bool;
{** OK für DLL **}
var
S: array[0..7]of Char;
begin
wvsprintf(S,'%d',Value);
WriteProfileInt:=WriteProfileString(Section,Key,S);
end;
function _ldelete(S: PChar):Integer;
{** OK für DLL, nur kurze Dateinamen! **}
var
ReOpenBuf: TOfStruct;
begin
_lDelete:=OpenFile(S,ReOpenBuf,OF_Delete);
end;
var
ProcInst: TFarProc;
ThisTask: THandle;
ChildInst: THandle;
const
NotifyWnd: HWnd=0;
Blocked: Bool=false;
var
NotifyMsg: Word;
function NotifyCallback(ID:Word; Data:LongInt):Bool; far;
{Achtung! Smart Callback funktioniert hier NICHT!
Toolhelp ruft diese Funktion, ohne das SS-Register aufs Datensegment
zu setzen, leider. Lösung:
* Single-Instance-Application
- "mov ds,seg @data"
- "export" ist sinnlos, es genügt "far"; dann muß DS gerettet werden
* Multiple-Instance-Application
- Verwendung von MakeProcInstance() und FreeProcInstance() erforderlich
- $K- schalten oder (da dieser Schalter leider global ist)
- "export" durch "far" ersetzen und am Eintritt den Assemblerbefehl
"mov ds,ax" setzen. Nicht vergessen, DS zu retten}
{** NICHT OK für DLL **}
var
TE: TTaskEntry;
begin
asm push ds
mov ds,ax
end;
if ID=NFY_ExitTask then begin
TE.dwSize:=sizeof(TE);
TaskFindHandle(@TE,GetCurrentTask);
if TE.hTaskParent=ThisTask then begin
if Blocked and (TE.hInst=ChildInst) then begin
Blocked:=false; {unblock}
ChildInst:=LongRec(Data).Lo; {Returncode}
end else if NotifyWnd<>0
then PostMessage(NotifyWnd,NotifyMsg,TE.hInst,Data);
end;
end;
NotifyCallback:=false;
asm pop ds end;
end;
function ExecAndWait(CmdLine:PChar; CmdShow:Word; Wnd:HWnd):Word;
{** NICHT OK für DLL **}
var
OldWndCurs:HCursor;
begin
if NotifyWnd=0 then begin
ProcInst:=MakeProcInstance(@NotifyCallback,Seg(HInstance));
NotifyRegister(0,TNotifyCallback(ProcInst),NF_Normal);
ThisTask:=GetCurrentTask;
end;
OldWndCurs:=SetClassWord(Wnd,GCW_HCursor,LoadCursor(0,IDC_Wait));
ChildInst:=WinExec(CmdLine,CmdShow);
{Problem: Callback könnte vor(!) der Rückkehr von WinExec()
aufgerufen werden! Dann würde ExecAndWait() ewig warten}
if ChildInst>=32 then begin
Blocked:=true;
EnableWindow(Wnd,false); {Keine Tastatur, keine Maus!}
while Blocked do ShortYield; {Warten auf Child-Ende}
EnableWindow(Wnd,true);
end else Inc(ChildInst,$4000);{Fehlercode-Offset bei Fehler dazu}
SetClassWord(Wnd,GCW_HCursor,OldWndCurs);
if NotifyWnd=0 then begin
NotifyUnregister(0);
FreeProcInstance(ProcInst);
end;
ExecAndWait:=ChildInst; {0 wenn erfolgreich}
end;
function SetExeTermNotify(Wnd: HWnd; Msg:Word):Bool;
{** NICHT OK für DLL **}
begin
SetExeTermNotify:=true;
if Wnd<>0 then begin
if NotifyWnd=0 then begin
ProcInst:=MakeProcInstance(@NotifyCallback,Seg(HInstance));
SetExeTermNotify:=NotifyRegister(0,TNotifyCallback(ProcInst),NF_Normal);
ThisTask:=GetCurrentTask;
end;
end else begin
if NotifyWnd<>0 then begin
NotifyUnregister(0);
FreeProcInstance(ProcInst);
end;
end;
NotifyWnd:=Wnd;
NotifyMsg:=Msg;
end;
procedure ShortYield;
{** OK für DLL **}
var
Msg: TMsg;
begin
if PeekMessage(Msg,0,0,0,PM_Remove) then begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
function CreatePIF(Title,ExeFile,Params,WorkDir:PChar;
var PIF:TPif):Integer;
{** NICHT OK für DLL **}
const
APIF:TPIF=(
rsv000: $00;
Checksum: $00;
Title: '(No Title) ';
rsv020: $0080;
ReqConvK: $0080;
ExeFile: '%COMSPEC%';
SmFlag1: $0010;
WorkDir: '';
SMParams: '';
rsv0E5: $0100;
rsv0E7: $FF00;
rsv0E9: $5019;
rsv0EB: $0000;
SmFlag2: $0007;
rsv0EF:( 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
SmFlag3: $60E0;
Magic1: 'MICROSOFT PIFEX'#0;
rsv181: $0187;
rsv183: $0000;
rsv185: $0171;
Magic2: 'WINDOWS 386 3.0'#0;
rsv197: $0205;
rsv199: $019D;
rsv19B: $0068;
V86MaxK: $0280;
V86MinK: $0080;
PriFore: $0400; {Hohe Prioritäten}
PriBack: $0400;
EmsMaxK: $FFFF;
EmsMinK: $0000;
XmsMaxK: $FFFF;
XmsMinK: $0000;
InfoShell: $00025002; {im Fenster! (sonst wirkt SW_Hide nicht)}
InfoVDD: $0000001F;
VKD_ScanCode: $0000;
VKD_Mask: $00000000;
rsv1BB:( 0,0,0,0,0);
EMParams: '';
Magic3: 'WINDOWS 286 3.0'#0;
rsv215: $FFFF;
rsv217: $021B;
rsv219: $0006;
SmXmsMaxK: $FFFF;
SmXmsMinK: $0000;
SmFlag4: $0000);
begin
Pif:=APif; {Struktur kopieren}
if LongRec(Title).Hi<>0 then begin
lstrcpyn(Pif.Title,Title,sizeof(Pif.Title)-1);
(Pif.Title+lstrlen(Pif.Title))^:=' '; {"blank padded"}
end else if LongRec(Title).Lo<>0 then begin
(Pif.Title+LoadString(Seg(HInstance),LongRec(Title).Lo,
Pif.Title,sizeof(Pif.Title)-1))^:=' ';
end;
if ExeFile<>nil
then lstrcpyn(Pif.ExeFile,ExeFile,sizeof(Pif.ExeFile)-1);
if Params<>nil then begin
lstrcpyn(Pif.SMParams,Params,sizeof(Pif.SMParams)-1);
lstrcpyn(Pif.EMParams,Params,sizeof(Pif.EMParams)-1);
end;
if WorkDir<>nil
then lstrcpyn(Pif.WorkDir,WorkDir,sizeof(Pif.WorkDir)-1);
end;
function lStrChr(Str:PChar; C:Char):PChar; assembler;
asm les ax,[Str]
mov dx,es
or dx,dx
jz @@n
jmp @@f
@@l: push dx
push ax
call AnsiNext
@@f: mov bx,ax
mov bl,es:[bx]
cmp bl,[C]
je @@e
or bl,bl
jnz @@l
@@n: xor ax,ax
cwd
@@e: 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 GetFileNameExt(S:PChar):PChar; assembler;
{** OK für DLL **}
{liefert Zeiger AUF DEN PUNKT oder AUF DIE NULL, niemals NIL}
asm les si,[S]
cld
@@ME: xor ah,ah {Punkt-gefunden-Flag}
@@m1: mov dx,si
@@l: seges lodsb
cmp al,'\'
jz @@me
cmp al,'\'
jz @@me
cmp al,':'
jz @@me
cmp al,'.'
jnz @@kp
inc ah
jmp @@l {Adresse AUF dem Punkt merken}
@@kp: or al,al
jz @@e {fertig}
or ah,ah
jnz @@l {nicht fertig und zuletzt '.'}
jmp @@m1 {nicht fertig und zuletzt '\/:'}
@@e: mov ax,es
xchg dx,ax
end;
function RemoveTrailSlash(S:PChar):PChar; assembler;
{** OK für DLL **}
{liefert Zeiger AUF DIE NULL, entfernt MAX. 1 Slash!}
asm les di,[S]
cld
xor ax,ax
mov dx,si
mov cx,$FFFF
repne scasb {ES:DI hinter die Null}
dec di {auf die Null}
@@l: mov al,es:[di]
cmp al,'\'
jz @@1
cmp al,'/'
jnz @@e
@@1: cmp di,dx
jnc @@l
{di=Stringanfang und alles '/\'}
dec di
@@e:{Sonstiges Zeichen erreicht}
inc di
mov byte ptr es:[di],ah
mov dx,es
xchg ax,di
end;
procedure AnsiDosFunc; assembler;
{PE: DS:DX=Dateiname (wird ANSI2OEM-konvertiert mit dynamischer
Stackanforderung); sonstige Register außer BP werden durchgereicht
VR: DS,DX, weitere Register je nach DOS-Funktion}
asm push bp
mov bp,sp
{Register retten; Windows-Funktionen retten SI und DI selbst}
push ax
push bx
push cx
push es
{Länge ermitteln und Stack reservieren}
push dx {DX über's lstrlen hinüberretten}
push ds
push dx
call lstrlen {Namenslänge in AX}
pop dx
inc ax
inc ax
and al,not 1 {aufrunden und ausrichten}
sub sp,ax {dynamische Stack-Anforderung!!}
mov ax,sp {neuer Stringzeiger}
{String dahinein kopieren}
push ds
push dx {ds:dx=Quelle}
push ss
push ax {ss:ax=Ziel}
call AnsiToOem
{Register holen}
mov ax,[bp-2]
mov bx,[bp-4]
mov cx,[bp-6]
mov es,[bp-8]
{DOS rufen}
push ss
pop ds
mov dx,sp {ds:dx=konvertierter String}
stc
call Dos3Call
{fertig}
leave {sp:=bp, pop bp}
end;
procedure SortRect(var R:TRect); assembler;
{sortiert die Punkte, daß die Zuordnungen stimmen}
asm les bx,[R]
mov ax,es:TRect[bx].left
cmp ax,es:TRect[bx].right
jl @@1
xchg es:TRect[bx].right,ax
mov es:TRect[bx].left,ax
@@1: mov ax,es:TRect[bx].top
cmp ax,es:TRect[bx].bottom
jl @@2
xchg es:TRect[bx].bottom,ax
mov es:TRect[bx].top,ax
@@2: end;
procedure __AHShift; external 'KERNEL' index 113;
procedure __AHIncr; external 'KERNEL' index 114;
procedure __0000H; external 'KERNEL' index 183;
procedure __0040H; external 'KERNEL' index 193;
procedure __A000H; external 'KERNEL' index 174;
procedure __B000H; external 'KERNEL' index 181;
procedure __B800H; external 'KERNEL' index 182;
procedure __C000H; external 'KERNEL' index 195;
procedure __D000H; external 'KERNEL' index 179;
procedure __E000H; external 'KERNEL' index 190;
procedure __F000H; external 'KERNEL' index 194;
procedure __RomBios; external 'KERNEL' index 173;
procedure __WinFlags; external 'KERNEL' index 178;
function _hread; external 'KERNEL' index 349;
function _hwrite; external 'KERNEL' index 350;
procedure Throw; external 'KERNEL' index 56;
function GetProfileInt; external 'KERNEL' index 57;
function GetPrivateProfileInt; external 'KERNEL' index 127;
function _LocalLock; external 'KERNEL' index 8;
function SendMessageWW; external 'USER' index 111;
function SendMessageP; external 'USER' index 111;
function SendDlgItemMsgWW; external 'USER' index 101;
function SendDlgItemMsgP; external 'USER' index 101;
procedure CopyRect; external 'USER' index 74;
function IsRectEmpty; external 'USER' index 75;
function PtInRect; external 'USER' index 76;
function IntersectRect; external 'USER' index 79;
function UnionRect; external 'USER' index 80;
function FillRect; external 'USER' index 81;
procedure InvertRect; external 'USER' index 82;
procedure FrameRect; external 'USER' index 83;
function EqualRect; external 'USER' index 244;
function RegisterClass; external 'USER' index 57;
function ScrollDC; external 'USER' index 221;
procedure SetSysColors; external 'USER' index 181;
function TabbedTextOut; external 'USER' index 196;
function wvsprintf; external 'USER' index 421;
function CreatePolygonRgn; external 'GDI' index 63;
function CreatePolyPolygonRgn; external 'GDI' index 451;
function CreateRectRgnIndirect; external 'GDI' index 65;
function Polygon; external 'GDI' index 36;
function Polyline; external 'GDI' index 37;
function PolyPolygon; external 'GDI' index 450;
function RectInRegion; external 'GDI' index 181;
function RectVisible; external 'GDI' index 104;
function SetDIBits; external 'GDI' index 440;
function SetDIBitsToDevice; external 'GDI' index 443;
function StretchDIBits; external 'GDI' index 439;
function waveInClose; external 'MMSYSTEM' index 505;
function MMTaskCreate; external 'MMSYSTEM' index 900;
function MMTaskBlock; external 'MMSYSTEM' index 902;
function MMTaskSignal; external 'MMSYSTEM' index 903;
function MMGetCurrentTask; external 'MMSYSTEM' index 904;
function MMTaskYield; external 'MMSYSTEM' index 905;
function LocalLock(Mem: THandle): Pointer; assembler;
asm push Mem
call _LocalLock
mov dx,ds
end;
function GetDragClientFromPos(const P:TPoint):HWnd;
var
Wnd:HWnd;
begin
Wnd:=WindowFromPoint(P);
if Wnd<>0 then begin
if GetWindowLong(Wnd,GWL_ExStyle) and WS_EX_AcceptFiles =0
then Wnd:=0;
end;
GetDragClientFromPos:=Wnd;
end;
function PerformDrop(ToWnd:HWnd;argc:Integer;const argv:PChar):Bool;
{enthält Bugs!!}
var
HDrop: THandle;
dfsp: PDropFileStruct;
len: Word;
i: Integer;
ppc: ^PChar;
SP: PChar absolute dfsp;
begin
if ToWnd=0 then exit;
if argc<=0 then exit;
ppc:=@argv;
len:=sizeof(dfsp)-1;
for i:=1 to argc do begin
if ppc^=nil then exit;
Inc(len,lstrlen(ppc^)+1); {Gesamtlänge ermittlen}
Inc(ppc);
end;
HDrop:=GlobalAlloc(GMEM_Share or GMEM_Moveable, len);
dfsp:=GlobalLock(HDrop);
dfsp^.wSize:=8;
dfsp^.InNcArea:=Bool(SendMessage(ToWnd,WM_NcHitTest,0,LongInt(dfsp^.mPos))
<>HTClient);
ScreenToClient(ToWnd,dfsp^.mPos);
ppc:=@argv;
SP:=dfsp^.fNames;
for i:=1 to argc do begin
lstrcpy(SP,ppc^);
Inc(SP,lstrlen(ppc^));
SP^:=#0;
Inc(SP);
Inc(ppc);
end;
SP^:=#0;
GlobalUnlock(HDrop);
PostMessage(ToWnd,WM_DropFiles,HDrop,0);
end;
{IncHugePointer - Erhöhen eines Zeigers
auf Speicher mit mehr als 64 Kilobyte; Windows-Version mit AHIncr}
procedure IncHP(var P:PChar; By: Word); assembler;
asm
les di,[P] {Adresse von P}
mov ax,[By]
add es:PtrRec[di].Ofs,ax {Offset inkrementieren}
jnc @@e {kein Überlauf: Selektor belassen!}
add es:PtrRec[di].Sel,offset __AHIncr {Selektor erhöhen}
@@e:
end;
{DecHugePointer - Erniedrigen eines Zeigers
auf Speicher mit mehr als 64 Kilobyte; Windows-Version mit AHIncr}
procedure DecHP(var P:PChar; By: Word); assembler;
asm
les di,[P] {Adresse von P}
mov ax,[By]
sub es:PtrRec[di].Ofs,ax {Offset inkrementieren}
jnc @@e {kein Überlauf: Selektor belassen!}
sub es:PtrRec[di].Sel,offset __AHIncr {Selektor erniedrigen}
@@e:
end;
{IncHugePointerLong - Erhöhen und Erniedrigen eines Zeigers
auf Speicher mit mehr als 64 Kilobyte; Windows-Version mit AHIncr}
procedure IncHPL(var P:PChar; By: LongInt); assembler;
asm
les di,[P] {Adresse von P}
mov cx,LongRec[By].Lo {Hier AX:CX: ungewöhnlich!}
mov ax,LongRec[By].Hi
add es:PtrRec[di].Ofs,cx {Offset inkrementieren}
adc ax,0 {Anzahl der 64-K-Übergänge}
mov cx,offset __AHShift
shl ax,cl {Vielfaches erzeugen}
add es:PtrRec[di].Sel,ax {Selektor erhöhen bzw. erniedrigen}
end;
{TransparentBlt: von der MSDN-Library-CD
kopiert Bitmap unter Angabe einer tranparenten Farbe (TColorRef)
in einen Zielkontext. Dreh- und Angelpunkt ist der korrekte ROP.
PE: DC: Zielgerätekontext
x,y: Ziel-Koordinaten linke obere Ecke
hBm: Quell-Bitmap
cr: Transparente Farbe}
procedure TransparentBlt(DC:HDC; x,y:Integer; HBM:HBitmap; cr:TColorRef);
const ROP_DSPDxax=$00E20746;
var
hDCSrc,hDCMid: HDC;
hBmpMono: HBitmap;
{ hBrT: HBrush;}
crBack,crText: TColorRef;
bm: TBitmap;
begin
if HBM<>0 then begin
GetObject(hBM,sizeof(bm),@bm);
hDCSrc:=CreateCompatibleDC(DC);
hDCMid:=CreateCompatibleDC(DC);
hBmpMono:=CreateCompatibleBitmap(hDCMid,bm.bmWidth,bm.bmHeight);
SelectObject(hDCSrc,hBm);
SelectObject(hDCMid,hBmpMono);
crBack:=SetBkColor(hDCSrc,cr);
BitBlt(hDCMid,0,0,bm.bmWidth,bm.bmHeight,hDCSrc,0,0,SrcCopy);
SetBkColor(hDCSrc,crBack);
BitBlt(DC,x,y,bm.bmWidth,bm.bmHeight,hDCSrc,0,0,SrcCopy);
{ hBrT:=SelectObject(DC,CreateSolidBrush(GetBkColor(DC)));}
crText:=SetTextColor(DC,$000000);
crBack:=SetBkColor(DC,$FFFFFF);
BitBlt(DC,x,y,bm.bmWidth,bm.bmHeight,hDCMid,0,0,ROP_DSPDxax);
SetTextColor(DC,crText);
SetBkColor(DC,crBack);
{ DeleteObject(SelectObject(DC,hBrT));}
DeleteDC(hDCSrc);
DeleteDC(hDCMid);
DeleteObject(hBmpMono);
end;
end;
{GetDriveTypeEx: Laufwerkstyp ermitteln, mit CD-ROM und RAM
PE: Drv: Nullbasierter Laufwerks-Index
PA: Einer der Werte:
Drive_Removable, Drive_Fixed, Drive_Remote, Drive_CDROM, Drive_RAM}
function GetDriveTypeEx(Drv:Integer):Word; assembler;
asm
push [Drv]
call GetDriveType
cmp ax,Drive_Fixed
jz @@TestCD
cmp ax,Drive_Remote
jnz @@SkipCD
@@TestCD:
push ax
mov ax,$1500
xor bx,bx
int $2f {Test MSCDEX-Präsenz}
or bx,bx
jz @@NoCD
mov ax,$150B
mov cx,[Drv]
int $2f {Test Laufwerk=CD-ROM?}
or ax,ax
jz @@NoCD
pop ax
push Drive_CDROM
@@NoCD:
@@SkipCD:
pop ax
cmp ax,Drive_Fixed
jnz @@SkipRAM
push ax
push ds
push ss
pop ds
sub sp,$200 {Dynamische Stackreservierung zum Sektorlesen}
mov bx,sp {BX=Sektorzeiger}
mov ax,[Drv]
mov cx,1 {Anzahl=1}
xor dx,dx {Sektor 0}
int $25
jc @@NoRAM
mov bx,sp {Achtung: BX ist 2 tiefergelegt!}
cmp byte ptr ss:[bx+$17],$f8 {Nochmals auf "Festplatte" testen}
jne @@NoRAM
cmp byte ptr ss:[bx+$12],1 {Eine FAT?}
jne @@NoRAM
mov word ptr ss:[bx+$204],Drive_RAM {gepushtes AX verändern!!}
@@NoRAM:
add sp,$202 {Stack freigeben, 2 mehr wegen Int25}
pop ds
pop ax
@@SkipRAM:
end;
function FirstWord(var S:PChar;Delim:Word):PChar; assembler;
{TOTAL FEHLERHAFT!}
var
StartPos,EndPos:Word;
TermChar:Char;
InQuote:Boolean;
asm push ds
les di,S
mov cx,[Delim]
mov [TermChar],cl {Zunächst Endezeichen}
mov [InQuote],0
lds si,es:[di]
cld
@@tl: mov [StartPos],si {Startposition im Stack merken}
lodsb
cmp al,0
jz @@end
cmp al,' '
jz @@lspc
cmp al,9
jz @@lspc
cmp al,10
jz @@lspc0
cmp al,13
jz @@lspc0
cmp al,'"'
jz @@DQ
cmp al,''''
jz @@SQ
{Sonstiger Buchstabe}
@@l:
push ax
call IsDBCSLeadByte
add ax,-1 {0-->CY=0}
adc si,0 {sprungfrei bedingt inkrementieren}
lodsb
cmp al,0
jz @@end
cmp al,[TermChar]
jz @@term
cmp al,' '
jz @@rspc
cmp al,9
jz @@rspc
cmp al,10
jz @@rspc0
cmp al,13
jz @@rspc0
@@te:
mov dx,ds
mov ax,[StartPos]
pop ds
jmp @@e
@@lspc0: test ch,$40 {Zeilenendezeichen erlaubt?}
jz @@l {nein}
@@lspc: test ch,1 {TrimLeft}
jz @@l {nein, als Buchstabe auffassen}
jmp @@tl {ja, weiter in TrimLeft}
@@DQ: test ch,4
jz @@l {nein, als Buchstabe auffassen}
mov [TermChar],'"'
jmp @@l0
@@SQ: test ch,8
jz @@l
mov [TermChar],''''
@@l0: mov [StartPos],si {Start ist HINTER dem Qu(ix)ote}
or [InQuote],1
jmp @@l
@@term: test [InQuote],1
jnz @@t1
lea bx,[si-1]
mov byte ptr [bx],0
mov es:[di],bx
jmp @@te
@@rspc0:
@@rspc:
@@t1:
@@end:
@@e: end;
procedure StrDisposeNoDS(var SP:PChar);
begin
if Seg(SP^)<>Seg(HInstance) then StrDispose(SP);
SP:=nil;
end;
function Str2XX(S:PChar; var P; Size:Word):Boolean;
var
HL: LongInt;
EC: Integer;
begin
Str2XX:=false;
case Size of
GX_Long: begin
Val(S,HL,EC); {VAL setzt bei Fehler Ziel auf 0, daher Hilfsvariable}
if EC=0 then begin
LongInt(P):=HL;
Str2XX:=true;
end;
end;
end;
end;
{Kapselfunktionen, die je nach StdProfile die WIN.INI oder eine private
.INI modifizieren. Zugriff auf die WIN.INI mit xxxPrivatexxx ist
gefährlich, da USER.EXE die WIN.INI dann 2x im Cache hält...}
function GetPrfInt(Sec,Key:PChar; Def:Integer):Integer; near; assembler;
asm pop bp {Pascal-Ärger!}
pop si {Returnadresse}
les di,[StdProfile]
mov cx,es
jcxz @@winini
push es; push di
call GetPrivateProfileInt
jmp si
@@winini:
call GetProfileInt
jmp si
end;
function GetPrfString(Sec,Key,Def,S:PChar;size:Integer):Integer; near;
assembler;
asm pop bp {Pascal-Ärger!}
pop si {Returnadresse}
les di,[StdProfile]
mov cx,es
jcxz @@winini
push es; push di
call GetPrivateProfileString
jmp si
@@winini:
call GetProfileString
jmp si
end;
function WritePrfString(Sec,Key,S:PChar):Bool; near; assembler;
asm pop bp {Pascal-Ärger!}
pop si {Returnadresse}
les di,[StdProfile]
mov cx,es
jcxz @@winini
push es; push di
call WritePrivateProfileString
jmp si
@@winini:
call WriteProfileString
jmp si
end;
function GetPrfXX(Section,Key:PChar; var P; Size:Word):Boolean;
var
S: array[0..1023] of Char; {ich glaube, GetXXString liefert nicht mehr}
begin
GetPrfXX:=false;
case Size of
GX_Int,GX_Word: begin
Integer(P):=GetPrfInt(Section,Key,Integer(P));
GetPrfXX:=true;
end;
0: begin
GetPrfString(Section,Key,PChar(P),S,sizeof(S));
if (PChar(P)=nil) or (lstrcmp(PChar(P),S)<>0) then begin
StrDisposeNoDS(PChar(P));
PChar(P):=StrNew(S); {schöne Schaufelei!}
end;
GetPrfXX:=true;
end;
2..$EFFF: begin
GetPrfString(Section,Key,PChar(@P),PChar(@P),Size);
GetPrfXX:=true;
end;
else begin
GetPrfString(Section,Key,'',S,sizeof(S));
GetPrfXX:=Str2XX(S,P,Size);
end;
end;
end;
function SetPrfXX(Section,Key:PChar; const P; T:PChar):Boolean;
var
S: array[0..1023] of Char;
begin
if T<>nil then begin
wvsprintf(S,T,P);
WritePrfString(Section,Key,S);
end else begin
WritePrfString(Section,Key,PChar(@P));
end;
end;
function GetWndXX(Wnd:HWnd; var P; Size:Word):Boolean;
var
W: Word;
S: array[0..255]of Char;
begin
GetWndXX:=true;
case Size of
0: begin
StrDisposeNoDS(PChar(P));
W:=Word(GetWindowTextLength(Wnd))+1;
GetMem(PChar(P),W);
GetWindowText(Wnd,PChar(P),W);
end;
2..$EFFF: begin
GetWindowText(Wnd,PChar(@P),Size);
end;
else begin
GetWindowText(Wnd,S,sizeof(S));
GetWndXX:=Str2XX(S,P,Size);
end;
end;
end;
function GetDlgItemXX(Wnd:HWnd; ID:Word; var P; Size:Word):Boolean;
var
B: Bool;
W: Word;
begin
case Size of
GX_Int: begin
Integer(W):=GetDlgItemInt(Wnd,ID,@B,true);
if B then Integer(P):=Integer(W);
GetDlgItemXX:=B;
end;
GX_Word: begin
W:=GetDlgItemInt(Wnd,ID,@B,true);
if B then Word(P):=W;
GetDlgItemXX:=B;
end;
else begin
GetDlgItemXX:=GetWndXX(GetDlgItem(Wnd,ID),P,Size);
end;
end;
end;
function GetModuleDescription(FName,Descript:PChar):Boolean;
{extrahiert aus Windows-EXE Modulbeschreibung, max. 255 Zeichen, ANSI-Font}
const
MZ=$5A4D;
NE=$454E;
label
finally;
var
f: Integer absolute FName;
L: LongInt;
LR: LongRec absolute L;
W: Word absolute L;
B: Byte absolute L;
begin
GetModuleDescription:=false;
if PtrRec(FName).Sel<>0
then f:=_lopen(FName,0); {Share-Modus richtig?}
if f=0 then exit; {falls NIL übergeben wurde}
if f=-1 then exit; {falls das Öffnen fehlschlug}
_lread(f,PChar(@W),2);
if W<>MZ then goto finally;
_llseek(f,$18,0);
_lread(f,PChar(@W),2);
if W<>$0040 then goto finally;
_llseek(f,$3C,0);
_lread(f,PChar(@L),4); {neuer Dateioffset}
_llseek(f,L,0);
if _lread(f,PChar(@W),2)<>2 then goto finally;
if W<>NE then goto finally;
_llseek(f,$2A,1); {42 Bytes hinter NE}
_lread(f,PChar(@L),4); {Dateioffset des Pascal-Strings}
_llseek(f,L,0);
if _lread(f,PChar(@B),1)<>1 then goto finally;
if B=0 then goto finally;
W:=B;
if _lread(f,Descript,W)<>W then goto finally;
for LR.Hi:=0 to W-1 do if Descript[LR.Hi]<' ' then goto finally;
Descript[W]:=#0; {terminieren}
OemToAnsi(Descript,Descript);
GetModuleDescription:=true;
finally:
if PtrRec(FName).Sel<>0
then _lclose(f);
end;
procedure memmove(d,s:Pointer; l:Word); assembler;
asm cld
push ds
lds si,[s]
les di,[d]
mov cx,[l]
cmp si,di
jnc @@up
dec cx
add si,cx
add di,cx
inc cx
std
@@up: rep movsb
pop ds
cld
end;
end.
{Müll}
type
TMemTextParse=record
a,c,e,max:PChar;
{a=Anfang, c=Cursor, e=Text-Ende, max=Speicher-Ende}
end;
function IsCharWhite(C:Char):Bool;
function NextLine(var mtp:TMemTextParse):Boolean;
{...verschiebt den Cursor auf den Anfang der nächsten Zeile}
function DelLine(var mtp:TMemTextParse):Boolean;
{...löscht die Zeile ab Cursor inkusive CRLF}
function InsertLine(var mtp:TMemTextParse; S:PChar):Boolean;
{...fügt eine Zeile ab Cursor inklusive CRLF ein}
function GetTrimmedLine(var mtp:TMemTextParse; S:PChar; SL:Word):Boolean;
{...holt eine Zeile, die von Leerzeichen an Anfang und Ende befreit ist}
{Speichertextverwaltungs-Funktionen}
function IsCharWhite(C:Char):Bool;
begin
IsCharWhite:= (C=' ')or(C=#9);
end;
function NextLine(var mtp:TMemTextParse):Boolean;
begin
NextLine:=false;
if mtp.c=mtp.e then exit; {Keine neue Zeile folgt}
while mtp.c^<>#10 do begin
mtp.c:=AnsiNext(mtp.c);
if mtp.c=mtp.e then exit; {Keine neue Zeile folgt}
end;
if ((mtp.c=mtp.a) or ((mtp.c-1)^<>#13)) {wenn kein #13 davor...}
and ((mtp.c+1)^=#13) {dann vielleicht dahinter...}
then Inc(mtp.c); {dann ist DIES das Zeilenende!}
Inc(mtp.c); {Der neue Zeilenanfang}
if mtp.c=mtp.e then exit; {keine echte Zeile!}
NextLine:=true;
end;
function DelLine(var mtp:TMemTextParse):Boolean;
var
c1: PChar;
begin
DelLine:=false;
c1:=mtp.c; {Cursor merken}
if c1=mtp.e then exit; {Nichts zu löschen da!}
NextLine(mtp); {Cursor auf neue Zeile}
Move(mtp.c,c1,mtp.e-mtp.c); {"Schwanz" bewegen}
Dec(mtp.e,mtp.c-c1); {Ende verkürzen}
mtp.c:=c1; {Cursor setzen}
DelLine:=true;
end;
function InsertLine(var mtp:TMemTextParse; Key,Value:PChar):Boolean;
var
len: Word;
LenKey,LenVal:Word;
begin
InsertLine:=false;
if Key=nil then exit;
LenKey:=lStrLen(Key);
len:=KenKey+3; {Einfüge-Länge}
LenVal:=$FFFF; if Value<>nil then LenVal:=lstrlen(Value);
Inc(len,LenVal); {aus Key und Value}
if mtp.max<mtp.e+len then exit; {Speichermangel}
Move(mtp.c,mtp.c+len,mtp.e-mtp.c); {"Schwanz" bewegen}
Inc(mtp.e,len); {Ende verlängern}
Move(Key,mtp.c,LenKey);
Inc(mtp.c,LenKey);
if LenVal<>$FFFF then begin
mtp.c^:='=';
Inc(mtp.c);
Move(Value,mtp.c,LenVal);
Inc(mtp.c,LenVal);
end;
PWord(mtp.c-2)^:=#1013; {CRLF einpatchen}
Inc(mtp.c,2); {Cursor dahinter}
InsertLine:=true;
end;
function GetIniLine(var mtp:TMemTextParse; Sec,Key,Value:PChar; VL:Word):Boolean;
var
c1,c2,c3: PChar;
begin
GetTrimmedLine:=false;
if mtp.c=mtp.e then exit; {Ende erreicht}
c1:=mtp.c; {Cursor merken}
NextLine(mtp); {Nächste Zeile oder Ende ansteuern}
c3:=mtp.c; {"Hilfs-Ende"}
while (c1<mtp.c) and IsCharWhite(c1^) do Inc(c1); {"TrimLeft"}
if (c1<mtp.c) and c1^='[' then
while c1<c3 do begin
c2:=AnsiPrev(c1,c3);
if IsCharWhite(c2^) or (c2^=#13) or (c2^=#10)
then c3:=c2; {weitermachen}
else break; {Stop, c3 zeigt aufs String-Ende}
end;
if SL>c3-c1 then SL:=c3-c1;
lstrcpyn(S,c1,SL);
GetTrimmedLine:=true;
end;
| Detected encoding: OEM (CP437) | 1
|
|
|