unit wutils;
{Statische Bibliothek für Windows-typische Problemchen}
{$C MOVEABLE PRELOAD PERMANENT} {gleiche Attribute wie Unit SYSTEM}
{$F-,A+,G+,K+,W-}
{$I-,Q-,R-,S-}
{$V+,B-,X+,T+,P+}
{Die Einbindung dieser Unit verbraucht 8 uninitialisierte Datenbytes}
interface
uses WinProcs,WinTypes,ShellAPI;
{MessageBox-Funktionen auf Basis von unterteilten Ressourcen-Strings}
var
StdMBoxTitle: PChar{=nil};
StdProfile: PChar{=nil}; {Vorgabe: WIN.INI}
const
MB_Sound = $0080;
HKCR=HKEY_Classes_Root;
WF_WinNT =$4000; {zusätzlich für GetWinFlags()}
{Windows9x und NT4-Konstanten}
VK_XButton1 =$05; {Linke X-Maustaste}
VK_XButton2 =$06; {Rechte X-Maustaste}
VK_Kana =$15; {jap.}
VK_JunJa =$17; {jap.}
VK_Final =$18; {jap.}
VK_Kanji =$19; {jap.}
VK_NonConvert =$1D; {jap.}
VK_Accept =$1E; {jap.}
VK_ModeChange =$1F; {jap.}
VK_Print =$2A;
VK_LWin =$5B;
VK_RWin =$5C;
VK_ContextKey =$5D; {Kontext-Menü-Taste einer Win95-Tastatur}
VK_Apps =VK_ContextKey;
VK_Sleep =$5F;
VK_LShift =$A0;
VK_RShift =$A1;
VK_LControl =$A2;
VK_RControl =$A3;
VK_LMenu =$A4;
VK_RMenu =$A5;
VK_Browser_Back =$A6;
VK_Browser_Forward =$A7;
VK_Browser_Refresh =$A8;
VK_Browser_Stop =$A9;
VK_Browser_Search =$AA;
VK_Browser_Favorites =$AB;
VK_Browser_Home =$AC;
VK_Volume_Mute =$AD;
VK_Volume_Down =$AE;
VK_Volume_Up =$AF;
VK_Media_Next_Track =$B0;
VK_Media_Prev_Track =$B1;
VK_Media_Stop =$B2;
VK_Media_Play_Pause =$B3;
VK_Launch_Mail =$B4;
VK_Launch_Media_Select =$B5;
VK_Launch_App1 =$B6;
VK_Launch_App2 =$B7;
WM_MouseWheel =$020A; {Rotation kommt bei GetMessageExtraInfo()}
MSH_MouseWheel ='MSWHEEL_ROLLMSG'; {wParam=Rotation in 120er Schritten}
{Wird an GetActiveWindow() verschickt!}
Wheel_Delta =120; {Standard-Schrittweite}
WM_Sizing =$0214; {ab Win9x; bei NT dummerweise Flat-Pointer}
WM_Moving =$0216; {ab Win9x}
WMSZ_Left=1; {hier war 'ne Blindpese am Werk!}
WMSZ_Right=2;
WMSZ_Top=3;
WMSZ_TopLeft=4;
WMSZ_TopRight=5;
WMSZ_Bottom=6;
WMSZ_BottomLeft=7;
WMSZ_BottomRight=8;
WM_Print =$0317; {wParam=PrintDC?}
WM_PrintClient =$0318; {wParam=PrintDC?}
WM_Notify =$004E;
WM_InputLangChangeRequest=$0050;
WM_InputLangChange =$0051;
WM_TCard =$0052;
WM_Help =$0053;
WM_ContextMenu =$007B;
WM_StyleChanging =$007C;
WM_StyleChanged =$007D;
WM_DisplayChange =$007E;
CF_SelectScript =$00400000; {ChooseFont-Flags}
CF_NoScriptSel =$00800000;
CF_NoVertFonts =$01000000;
OFN_LongNames =$00200000; {GetOpen/SaveFileName-Flag}
type
PHelpInfo=^THelpInfo;
THelpInfo=record {na?}
cbSize: LongInt;
iContextType: Integer;
iCtrlID: Word;
hItemHandle: THandle;
dwContextID: LongInt;
MousePos: TPoint;
end;
const {Accelerator Table Codes für fVirt}
FVirtKey =$01;
FNoInvert =$02;
FShift =$04;
FControl =$08;
FAlt =$10;
FLast =$80;
type
PAccel=^TAccel;
TAccel=packed record
fVirt: Byte;
key: Word;
cmd: Word;
end;
type {lParam in CallWndProc-Callback}
PCwpStruct=^TCwpStruct;
TCwpStruct=record
lParam:LongInt;
wParam,message:Word;
hwnd:HWnd;
end;
type
TCompProc=function(s1,s2:PChar):Integer; {entweder lstrcmp oder lstrcmpi}
function vMBox(WndParent:HWnd; ID,style:Word; var p):Integer;
function MBox:Integer; {cdecl - nur für Assembler-Aufruf}
function MBox0(WndParent:HWnd; ID,style:Word):Integer;
function MBox1(WndParent:HWnd; ID,style:Word; S:PChar):Integer;
function MBox2(WndParent:HWnd; ID,style:Word; S2,S1:PChar):Integer;
procedure StrDisposeNoDS(var SP: PChar);
function lstrchr(Str:PChar; C:Char):PChar;
{Zeichen <c> im String <Str> suchen, Position liefern}
function lstrcmp1(s_short,s_long:PChar;CP:TCompProc):Integer;
{Anfang von <s_long> mit <s_short> vergleichen, entweder strcmpi oder strcmp}
function lstrstr(needle,heap:PChar;CP:TCompProc):PChar;
{einfache Suche von Nadel in Heuhaufen, entweder strcmpi oder strcmp}
function memcmp(s1,s2:PChar; len:Word):Integer;
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 Accel2Text(const accel:TAccel; s:PChar);
{Wandelt Akzelerator via Tastaturtreiber in lokalisierte,
beschreibende Zeichenkette um, ideal für Menüs und ToolTips,
bspw.: "Alt+Strg+Umschalt+Num 5"}
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;
{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;
{C-mäßige String-Umwandlung in darstellbares Format}
function EscapeStr(src:PChar; slen:Word; dst:PChar; dlen:Word):Word;
function UnescapeStr(src, dst:PChar; dlen:Word):Word;
{Dateifunktionen}
procedure AnsiDosFunc;
function _ldelete(S: PChar):Integer;
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}
function PathCat(Path,FName:PChar):PChar;
{Anhängen von FName an Path; dabei darf Path mit oder ohne (Back)Slash enden,
Rückgabewert ist die Stelle, wo FName hinkopiert wurde (also hinter Slash)}
procedure ShortYield;
{einfachste Wartefunktion, gibt eine "Zeitscheibe" her.
Zur Nachbildung von Delay() nur bedingt geeignet, da dann volle CPU-Last}
procedure TranslateWin95Keys(const Msg:TMsg);
{übersetzt die Kontextmenü-Tasten Shift+F10 oder WinMenü in WM_ContextMenu,
unter Windows 3.1 liefert diese Taste VK_FF und Scancode=VK_ContextKey;
die Umwandlung von Shift+F10 muß auch unter Win95 durchgeführt werden!
Die beiden Windows-Logo-Tasten werden nicht beachtet,
da sie systemglobal für die Shell oder als AppHotKey
(Stichwort: SetWindowsHookEx(WH_Keyboard...)) gedacht sind.
Der Aufruf erfolgt vor TranslateMessage(Msg)}
function BitCount(W:Word):Integer;
{Zählt die gesetzten Bits in W}
procedure TransparentBlt(DC:HDC; x,y:Integer; HBM:HBitmap; cr:TColorRef);
{Kopiert Bitmap und wandelt dabei die Transparent-Farbe der Bitmap in den
Hintergrund-Pinsel des Zielgerätekontexts (keine echte Transparenz!)}
function CopyFile(NameS,NameD:PChar; Overwrite: Bool):Bool;
{Funktionskompatibel zur Win32-API, unterstützt lange Dateinamen}
function GetRadioCheck(Wnd:HWnd; u,o:Word): Integer;
{Abfrage einer Reihe von Radiobuttons, bis ein gedrückter gefunden
wird, sonst Rückgabe von -1}
function GetCheckboxGroup(Wnd:HWnd; u,o:Word): LongInt;
{Abfrage von bis zu 16 in ihrer ID aufeinanderfolgenden Checkboxen}
procedure SetCheckboxGroup(Wnd:HWnd; u,o:Word; x:LongInt);
{Setzen von bis zu 16 in ihrer ID aufeinanderfolgenden Checkboxen}
procedure SetCheckboxGroup2(Wnd:HWnd; u,o,x:Word);
{Setzen von bis zu 16 in ihrer ID aufeinanderfolgenden Checkboxen,
beläßt jedoch solche im dritten Schaltzustand unverändert}
function EnableDlgItem(Wnd:HWnd; idItem:Word; Enable:Bool):Bool;
{Aktivieren bzw. Grausetzen eines Dialogelements.
Achtung - Gefahr: Noch keine Fokuskontrolle!}
procedure EnableDlgItemGroup(Wnd:HWnd; u,o:Word; Enable:Bool);
{Aktivieren bzw. Grausetzen einer Reihe von Dialogfeldern.
Achtung: Ohne Fokuskontrolle!}
procedure SetEditFocus(HWndEdit: HWnd);
{fokussiert+markiert Editfenster}
procedure CenterDlg(Wnd:HWnd);
{Zentriert Wnd im Elternfenster oder Desktopfenster}
function MoveRectIntoRect(var R:TRect; const R2:TRect): Bool;
{Dient zum Hineinholen von außerhalb liegenden Fenstern in den Desktop.}
procedure GetFullScreenRect(var R:TRect);
{liefert ideales R2 für MoveRectIntoRect zur Ganz-Anzeige von Dialogen u.ä.}
procedure MoveRectIntoFullScreen(var R:TRect);
{die logische Kombination beider o.g. Routinen}
function GetShiftState:Bool;
{Status der Shift-Taste}
function GetControlState:Bool;
{Status der Strg-Taste}
function Msg2VScroll(Msg,wParam: Word; PageSize:Integer):Integer;
{Wandelt geeignete VScroll- und KeyDown-Nachrichten in "Entfernungscodes"
um, liefert ±1 für "Zeilen" und PageSize für "Seiten", sonst 0}
const
Drive_CDROM =5;
Drive_RAM =6;
function GetDriveTypeEx(Drv:Integer):Word;
type HFile=Integer; {fehlt bei BP7}
const HFile_Error=-1; {fehlt bei BP7}
type
PLongLong=^LongLong;
LongLong=record
case integer of
0:(lo,hi: LongInt);
1:(b: array[0..7] of Byte);
2:(w: array[0..3] of Word);
3:(l: array[0..1] of LongInt);
4:(d: Double);
end;
PQWord=^QWord;
QWord=LongLong;
LongRec=record
Lo,Hi:Word;
end;
LongRecI=record
Lo,Hi:Integer;
end;
PtrRec=record
Ofs,Sel:Word;
end;
WordRec=record
Lo,Hi:Byte;
end;
ByteSet=set of 0..7; {für die Verwendung von Include u.a.}
WordSet=set of 0..15; {Mengenoperationen}
LongSet=set of 0..31;
TS259=array[0..259] of Char;
TLfnBuf=TS259; {für "lange" Pfade}
TS255=array[0..255] of Char;
TS127=array[0..127] of Char;
TS79=array[0..79] of Char;
TSfnBuf=TS79; {für "kurze" Pfade}
TS63=array[0..63] of Char;
TS31=array[0..31] of Char;
TS15=array[0..15] of Char;
TS7=array[0..7] of Char;
TS3=array[0..3] of Char;
PPChar=^PChar;
PDropFileStruct=^TDropFileStruct;
TDropFileStruct=record
wSize: Word;
MPos: TPoint;
InNcArea: Bool;
FNames: array[0..0] of Char;
end;
function GetDragClientFromPos(const P:TPoint):HWnd;
function PerformDrop(ToWnd:HWnd;const P:TPoint;argc:Integer;argv:PPChar):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/$D039/$017C/$92);
{pop ax; pop dx; cmp ax,dx; jl $+3; xchg dx,ax}
function minW(W1,W2:Word):Word;
inline($58/$5A/$D039/$0172/$92);
{pop ax; pop dx; cmp ax,dx; jb $+3; xchg dx,ax}
function minL(L1,L2:LongInt):LongInt;
function max(I1,I2:Integer):Integer;
inline($58/$5A/$D039/$017F/$92);
{pop ax; pop dx; cmp ax,dx; jg $+3; xchg dx,ax}
function maxW(W1,W2:Word):Word;
inline($58/$5A/$D039/$0177/$92);
{pop ax; pop dx; cmp ax,dx; ja $+3; xchg dx,ax}
function maxL(L1,L2:LongInt):LongInt;
{LimitX begrenzt i zwischen u und o, wobei u<o gelten muss}
function Limit(i,u,o:Integer):Integer;
inline($5A/$59/$58/$C839/$017F/$91/$D039/$017C/$92);
{pop dx; pop cx; pop ax;
cmp ax,cx; jg $+3; xchg cx,ax; cmp ax,dx; jl $+3; xchg dx,ax}
function LimitW(i,u,o:Word):Word;
inline($5A/$59/$58/$C839/$0177/$91/$D039/$0172/$92);
{pop dx; pop cx; pop ax;
cmp ax,cx; ja $+3; xchg cx,ax; cmp ax,dx; jb $+3; xchg dx,ax}
function LimitL(i,u,o:LongInt):LongInt;
{BetweenX begrenzt i zwischen u und o, wobei nicht u<o gelten muss}
function Between(i,u,o:Integer):Integer;
inline($5A/$59/$58/$D139/$027C/$D178/$C839/$017F/$91/$D039/$017C/$92);
{pop dx; pop cx; pop ax; cmp cx,dx; jl $+4; xchg dx,cx;
cmp ax,cx; jg $+3; xchg cx,ax; cmp ax,dx; jl $+3; xchg dx,ax}
function BetweenW(i,u,o:Word):Word;
inline($5A/$59/$58/$D139/$0272/$D178/$C839/$0177/$91/$D039/$0172/$92);
{pop dx; pop cx; pop ax; cmp cx,dx; jb $+4; xchg dx,cx;
cmp ax,cx; ja $+3; xchg cx,ax; cmp ax,dx; jb $+3; xchg dx,ax}
function BetweenL(i,u,o:LongInt):LongInt;
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 lLongDivW(A:LongInt;B:Word):Word;
inline($5B/$58/$5A/$39/$DA/$72/$05/$B8/$FF/$FF/$EB/$02/$F7/$F3);
{pop bx; pop ax; pop dx; cmp dx,bx; jc $+7; mov ax,-1; jmp $+4;
div bx - mit Begrenzung auf 65535}
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}
function idiv2(x: Integer):Integer;
{weil Turbo's shr nicht arithmetisch schiebt!}
inline($58/$D1/$F8); {pop ax; sar ax,1}
function bsf(w: Word):Integer; {Bitsuche vorwärts, findet tiefstes Bit}
function bsr(w: Word):Integer; {Bitsuche vorwärts, findet höchstes Bit}
function sar(x: Integer; bits:Byte):Integer;
{weil Turbo's shr nicht arithmetisch schiebt!}
inline($59/$58/$D3/$F8); {pop cx; pop ax; sar ax,cl}
function Bool2MenuCheck(Check:Bool):Word;
{konvertiert Bool-Argument in MF_UnChecked(false) oder MF_Checked(true)}
inline($58/$09/$C0/$74/$03/$B8/>MF_Checked);
{pop ax; or ax,ax; jz $+5; mov ax,MF_Checked}
function IfThenElse(i:Bool;t,e:Integer):Integer; {"?:"-Operator}
inline($58/$5A/$59/$01E3/$92);
{pop ax; pop dx; pop cx; jcxz $+3; xchg dx,ax}
function IfThenElseW(i:Bool;t,e:Word):Word; {"?:"-Operator}
inline($58/$5A/$59/$01E3/$92);
{pop ax; pop dx; pop cx; jcxz $+3; xchg dx,ax}
function IfThenElseL(i:Bool;t,e:LongInt):LongInt;
inline($5A/$58/$5B/$5E/$59/$03E3/$96/$DA87);
{pop dx; pop ax; pop bx; pop si; pop cx; jcxz $+5; xchg si,ax; xchg bx,dx}
function IfThenElseP(i:Bool;t,e:PChar):PChar;
inline($5A/$58/$5B/$5E/$59/$03E3/$96/$DA87);
{dito!}
{Um systemweite Hooks oder eine Toolhelp-Notify-Prozedur in eine .EXE
statt in eine .DLL zu legen, und nicht auf Smart Callbacks verzichten
zu müssen, deklariert man dieses Callback als "far" statt "export"
und benutzt dafür MakeProcInstance. Am Anfang des Callbacks muss
der Aufruf "export_enter", am Ende "export_leave".
Stack-Prüfung muss ausgeschaltet sein!
Falls die .EXE stets nur 1x läuft, reicht aber mov ax,seg @data, und
MakeProcInstance ist unnötig.}
procedure export_enter;
inline($1E/$D88E); {push ds; mov ds,ax}
procedure export_leave;
inline($1F); {pop ds}
function InitStruct(var x; xlen:Word):Word;
{xlen muss gerade sein! Liefert stets Null.}
{PUSH und POP nur verwenden, wenn man weiß, was man tut!}
procedure push(i: Integer); inline($90); {nop}
procedure pushW(w:Word); inline($90); {nop}
procedure pushL(l: LongInt); inline($90); {nop}
function pop:Integer; inline($58); {pop ax}
function popW:Integer; inline($58); {pop ax}
function popL:Integer; inline($58/$5A); {pop ax; pop dx}
{Kann leider nicht für SelectObject verwendet werden wegen DC-Parameter}
{Das schöne am Stack-Speicher ist, man muß ihn nicht freigeben!}
function StackAlloc(size:Word):Pointer;
{reserviert dynamisch Stack-Speicher (size sollte gerade sein)}
inline($58/$C429/$E089/$D28C); {pop ax; sub sp,ax; mov ax,sp; mov dx,ss}
procedure StackFree(size:Word);
{gibt o.g. StackAlloc-Speicher frei (size muß gleich sein!)}
inline($58/$C401); {pop ax; add sp,ax}
function StackAlloc2(size:Word):Pointer;
{reserviert dynamisch Stack-Speicher (size wird gerade gemacht)}
inline($58/$40/$FE24/$C429/$E089/$D28C);
{pop ax; inc ax; and al,0FEh; sub sp,ax; mov ax,sp; mov dx,ss}
procedure StackFree2(size:Word);
{gibt o.g. StackAlloc2-Speicher frei (size muß gleich sein!)}
inline($58/$40/$FE24/$C401); {pop ax; inc ax; and al,0FEh; add sp,ax}
type
Bool2MenuGray=Word; {Hier: Einfache Typkonvertierung}
{konvertiert Bool-Argument in MF_Enabled(false!) oder MF_Grayed(true!)}
procedure SortRect(var R:TRect);
{sortiert die Koordinaten in R so um,
daß top/left links oben und bottom/right rechts unten ist}
{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 definierter 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 GetInstanceData(Instance:THandle; Data:Word; Count:Integer):Integer;
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 wsprintf: Integer; {Nur für Assembler}
function GetTabbedTextExtent(DC: HDC; Str: PChar; Count: Integer;
TabPostions: Integer; const TabStopPostions):LongInt;
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(h:THandle): Word;
function MMTaskSignal(h:THandle): Bool;
function MMGetCurrentTask: THandle;
procedure MMTaskYield;
implementation
uses Strings,Win31;
function vMBox(WndParent:HWnd; ID,style:Word; var p):Integer;
{** NICHT OK für DLL wegen HInstance - aber vielleicht vom Aufrufer? **}
var
SPH: PChar; {Zeiger auf Titel}
I,K: Integer;
S,S2: TS255; {2 Puffer; leider so erforderlich}
begin
I:=LoadString(HInstance,ID,S,sizeof(S)); {I=Anzahl der Zeichen insgesamt}
K:=lstrlen(S);
SPH:=StdMBoxTitle;
if K<I then SPH:=S+K+1;
wvsprintf(S2,S,p);
if style and MB_Sound <>0 then MessageBeep(style and $0070);
vMBox:=MessageBox(WndParent,S2,SPH,style and not MB_Sound);
end;
function MBox:Integer; assembler; {cdecl - nur für Assembler-Aufruf}
asm mov si,sp
add si,4 {FAR-Return-Adresse überspringen}
cld
segss lodsb
push ax {HWndParent}
segss lodsb
push ax {ID}
segss lodsb
push ax {style}
push ss
push si {p}
call vMBox
end;
function MBox0(WndParent:HWnd; ID,style:Word):Integer;
{hier waere ein cdecl himmlisch...}
begin
MBox0:=vMBox(WndParent,ID,style,MemW[0:0]);
end;
function MBox1(WndParent:HWnd; ID,style:Word; S:PChar):Integer;
begin
MBox1:=vMBox(WndParent,ID,style,S);
end;
function MBox2(WndParent:HWnd; ID,style:Word; S2,S1:PChar):Integer;
begin
MBox2:=vMBox(WndParent,ID,style,S1);
end;
function AddRemoveVxD(AddPath,RemovVxD:PChar):Integer;
{** OK für DLL **}
const
devkey: array[0..7]of Char='device='#0;
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:=(lstrcmp1('[386Enh]',Line,lstrcmpi)=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 (lstrcmp1(devkey,Line,lstrcmpi)=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 IsInvisible(c:Char):Boolean;
{liefert TRUE, wenn Zeichen im üblichen Windows-Zeichensatz nicht sichtbar}
begin
IsInvisible:=(c<' ') or (c>=#$80) and (c<#$A0) or (c=#$FF);
end;
function EscapeStr(src:PChar; slen:Word; dst:PChar; dlen:Word):Word;
{Wandelt übergebene "Bytefolge" (nicht nullterminiert) in C-String
mit Escape-Sequenzen um, auch \" und \' und \\. Nicht darstellbare
Zeichen werden in \a, \b usw. und ansonsten in Hex (\xXX) umgesetzt.
Liefert als Ergebnis die Länge des Ergebnisstrings ohne \0.
src und dst dürfen sich nicht überlappen.}
var
su: Char;
ChrCount: Word;
function fcat(template:PChar; len:Word):Boolean;
begin
fcat:=false;
if len<dlen then begin
if PtrRec(template).Sel<>0
then wvsprintf(dst,template,su)
else dst^:=su;
Inc(dst,len);
Inc(ChrCount,len);
Dec(dlen,len);
fcat:=true;
end;
end;
begin
ChrCount:=0;
while slen>0 do begin
su:=#0;
case src^ of
'\','"','''': su:=src^;
#7: su:='a';
#8: su:='b';
#9: su:='t';
#10: su:='n';
#11: su:='v';
#13: su:='r';
end;
if su<>#0 then begin
if not fcat('\%c',2) then break;
end else begin
su:=src^;
if IsInvisible(su) then begin
if not fcat('\x%02X',4) then break;
end else begin
if not fcat(nil,1) then break;
end;
end;
Inc(src);
Dec(slen);
end{while};
if dlen>0 then dst^:=#0; {terminieren}
EscapeStr:=ChrCount;
end;
function UnescapeStr(src, dst:PChar; dlen:Word):Word;
{Wandelt übergebenen C-String (nullterminiert) in "Bytefolge".
Liefert als Ergebnis die Länge der Ergebnis-Bytefolge -
diese ist nicht nullterminiert!
Da der Ergebnisstring niemals länger wird, darf src=dst sein.}
var
su,st: Char;
ChrCount: Word;
e,f: Integer;
begin
ChrCount:=0;
while dlen>0 do begin
su:=src^;
Inc(src);
if su=#0 then break;
if su='\' then begin
su:=src^;
Inc(src);
case su of
#0: break;
'0': su:=#0; {Hier: Keine Oktalzahlen - nur dieser Sonderfall}
'1'..'9': begin
Dec(src);
Val(src,Byte(su),e); {liefert als Fehler Zeichenpos+1!}
if e<>0 then begin
Dec(e);
st:=src[e];
src[e]:=#0;
Val(src,Byte(su),f); {sollte f=0 liefern, ist jedoch belanglos}
Inc(src,e);
src^:=st; {Zurückpatchen}
end else Inc(src,lstrlen(src)); {falls gerade am Stringende}
end;
'a': su:=#7;
'b': su:=#8;
't': su:=#9;
'n': su:=#10;
'v': su:=#11;
'r': su:=#13;
'x': begin
st:=src[2];
src[2]:=#0;
Dec(src);
src[0]:='$';
Val(src,Byte(su),e);
src[0]:='x'; {Zurückpatchen}
Inc(src);
src[2]:=st; {Zurückpatchen}
if e=0 then Inc(src,2) else su:='x';
end;
end{case}; {im ELSE-Fall bleibt "su" literal!}
end{if};
dst^:=su;
Inc(dst);
Inc(ChrCount);
Dec(dlen);
end;
UnescapeStr:=ChrCount;
end;
function _ldelete(S: PChar):Integer;
{** OK für DLL, nur kurze Dateinamen! **}
var
ReOpenBuf: TOfStruct;
begin
_lDelete:=OpenFile(S,ReOpenBuf,OF_Delete);
end;
function lstrchr(Str:PChar; C:Char):PChar; assembler;
asm les bx,[Str]
mov dx,es
or dx,dx
jz @@n
jmp @@f
@@l: push es
push ax
call AnsiNext {Leider ist diese Funktion ätzend langsam!}
mov es,dx
xchg bx,ax
@@f: mov al,es:[bx]
cmp al,[C]
xchg bx,ax
je @@e
or bl,bl
jnz @@l
@@n: xor ax,ax
cwd
@@e: end;
function lstrcmp1(s_short,s_long:PChar;CP:TCompProc):Integer; assembler;
asm les si,[s_short]
push es
push si
call lstrlen {String-Länge...}
les bx,[s_long]
mov di,bx
add di,ax {bis dahin vergleichen!}
mov al,0
xchg es:[di],al {deshalb langen String abhacken}
push es
push di
push ax
push PtrRec[s_short].sel
push si
push es
push bx
call [CP] {DI und SI könnten zerstört werden}
pop bx
pop di
pop es
mov es:[di],bl {zurückpatchen}
end;
function lstrstr(needle,heap:PChar;CP:TCompProc):PChar; assembler;
asm push ds
lds si,[needle]
push ds
push si
call lstrlen
xchg di,ax
lds si,[heap]
push ds
push si
call lstrlen
mov bx,si {der Heu-Zeiger}
add si,di {die Null-Patch-Stelle}
sub di,ax {Längendifferenz = Anzahl der Vergleiche -1}
jc @@notfound {Nadel länger als Heu? Kann nicht finden!}
lea cx,[di+1] {Anzahl der Vergleiche (stets >0)}
les di,[needle]
mov dx,es
@@l: {Suchschleife mit DS:SI=Null-Patch-Stelle, DS:BX=Heu, DX:DI=Nadel, CX=}
mov al,0
xchg [si],al {Patch!}
pusha
push dx
push di {DX:DI=Nadel-Zeiger}
push ds
push bx {DS:BX=Heu-Zeiger}
call [CP]
or ax,ax
popa
mov [si],al {Rückpatch!}
jz @@found
inc di
inc si
loop @@l
@@notfound:
xor ax,ax
cwd
jmp @@e
@@found:
mov dx,ds {ins HEU!}
xchg di,ax
@@e: pop ds
end;
function memcmp(s1,s2:PChar; len:Word):Integer; assembler;
asm push ds
cld
lds si,[s1]
les di,[s2]
mov cx,[len]
mov ax,1
repe cmpsb
ja @@e {AX=1 wenn Z=0 und CY=0}
sbb ax,ax {AX=0 wenn Z=1 und AX=-1 wenn CY=1}
@@e: pop ds
end;
procedure Inc_SI_when_AL_DBCS; assembler;
asm pusha
push ax
call IsDbcsLeadByte
add ax,-1 {CY=1 wenn AX<>0}
popa
adc si,0
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
jz @@e
call Inc_SI_when_AL_DBCS
jmp @@l
@@e:
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 TERMINIERENDE NULL, niemals NIL}
{Als Extension gilt hierbei die Zeichenkette beginnend am _letzten_
Punkt in der _letzten_ Pfadkomponente, wenn dieser Punkt nicht
am Anfang steht (wie bei den versteckten Dateien unter UNIX)
und auch nicht als Folge von Punkten am Anfang steht (wie bei ..)
*Voraussetzung für das korrekte Funktionieren dieser Funktion ist,
daß der Dateiname keinen anhängigen Pfad-Trenner (/\:) hat.}
{AH enthält: 0 für Pfadkomponentenanfang, 1 für andere Zeichen als /\:.,
≥2 für Punkt gefunden}
asm les si,[S]
cld
@@ME: xor ah,ah {AH=0 Pfadkomponente beginnt}
@@m1: mov dx,si
@@l: seges lodsb
cmp al,'\'
jz @@me {Neue Pfadkomponente: AH=0 setzen}
cmp al,'/'
jz @@me {dito}
cmp al,':'
jz @@me {dito}
cmp al,'.'
jz @@pt
or al,al
jz @@e {fertig}
call Inc_SI_when_AL_DBCS
cmp ah,2
jnc @@l {AH=2 (oder höher) nicht fertig und zuletzt '.'}
mov ah,1 {AH=1 setzen - zuletzt kein '\/:'}
jmp @@m1
@@pt:
or ah,ah {Null?}
jz @@m1 {kein Extensionspunkt am Anfang!}
inc ah {AH≥2 gültiger, aber vielleicht nicht finaler Punkt}
lea dx,[si-1]
jmp @@l {Adresse AUF den Punkt bleibt in DX stehen}
@@e: mov ax,es
xchg dx,ax
end;
function RemoveTrailSlash(S:PChar):PChar; assembler;
{** OK für DLL ** - auch für DBCS geeignet}
{liefert Zeiger AUF DIE NULL, entfernt alle anhängenden Slashes}
asm les di,[S]
cld
xor ax,ax
mov dx,di
mov cx,$FFFF
repne scasb {ES:DI hinter die Null}
@@l: dec di {auf die Null}
cmp di,dx
je @@e
mov al,es:[di-1]
cmp al,'\'
jz @@l
cmp al,'/'
jz @@l
@@e:{Sonstiges Zeichen erreicht}
mov byte ptr es:[di],ah
mov dx,es
mov ax,di
end;
function PathCat(Path,FName:PChar):PChar; assembler;
{Anhängen von FName an Path; dabei darf Path mit oder ohne (Back)Slash enden,
Rückgabewert ist die Stelle, wo FName hinkopiert wurde (also hinter Slash)}
asm les di,[Path]
push es
push di
call RemoveTrailSlash
mov al,'\'
stosb
push es
push di
les di,[FName]
push es
push di
call lstrcpy
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 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;
procedure TranslateWin95Keys(const Msg:TMsg); assembler;
asm
les di,[Msg]
{if (Msg.message and $FFFE <>WM_SysKeyDown) then exit;}
mov ax,es:TMsg[di].message
mov si,es:TMsg[di].wParam
cmp ax,WM_SysKeyDown {kein F10}
jne @@noF10
cmp si,VK_F10
jne @@e
push es
call GetShiftState
pop es
jz @@e
jmp @@ok
@@noF10:
cmp ax,WM_KeyDown
jne @@e
cmp si,0FFh {VK_FF kommt unter Win3.1}
jne @@e
cmp es:byte ptr TMsg[di].lParam+2,VK_ContextKey
jne @@e
@@ok: mov ax,es:TMsg[di].hWnd
push ax
push WM_ContextMenu
push ax
push -1
push -1
call PostMessage
@@e: 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 ShiftRect; assembler;
{Hilfsfunktion, schiebt horizontal bzw. vertikal}
asm mov ax,es:TRect[di].left
sub ax,TRect[si].left
jz @@e {wenn linksbündig: niemals schieben}
jg @@r {R nach rechts}
{nun: AX negativ oder Null: Verschiebe-Fähigkeit nach links}
mov dx,es:TRect[di].right
sub dx,TRect[si].right
jge @@e {nicht schieben}
cmp ax,dx {die betragsmäßig kleinere Zahl ist gefragt}
jg @@r
xchg dx,ax
@@r: add TRect[si].left,ax
add TRect[si].right,ax
mov cl,TRUE {Verschiebung vermerken}
@@e: end;
function MoveRectIntoRect(var R:TRect; const R2:TRect): Bool; assembler;
{Falls R in R2 teilweise oder vollständig außerhalb liegt,
wird R verschoben und TRUE zurückgeliefert, um maximale Sichtbarkeit
zu realisieren.
Dient zum Hineinholen von außerhalb liegenden Fenstern in den Desktop.}
asm push ds
lds si,[R]
les di,[R2]
xor cx,cx
call ShiftRect
add si,2 {auf "top" bzw. "bottom" vorrücken}
add di,2
call ShiftRect
xchg cx,ax
pop ds
end;
procedure GetFullScreenRect(var R:TRect); assembler;
{Ermittelt das Rechteck für maximierte Fenster, d.h. die Startleiste(n)
von Win9x bereits abgezogen, ideal für R2 in MoveRectIntoRect}
asm les di,[R]
cld
xor ax,ax
stosw {R.left=0}
stosw {R.top=0}
push es
push SM_CXFullScreen
call GetSystemMetrics
pop es
cld
stosw
push es
push SM_CYFullScreen
call GetSystemMetrics
xchg si,ax
push SM_CYCaption
call GetSystemMetrics
add ax,si
pop es
stosw
end;
procedure MoveRectIntoFullScreen(var R:TRect);
{die logische Kombination beider o.g. Routinen}
var
R2: TRect;
begin
GetFullScreenRect(R2);
MoveRectIntoRect(R,R2);
end;
function GetShiftState:Bool; assembler;
{liefert Z=0: Shift gedrückt (AX<>0), Z=1: Shift nicht gedrückt (AX=0),
VR: AX,BX,CX,DX,ES}
asm push VK_Shift
call GetKeyState
and al,0FEh
end;
function GetControlState:Bool; assembler;
{liefert Z=0: Control gedrückt (AX<>0), Z=1: Control nicht gedrückt (AX=0),
VR: AX,BX,CX,DX,ES}
asm push VK_Control
call GetKeyState
and al,0FEh
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 GetInstanceData; external 'KERNEL' index 54;
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 wsprintf; external 'USER' index 420;
function wvsprintf; external 'USER' index 421;
function GetTabbedTextExtent; external 'USER' index 197;
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;
procedure MMTaskYield; external 'MMSYSTEM' index 905;
function LocalLock(Mem: THandle): Pointer; assembler;
{noch einmal wegen falscher Codesegment-Attribute von WinProcs}
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;const P:TPoint;
argc:Integer;argv:PPChar):Bool;
{enthält Bugs? Noch ungetestet!}
var
HDrop: THandle;
len: Word;
i: Integer;
ppc: PPChar;
SP: PChar absolute ppc; {nicht gemeinsam benutzt}
begin
PerformDrop:=false;
if ToWnd=0 then exit;
if argc<=0 then exit;
ppc:=argv;
len:=sizeof(TDropFileStruct);
for i:=argc downto 1 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);
if HDrop=0 then exit;
with PDropFileStruct(GlobalLock(HDrop))^ do begin
wSize:=8;
mPos:=P;
InNcArea:=Word(SendMessage(ToWnd,WM_NcHitTest,0,LongInt(P)))<>HTClient;
ScreenToClient(ToWnd,mPos);
SP:=fNames;
repeat
lstrcpy(SP,argv^);
Inc(SP,lstrlen(argv^)+1);
Inc(argv);
Dec(argc);
until argc=0;
SP^:=#0;
end;
GlobalUnlock(HDrop);
PerformDrop:=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;
function minL(L1,L2:LongInt):LongInt; assembler;
{Nebenergebnis: CX:BX = Maximum}
asm mov dx,LongRec[L1].hi
mov ax,LongRec[L1].lo
mov cx,LongRec[L2].hi
mov bx,LongRec[L2].lo
cmp dx,cx
jl @@e
jg @@swp
cmp ax,bx
jle @@e
@@swp: xchg bx,ax
xchg cx,dx
@@e: end;
function maxL(L1,L2:LongInt):LongInt; assembler;
asm push LongRec[L1].hi
push LongRec[L1].lo
push LongRec[L2].hi
push LongRec[L2].lo
call minL
xchg bx,ax
xchg cx,dx
end;
function LimitL(i,u,o:LongInt):LongInt; assembler;
asm push LongRec[i].hi
push LongRec[i].lo
push LongRec[u].hi
push LongRec[u].lo
call minL {Maximum in CX:BX}
push cx
push bx
push LongRec[o].hi
push LongRec[o].lo
call minL {Minimum in DX:AX - fertig}
end;
function BetweenL(i,u,o:LongInt):LongInt; assembler;
asm push LongRec[u].hi
push LongRec[u].lo
push LongRec[o].hi
push LongRec[o].lo
call minL {DX:AX = Minimum, CX:BX = Maximum}
push LongRec[i].hi
push LongRec[i].lo
push dx
push ax
push cx
push bx
call LimitL
end;
function InitStruct; assembler;
asm les di,[x]
mov ax,[xlen]
cld
stosw
shr ax,1
dec ax
xchg cx,ax
xor ax,ax
rep stosw
end;
function BitCount; assembler;
asm mov cx,[W]
xor ax,ax
@@l: jcxz @@e
shr cx,1 {statistisch sind die meisten Bits "unten"}
adc ax,0
jmp @@l
@@e: end;
function bsf; assembler;
asm mov cx,[W]
mov ax,-1
jcxz @@e
mov ax,16
@@l: jcxz @@e
shl cx,1
dec ax
jmp @@l
@@e: end;
function bsr; assembler;
asm mov cx,[W]
mov ax,-1
@@l: jcxz @@e
shr cx,1
inc ax
jmp @@l
@@e: 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;
{Funktionskompatibel zur Win32-API, unterstützt lange Dateinamen}
function CopyFile(NameS,NameD:PChar; Overwrite: Bool):Bool;
label
ex1, ex2, ex3;
const
BUFSIZE=$4000;
var
OK: Bool;
Buf: PChar; {hier: 16K-Cluster}
fs,fd: Integer;
BytesRead: Integer;
begin
OK:=false;
fs:=_lopen(NameS,OF_Share_Compat);
if fs=-1 then fs:=_lopen(NameS,OF_Share_Deny_Write);
if fs=-1 then goto ex1;
if not Overwrite then begin
fd:=_lopen(NameD,OF_Share_Compat);
if fd<>-1 then goto ex2;
end;
fd:=_lcreat(NameD,0);
if fd=-1 then goto ex2;
Buf:=Ptr(GlobalAlloc(GMEM_Fixed,BUFSIZE),0);
if PtrRec(Buf).sel=0 then goto ex2;
repeat
BytesRead:=_lread(fs,Buf,BUFSIZE);
if Integer(_lwrite(fd,Buf,BytesRead))<>BytesRead then goto ex3;
until BytesRead=0;
GlobalFree(PtrRec(Buf).sel);
asm mov ax,5700h {Datum/Uhrzeit lesen}
mov bx,[fs]
call Dos3Call
jc ex3
inc al {Datum/Uhrzeit setzen}
mov bx,[fd]
call Dos3Call
jc ex3
end;
OK:=true;
ex3: OK:=(_lclose(fd)<>-1) and OK;
ex2: OK:=(_lclose(fs)<>-1) and OK;
ex1: CopyFile:=OK;
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 ... funktioniert nicht mit TDSK!}
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;
{Zentriert Wnd im Elternfenster oder Desktopfenster}
procedure CenterDlg(Wnd:HWnd); assembler;
var
R: TRect;
asm mov si,sp {Rechteck Dialog und Desktop}
push [Wnd]
call GetParent
or ax,ax
jnz @@1
call GetDesktopWindow
@@1: push ax
push ss
push si {für GetDesktopWindowRect}
push [Wnd]
push ss
push si
call GetWindowRect
mov si,[R.right]
sub si,[R.left] {SI=neues R.width}
mov di,[R.bottom]
sub di,[R.top] {DI=neues R.height}
call GetWindowRect
push [Wnd]
mov ax,[R.right] {R.left sollte 0 sein}
sub ax,si
sar ax,1
push ax {neues R.left (X)}
mov ax,[R.bottom] {R.top sollte 0 sein}
sub ax,di
sar ax,1
push ax {neues R.top (Y)}
push si {width}
push di {height}
push 1 {fRepaint}
call MoveWindow
end;
function GetRadioCheck(Wnd:HWnd; u,o:Word): Integer; assembler;
{Abfrage einer Reihe von Radiobuttons, bis ein gedrückter gefunden
wird, sonst Rückgabe von -1}
asm mov di,0 {Zähler}
mov si,[u]
dec si
@@l:
inc si
push [Wnd]
push si
call IsDlgButtonChecked
inc ax
jz @@err {Notbremse bei Fehler}
dec ax
dec ax
jz @@found
inc di
cmp si,[o]
jnz @@l
@@err: mov di,-1 {Kein Button}
@@found:xchg di,ax
end;
function GetCheckboxGroup(Wnd:HWnd; u,o:Word): LongInt; assembler;
{Abfrage von bis zu 16 in ihrer ID aufeinanderfolgenden Checkboxen}
asm xor ax,ax {Ergebnis: Angekreuzt}
xor dx,dx {Ergebnis: Tristate}
mov di,1 {Maske}
mov si,[u]
dec si
@@l: inc si
push dx
push ax
push [Wnd]
push si
call IsDlgButtonChecked
dec ax
pop ax
pop dx
js @@1 {nichts wenn <=0}
jz @@set
or dx,di
db 0B9h {2 Bytes überspringen, mov cx,xxxx}
@@set: or ax,di {setzen wenn =1}
@@1: shl di,1
jc @@e {Notbremse}
@@f: cmp si,[o]
jnz @@l
@@e: end;
procedure SetCheckboxGroup(Wnd:HWnd; u,o:Word; x:LongInt); assembler;
{Setzen von bis zu 16 in ihrer ID aufeinanderfolgenden Checkboxen}
asm mov si,[u]
dec si
@@l: inc si
push [Wnd]
mov ax,1
push si
test ax,LongRec[x].hi
jnz @@tri
and ax,LongRec[x].lo {Null oder Eins}
db 0B9h {2 Bytes überspringen, mov cx,xxxx}
@@tri: add ax,ax
push ax
call CheckDlgButton
shr LongRec[x].hi,1
shr LongRec[x].lo,1
@@f: cmp si,[o] {ohne Notbremse!}
jnz @@l {auch umlaufend geeignet}
end;
procedure SetCheckboxGroup2(Wnd:HWnd; u,o,x:Word); assembler;
{Setzen von bis zu 16 in ihrer ID aufeinanderfolgenden Checkboxen,
beläßt jedoch solche im dritten Schaltzustand unverändert}
asm mov si,[u]
dec si
@@l: inc si
push [Wnd]
push si
call IsDlgButtonChecked
inc ax {-1?}
jz @@e {Notbremse}
cmp ax,3
jnc @@1
push [Wnd]
mov al,1 {AH ist hier bereits Null!}
push si
and ax,[x] {Null oder Eins}
push ax
call CheckDlgButton
@@1: shr [x],1
@@f: cmp si,[o]
jne @@l
@@e: end;
function EnableDlgItem(Wnd:HWnd; idItem:Word; Enable:Bool):Bool; assembler;
asm push [Wnd]
push [idItem]
call GetDlgItem
or ax,ax
jz @@e {Fehler}
push ax
push [Enable]
call EnableWindow
@@e: end;
procedure EnableDlgItemGroup(Wnd:HWnd; u,o:Word; Enable:Bool); assembler;
asm mov si,[u]
dec si
@@l: inc si
push [Wnd]
push si
push [Enable]
call EnableDlgItem
cmp si,[o]
jne @@l
end;
procedure SetEditFocus(HWndEdit: HWnd);
{fokussiert+markiert Editfenster}
begin
SetFocus(HWndEdit);
SendMessage(HWndEdit,EM_SetSel,0,$FFFF0000);
end;
function Msg2VScroll(Msg,wParam: Word; PageSize:Integer):Integer; assembler;
{Wandelt geeignete VScroll- und KeyDown-Nachrichten in "Entfernungscodes"
um, liefert ±1 für "Zeilen" und PageSize für "Seiten", sonst 0}
{begin
Msg2VScroll:=0;
case Msg of
WM_KeyDown: case wParam of
VK_Prior: Msg2VScroll:=PageSize;
VK_Up: Msg2VScroll:=1;
VK_Down: Msg2VScroll:=-1;
VK_Next: Msg2VScroll:=-PageSize;
end;
WM_VScroll: case wParam of
SB_PageUp: Msg2VScroll:=PageSize;
SB_LineUp: Msg2VScroll:=1;
SB_LineDown:Msg2VScroll:=-1;
SB_PageDown:Msg2VScroll:=-PageSize;
end;
end;
end;}
asm mov ax,[Msg]
cmp ax,WM_VScroll
jz @@bar
cmp ax,WM_KeyDown
jnz @@f
@@key:
mov ax,[wParam]
mov dx,1
cmp al,VK_Up
jz @@e
neg dx {-1}
cmp al,VK_Down
jz @@e
mov dx,[PageSize]
cmp al,VK_Prior
jz @@e
neg dx {-PageSize}
cmp al,VK_Next
jz @@e
jmp @@f
@@bar:
mov ax,[wParam]
mov dx,1
cmp al,SB_LineUp
jz @@e
neg dx {-1}
cmp al,SB_LineDown
jz @@e
mov dx,[PageSize]
cmp al,SB_PageUp
jz @@e
neg dx {-PageSize}
cmp al,SB_PageDown
jz @@e
@@f: xor dx,dx
@@e: xchg dx,ax
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, mit OEM->ANSI
FName darf alternativ ein geöffnetes Datei-Handle sein (Dateipos=0!),
Descript muß auf einen Puffer mit mindestens 256 Bytes zeigen}
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 Accel2Text(const accel:TAccel; s:PChar); assembler;
const
prs: array[0..3] of Char='%s+';
var
s2: TS15;
asm
mov bx,FShift*256+VK_Shift
@@l: les di,[accel]
test es:TAccel[di].fVirt,bh
jz @@1
push bx
mov al,bl
cbw
push ax
push 0
call MapVirtualKey
push ax
push 0
lea di,[s2]
push ss
push di
push 16
call GetKeyNameText
push ss
push di
push ds
push offset prs
les di,[s]
push es
push di
call wsprintf
add sp,6*2
add PtrRec[s].ofs,ax
pop bx
@@1: shl bh,1
inc bl
cmp bl,VK_Menu+1
jne @@l
les di,[accel]
test es:TAccel[di].fVirt,FVirtKey
mov ax,es:TAccel[di].key
jz @@else
push ax
push 0
call MapVirtualKey
push ax
push 0
les di,[s]
push es
push di
push 16
call GetKeyNameText
jmp @@e
@@else:
les di,[s]
stosw
@@e:
{ for i:=0 to 2 do
if accel.fVirt and (FShift shl i) <>0 then begin
GetKeyNameText(MakeLong(0,MapVirtualKey(VK_Shift+i,0)),
s2,sizeof(s2));
sp:=s2;
Inc(s,wvsprintf(s,'%s+',sp));
end;
if accel.fVirt and FVirtKey <>0 then begin
GetKeyNameText(MakeLong(0,MapVirtualKey(accel.key,0)),
s,32);
end else begin
PWord(s)^:=accel.key;
end;}
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.
| Vorgefundene Kodierung: OEM (CP437) | 1
|
|
|