{ $A+,B-,D+,F-,G+,I+,K+,L+,N-,P-,Q-,R-,S+,T-,V+,W-,X+,Y+}
{$A+,B-,D-,F-,G+,I-,K-,L-,N-,P-,Q-,R-,S-,T-,V-,W-,X+,Y-}
{$M $2000,$8000} {32 Kilobyte Heap sollten reichen}
program VTW;
{$R VTW.RES}
{$D Videotext für Windows V.1.22 (01/97)}
{Künftige Zielstellung ist die Dreiteilung des Projekts in:
* VT-Seiten-Beschaffung (mit DDE und Packerei)
* VT-Seiten-Konvertierung (Text, Grafik und LinkList)
* Präsentation unter Windows
* Import / Exportfilter für verschiedene Dateiformate
Dateiformat .MGZ (russischer Videotext):
* Binärformat mit zusammenhängenden Seiten zu je 24*40=960 Bytes
* Bit 7 nirgends gesetzt, für 7-Bit-Binärkanäle geeignet
* Keine dedizierte Seiteninformation verfügbar
* Aufbau Kopfzeile:
- 7 Bytes 15h (Kennung?)
- 1 Byte Farbbyte für Kopfzeile (02h)
- 23 Bytes Kopfzeile, Inhalt beliebig
- 9 Bytes Magazin-Info: xxx-yy:zz
mit xxx=Seitennummer, yy=Unterseitennummer (01, wenn erste oder nur eine),
zz=maximale Unterseitennummer = Anzahl Unterseiten (01 wenn nur eine)
xxx,yy und zz sind ASCII-Zeichen (hexadezimal), '-' und ':' literal
* Die Art der Abspeicherung der Seiteninformation ist durchaus clever,
da der Inserter dort die Uhrzeit (8 Zeichen) sowie ein konstantes
Farbbyte (das erste der 9 Zeichen) einbaut für eine laufende Uhr
}
uses WinTypes, WinProcs, WinDos, OWindows, OMemory,
{OStdDlgs,} ODialogs, Strings, {Formats,} Objects, Win31,
CommDlg, ShellApi, LZExpand, WUtils {, WinExecE};
{WinExecE macht ernsthafte Probleme mit Windows NT, in meinem Fall
war kein Abbruch möglich, und der Bootsektor der Festplatte zerschossen!}
type char4=array[0..3]of char;
const
VTW_Name:array[0..9]of char='Videotext'#0;
{ INDIZES=2048;} {Keine Begrenzung durch dynamische Vewaltung}
MAGIC=$e6e8d4d6; {'VThf' mit gesetzten Bit7}
INDEXPP=249; {IndexeintrΣge pro fⁿhrender Index-Seite}
MAGIC_HS=$f3e8d4d6; {'VThs' mit gesetzten Bit7}
INDEXPP_HS=255; {im h#s-Format passen mehr EintrΣge 'rein}
const
FONTW=8; {Angaben zum verwendeten Videotext-Font}
FONTH=10;
SFontW:Integer=8;
SFontH:Integer=10;
type
Str40=String[40];
VTLine=array[0..39]of byte;
tIdx=record
case integer of
1: (Page,Subp:word);
2: (L:LongInt);
end;
tHeader=record
case integer of
1: (Page,Subp,CBits:word; errors:byte);
2: (Idx: tIdx);
end;
tSAATrail=record
Page10,Page1,Subp1000,Subp100,Subp10,Subp1,Page100,C1,C2,PBLF:byte;
end;
tHSFTrail=record {haftmann#software und FifiSoft Schwanz}
Acqisitor:byte; {Wer eingelesen hat}
MaxSubp:byte; {nur aus der Angabe xx/yy auf der Seite entnommen}
MsDosTime:record {Einlesezeitpunkt, zeitzonenabhΣngig}
case integer of
1: (L: LongInt);
2: (Time,Date:word);
end;
CRC:word; {Prⁿfsumme ⁿber diese Seite fⁿr Fehlerkorrektur}
Mirror:word; {Adresse einer Spiegelseite im XMS wΣhrend des Einlesens}
UnixTime:LongInt; {Einlesezeitpunkt, Universal Time}
end;
tPage=record
case integer of
0: (B: array[0..$3ff]of byte);
{ 1: (C: array[0..$3ff]of char);}
2: (L: array[0..24]of VTLine;
S: tSAATrail;
E: tHSFTrail);
3: (H: tHeader);
4: (TopLeft: array[0..6]of char);
end;
pIdxA=^tIdxA;
tIdxA=array[0..16380]of tIdx; {Nach oben offen - äh, durch 64KB begrenzt}
function LongMul(F1,F2:Integer):LongInt;
inline($5A/$58/$F7/$EA); {pop dx; pop ax; imul dx}
function LongDiv(Z:LongInt; N:Integer):Integer;
inline($59/$58/$5A/$F7/$F9); {pop cx; pop ax; pop dx; idiv cx}
{***********************}
{** Objektefreie Zone **}
{***********************}
{Programmstück Unsichtbare Kindfenster verwalten
GetWindowWord(0) liefert Seitennummer
GetWindowWord(2) liefert Unterseitennummer}
procedure Register;
{Registrierung der Fensterklasse}
const
wc: TWndClass=(
style: CS_ParentDC;
lpfnWndProc: @DefWindowProc;
cbClsExtra: 0;
cbWndExtra: 4; {Platz für Seite/Unterseite}
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'HiddenWnd');
begin
if HPrevInst=0 then begin
wc.hInstance:=hInstance;
wc.hCursor:=LoadCursor(hInstance,'HAND');
if not RegisterClass(wc) then halt(255);
end;
end;
function CreateInvisible(hParent:HWnd; const R: TRect; N: LongInt):HWnd;
{Ein unsichtbares Fenster erzeugen, das Fensterhandle darf verworfen werden}
var
Wnd: HWnd;
begin
Wnd:=CreateWindow('HiddenWnd',nil,
WS_Child or WS_Visible,
R.left,R.top,R.right-R.left,R.bottom-R.top,
hParent,0,hInstance,nil);
SetWindowLong(Wnd,0,N);
CreateInvisible:=Wnd;
end;
function IsTheInvisible(Wnd:HWnd):boolean;
var
S: array[0..31]of Char;
begin
GetClassName(Wnd,S,sizeof(S));
IsTheInvisible:=StrIComp(S,'HiddenWnd')=0;
end;
procedure DestroyInvisibles(hParent:HWnd);
{alle unsichtbaren Kindfenster entfernen}
var
Wnd,Wnd2: HWnd;
begin
Wnd:=GetWindow(hParent,GW_Child);
while Wnd<>0 do begin
Wnd2:=GetWindow(Wnd,GW_hWndNext);
if IsTheInvisible(Wnd) then
DestroyWindow(Wnd);
Wnd:=Wnd2;
end;
end;
function AppendNew(Wnd:HWnd; X,Y,W,H: Integer; P,S:Word):HWnd;
var
R:TRect;
begin
SetRect(R,X*SFontW,Y*SFontH+20,(X+W)*SFontW,(Y+H)*SFontH+20);
AppendNew:=CreateInvisible(Wnd,R,MakeLong(P,S));
end;
{Reaktion auf WM_ParentNotify}
{ WM_ParentNotify:
if wParam=WM_LButtonDown then begin
cWnd:=ChildWindowFromPoint(hWindow,TPoint(lParam));
if IsTheInvisible(cWnd) then begin
SelectPage(GetWindowWord(cWnd,0),GetWindowWord(cWnd,2),EQUALPAGE);
...
end;
end;}
{*******************}
{* Linklist-Objekt *}
{*******************}
(*
type
pRI=^tRI; {Linklist-Speicher"objekt"}
tRI=record
R:TRect;
I:TIdx;
end;
pLinklist=^tLinklist;
tLinklist=object(tCollection)
procedure FreeItem(Item: pointer); virtual;
procedure AppendNew(left,top,width,height:integer; Page,Subp: word);
end;
procedure tLinklist.FreeItem(Item:pointer);
begin
Dispose(pRI(Item)); {Speicher freigeben}
end;
procedure tLinklist.AppendNew(left,top,width,height:integer; Page,Subp: word);
var RI:pRI;
begin
New(RI); {Zeiger auf dyn. Variable beschaffen}
RI^.R.left:=left; {Dynamische Variable füllen}
RI^.R.top:=top; {Dynamische Variable füllen}
RI^.R.right:=left+width; {Dynamische Variable füllen}
RI^.R.bottom:=top+height; {Dynamische Variable füllen}
RI^.I.Page:=Page;
RI^.I.Subp:=Subp;
Insert(RI); {in die Kollektion stellen}
end;
*)
{********************}
{* Videotext-Objekt *}
{********************}
{ctrl0 ;Bit-Speicher
;0: Rolling Header (bei Spezialaufgabe) aus/ein
;1: Suche nach Pseudoseiten ein/aus
;2: Trage auch die 3stelligen Zahlen in Prädiktortabelle ein ein/aus
;3: [Teste Rolling Header NICHT auf Senderwechsel (RTL4-Problem) ein/aus]
;4: Lösche NICHT die Seite, bei der eine Unterseite 0 und eine <>0 gefunden wurde
;5: Quiet on/off (0=Piepser EIN!)
;6: Indexdatei zum VT-File NICHT schreiben e/a
;7: Fehler beim I²C-Bus (Standard-Fehlerroutine)
;8: Die Semaphorendatei muß am Ende geschrieben (erneuert) werden
; (Ist bei jedem Schreibzugriff auf CurVT..Req1 zu setzen!)
;9: Garbage Collection Mode aktiv
;10: Einlese-Mode aktiv
;11: Die VT-Datei ist NOCH NICHT vollständig aktualisiert (wird von VTFile_Load_Init gesetzt)
;12: Überlauf-Effekte bei den Indizes aufgetreten
;13: DOS-ERROR bei der Semaphorendatei aufgetreten
;14: DOS-ERROR bei der *.VT-Datei aufgetreten
;15: Disk Full (Schreibfehler)
ctrl1
;0: Zeitschoner-Bit (=1 wenn der Prädiktor garantiert nichts neues hat)
;1: Ein Kritischer Fehler (Int24) ist aufgetreten}
{const {Suchmodi, wenn angegebene Seite nicht gefunden:}
{ EQUALPAGE=1; {Seite und Unterseite muß stimmen}
{ NEXTPAGE=2; {Gehe zur nächsten Seite, minimale Unterseite}
{ PREVPAGE=3; {Gehe zur vorherigen Seite, minimale Unterseite}
{ NEXTSUB=4; {Gehe zur nächsten Unterseite mit Wrap-Around, Seite muß stimmen}
{ PREVSUB=5; {Gehe zur vorherigen Unterseite mit Wrap-Around, Seite muß stimmen}
{ NEXTSUBPAGE=6;{Gehe zur nächsten Unterseite, wenn nicht dann zur nächsten Seite}
{ PREVSUBPAGE=7;{Gehe zur vorherigen Unterseite, wenn nicht dann zur vorherigen Seite}
{ ADDNEXTPAGE=10;{wie NEXTPAGE, jedoch nicht die angegebene Seite nehmen}
{ SUBPREVPAGE=11;{wie PREVPAGE, jedoch nicht die angegebene Seite nehmen}
{ ADDNEXTSUB=12;{wie NEXTSUB, jedoch nicht die angegebene Unterseite nehmen}
{ SUBPREVSUB=13;{wie PREVSUB, jedoch nicht die angegebene Unterseite nehmen}
{ ADDNEXTSUBPAGE=14;{wie NEXTSUBPAGE, jedoch nicht die angegebene Seite nehmen}
{ SUBPREVSUBPAGE=15;{wie PREVSUBPAGE, jedoch nicht die angegebene Seite nehmen}
type
TSearchMode=(Default,EqualPage,NextPage,PrevPage,
NextSub,PrevSub,NextSubPage,PrevSubPage,
Unused,HomePage,AddNextPage,SubPrevPage,
AddNextSub,SubPrevSub,AddNextSubPage,SubPrevSubPage);
type
TVT=object
VTFile: HFile;
VREQFile: HFile;
VREQ: record
CurVT: array[0..8]of char;
GarbFlg: byte;
ctrl0: word;
ctrl1: word;
FuzzySender: byte;
FuzzyQuality: byte;
req: array[0..7]of TIdx; {Request-Indizes}
end;
IndexCnt: integer;
Index: pIdxA;
Header: tHeader;
LineInfo:array[0..24]of byte; {enthält pro Zeile Infos wie:
fQuiz: Zeile enthält QUIZ-Code ($18)
fBlink: Zeile enthält BLINK-Code ($08)
fDblH: Zeile enthält doppelt hohe Zeichen ($0D)
fMix: Zeile enthält Code zur Transparentumschaltung ($0A)
fPrevDblH: Vorhergehende Zeile enthält doppelt hohe Zeichen, Zeile ungültig
fTwoFonts: Zeile enthält ESC ($1B)}
Page: TPage;
Alter: TDateTime;
AlterStr: array[0..63] of Char;
{als String mit max. 2 Angaben, z.B. Stunden/Minuten, z.Z. in deutsch}
QuellZeitzone, LokaleZeitzone: Integer;
{ LinkList: pLinklist;}
Russisch: Boolean;
PageSize: Integer; {Länge einer Seite, z.B. 1024 oder 960}
constructor Init; {Page mit einer Startseite belegen}
function LoadFile(FileName:PChar):integer; {Rⁿckgabe: Fehlercode oder 0 wenn fehlerfrei}
function ReadIndex:integer; {Rⁿckgabe: dito}
{ function MkSortedIndex:integer; {Rueckgabe void}
procedure CloseFile; {Datei schlie▀en, Index l÷schen, Startseite}
function MkBitmap(dc:HDC;Flags,Land:word;const Bereich:TRect):integer; {mittels Windows-Funktionen Bitmap kreieren}
function MkText(Buf:PChar;Flags,Land:word;var Bereich:TRect):integer; {zu Text machen}
{ function ProcessPage(var Buf; Flags,Font:word; const Bereich:TRect; )}
{ function IsHot:boolean;}
{Testet, ob Datei gerade aktualisiert wird, und liest ggf. den Index neu ein}
{ function RequestPage(Desire:TIdx):boolean;}
{Eintrag in die VREQxxx.VTD, wenn IsHot=TRUE. Subp=FFFF wenn irrelevant}
{ function AcknowledgePage(Desire:TIdx):boolean;}
{Liest VREQxxx.VTD aus und testet das entspr. Bit}
{ function ChooseBroadcaster:boolean;}
{fuer eine kuenftige VTGRAB-Version, bei der dies eingebaut ist}
procedure IndexReAlloc(NewSize: Integer); {hier: auf lokalem Heap}
function MkLinkList(Wnd:HWnd;Flags:word):integer; {eine Rechteckliste erzeugen}
function PageContain(b:byte):boolean; {Test ob Seite dieses Zeichen enthΣlt}
function SelectPage(DP,DS:word;SearchMode:TSearchMode):word;
function SelectLoadPage(var Desire:TIdx; SearchMode:TSearchMode):word;
procedure SetupPage;
{Auswahl einer gewⁿnschten Seite aus Datei. Ist die Seite nicht verfⁿgbar, wird je
nach angegebenen Richtungen auf- oder abwΣrts gesucht. Wurde daraufhin eine gefunden, wird
"Sel" entsprechend gesetzt, und die Rⁿckgabe ist 0, ansonsten -1. Bei DOS-Fehlern erscheint
ebenfalls -1}
end;
{Videotext-Seitennummer in "gewöhnliches Format" wandeln}
function UsualPage(Page:word):word; assembler;
asm
mov ax,Page
and ax,7ffh {Obere Bits löschen}
cmp ax,100h
jnc @@e
add ax,800h {000..0FF --> 800..8FF}
@@e:
end;
{Videotext-Index in String wandeln}
function Idx2Str(Index:tIdx):PChar; {Nicht reentrant!}
const
Puffer: array[0..9]of char=''; {Statische Variable, Vorbelegung Wurst}
begin
Index.Page:=UsualPage(Index.Page);
Index.Subp:=Index.Subp and $3f7f;
wvsprintf(Puffer,'%03X/%02X',Index);
Idx2Str:=Puffer;
end;
{Seite auswählen, liefert Index-Nummer oder FFFF bei Fehler}
function TVT.SelectPage(DP,DS:word; SearchMode:TSearchMode): word;
var
i,idx: word; {Indizes}
BB,OO: LongInt; {BB:=Bester Abstand, OO:=Abstand, müßte "unsigned" sein!}
f01: word; {Entscheidet, ob GLEICHE Seite gefunden wird}
begin
OO:=$ffffffff;
BB:=OO;
idx:=$ffff; {ungültigen Indexeintrag vormerken}
DP:=DP and $7FF;
DS:=DS and $3F7F;
f01:=0;
if SearchMode=HomePage then begin
SearchMode:=NextSubPage;
DP:=$100; DS:=0;
end;
if Byte(SearchMode) and 8 <>0 then begin
Inc(f01);
Byte(SearchMode):=Byte(SearchMode) and not 8;
end;
if IndexCnt>0 then
for i:=0 to IndexCnt-1 do begin
if Index^[i].Page < $1000 then begin {Wenn Indexeintrag gültig}
case SearchMode of
NEXTPAGE: OO:=MakeLong(Index^[i].Subp and $3f7f,
Index^[i].Page and $7ff -DP-f01);
{Vorwärts, DesiredSub verwerfen}
PREVPAGE: OO:=MakeLong(Index^[i].Subp and $3f7f,
DP-Index^[i].Page and $7ff -f01);
{Rückwärts & Vorwärts, DesiredSub verwerfen}
NEXTSUB: if Index^[i].Page and $7ff=DP then {Gleiche Seite?}
OO:=LongInt(Index^[i].Subp) and $3f7f-DS-f01; {Vorwärts}
PREVSUB: if Index^[i].Page and $7ff=DP then {Gleiche Seite?}
OO:=LongInt(DS)-Index^[i].Subp and $3f7f-f01; {Rückwärts}
NEXTSUBPAGE: OO:=MakeLong(Index^[i].Subp and $3f7f,
Index^[i].Page and $7ff)-
MakeLong(DS,DP)-f01;
{Vorwärts, Abstand als LongInt}
PREVSUBPAGE: OO:=MakeLong(DS,DP)-
MakeLong(Index^[i].Subp and $3f7f,
Index^[i].Page and $7ff)-f01;
{Rückwärts, Abstand als LongInt}
EQUALPAGE: if (DP=Index^[i].Page and $7ff) and
(DS=Index^[i].Subp and $3f7f) then
OO:=0; {Nur wenn gleich den Index setzen}
end; {case}
asm {ich brauche hier "unsigned long", daher ASM}
mov ax,word [OO]; mov dx,word [OO+2];
sub ax,word [BB]; sbb dx,word [BB+2];
jnc @@1; {Springe NICHT wenn BB>OO war (vorzeichenlos mit CY)}
mov ax,word [OO]; {if OO<BB then begin BB:=OO;}
mov word [BB],ax;
mov ax,word [OO+2];
mov word [BB+2],ax;
mov ax,[i]; {idx:=i; end;}
mov [idx],ax;
@@1: end;
end; {if}
end; {for}
SelectPage:=idx;
end; {function}
function TVT.SelectLoadPage(var Desire: tIdx; SearchMode:TSearchMode): word;
var
i: word; {Lade-Index}
begin
if Index=nil then begin
{ memcpy(&Page,sPagedefault[country],1024);}
SetupPage; {kopieren und Header extrahieren}
SelectLoadPage:=$ffff; {"Fehler" melden}
exit;
end;
if SearchMode=Default then {Defaultwert?}
SearchMode:=NextSub; {Default-Suchmodus}
i:=SelectPage(Desire.Page,Desire.Subp,SearchMode);
if i<>$ffff then begin {Suche erfolgreich}
_llSeek(VTFile,LongMul(i,sizeof(Page)),0);
if _lRead(VTFile,@Page,PageSize)=PageSize then begin
SetupPage;
Desire:=Header.Idx; {Ergebnis rückschreiben}
Move((Idx2Str(Desire))^,Page.Topleft[1],6); {links oben hinpinseln}
end else begin
i:=$ffff;
end;
end;
SelectLoadPage:=i;
end;
constructor TVT.Init;
var hRes:THandle; {Handle auf Resource}
STZ: PChar;
EC: Integer;
begin {Startbild als Resource}
hRes:=LoadResource(hInstance,
FindResource(hInstance,MakeIntResource(49),RT_RCDATA));
Move(LockResource(hRes)^,Page,sizeof(Page)); {Resource feststellen und absaugen}
UnlockResource(hRes); FreeResource(hRes); {Resource verwerfen}
IndexCnt:=0;
Index:=nil;
Russisch:=false;
PageSize:=sizeof(TPage);
Header.Page:=$100; Header.Subp:=0; Header.CBits:=$4000; {Seite 100 Sprache deutsch}
{ New(LinkList,Init(32,32)); {Linkliste gültig machen}
{Zeitzonen-Variable auswerten. Wenn nicht vorhanden, dann Mitteleuropa
Aufbau der Variable z.B. TZ=MET-1DST:
3 Zeichen Zeitzonen-Code (hier nicht ausgewertet)
x Zeichen Zeitversatz in Stunden (eigentlich eine Floatpoint-Zahl)
y Zeichen (Rest): Sommerzeit-Information
Standardmäßig einzulesen mit sscanf(tz,"%3.3s%f%s",a,b,c)}
QuellZeitzone:=-1; {Versatz in Stunden}
STZ:=GetEnvVar('TZ');
if STZ<>nil then begin
Val(STZ[3],LokaleZeitzone,EC); {Erstes falsches Zeichen finden}
if EC>3 then STZ[3+EC]:=#0;
Val(STZ[3],LokaleZeitzone,EC);
if EC<>0 then LokaleZeitzone:=QuellZeitzone;
{Default: Keine Zeitdifferenz}
end;
end;
procedure TVT.IndexReAlloc(NewSize: Integer); {hier: auf lokalem Heap}
begin
if NewSize>$2000 then RunError; {Nie mehr als 8K Seiten}
if Index<>nil then FreeMem(Index,IndexCnt*sizeof(TIdx));
IndexCnt:=NewSize;
GetMem(Index,IndexCnt*sizeof(TIdx));
end;
function TVT.LoadFile(FileName:PChar):integer;
var
Path,Name: array[0..fsPathName]of Char;
Ext: array[0..fsExtension]of Char;
IdxFile: HFile;
Result: integer;
begin
FileSplit(FileName,Path,Name,Ext);
if StrLen(Name)=0 then begin
LoadFile:=-1; exit; end; {Fehler: Kein Dateiname}
lStrCat(Path,Name); {Path:=Path+Name}
IndexCnt:=0;
Russisch:=false;
StrECopy(StrECopy(Name,Path),'.vti');
IdxFile:=_lOpen(Name,0); {Path+'.VTI'} {Name dient als Zielpuffer}
if IdxFile<>HFile_Error then begin
IndexReAlloc(LongDiv(_llSeek(IdxFile,0,2),sizeof(TIdx)));
_llSeek(IdxFile,0,0); {setzt auch IndexCnt neu}
_lRead(IdxFile,PChar(Index),IndexCnt*sizeof(TIdx)); {Indexdatei einlesen}
_lClose(IdxFile);
end else begin
if lStrCmpi(Ext,'.mgz')=0 then Russisch:=true;
end;
if lStrLen(Ext)=0 then StrCopy(Ext,'.vt'); {Leere Extension als ".VT" annehmen}
StrECopy(StrECopy(Name,Path),Ext); {Path+Ext, Name dient als Zielpuffer}
VTFile:=_lOpen(Name,0);
Result:=Word(VTFile=HFile_Error);
if Result<>0 then begin
LoadFile:=Result; exit;
end else
if IndexCnt=0 then LoadFile:=ReadIndex else LoadFile:=0;
end;
function TVT.ReadIndex:integer; {Videotext-Index einlesen, alte und neue Form}
var
ph: LongInt;
procedure readall; {Klassisches Indexlesen, langsam}
var
i: integer;
begin
if IndexCnt>0 then {n÷tig da IndexCnt ein WORD ist}
for i:=0 to IndexCnt-1 do begin
_llSeek(VTFile,LongMul(i,sizeof(TPage)),0);
_lRead(VTFile,@(Index^[i]),sizeof(tidx));
end;
end; {readall}
procedure ReadNewIndex(indexpp:word); {Routine zum Einlesen eines New-Format-VT-Files}
{Die Kennung sei bereits vorher gecheckt! (schneller)}
var
i,i1: integer;
begin
{DateilΣnge:=Seitenzahl + (Seitenzahl+248) div INDEXPP, oder andersherum:}
{Seitenzahl:=DateilΣnge - (DateilΣnge+249) div (INDEXPP+1)}
i:=(IndexCnt+indexpp) div (indexpp+1); {Reservierte Seiten am Beginn}
for i1:=0 to i-1 do
Longint(Index^[i1]):=MAGIC; {Erste IndexeintrΣge sperren}
while i<IndexCnt do begin
_lRead(VTFile,@Page,sizeof(TPage)); {Eine Seite mit Indizes lesen}
if ph>=0 then RunError; {Bit15 mu▀ gesetzt sein, auch bei kⁿnftigen ─nderungen!}
i1:=IndexCnt-i; if i1>indexpp then i1:=indexpp; {Differenz, aber h÷chstens 255}
Move(Page.B[4],Index^[i],sizeof(tIdx)*i1); {Indizes kopieren}
Inc(i,i1); {gleich ein Ruck weiter}
end {while};
end;
procedure ReadRussischIndex;
var
S: array[0..7] of Char; {beinhaltet dann "?xxx-yy?"}
I,EC: Integer;
begin
I:=0; while I<IndexCnt do begin
_llSeek(VTFile,LongMul(I,PageSize)+30,0);
_lRead(VTFile,@S[1],6); {Lesen von "xxx-yy"}
S[0]:='$'; S[4]:=#0; Val(S,Index^[I].page,EC); {"$xxx0yy?"}
S[4]:='$'; S[7]:=#0; Val(PChar(@S[4]),Index^[I].subp,EC); {"$xxx$yy0"}
end;
end;
begin {ReadIndex}
PageSize:=sizeof(TPage);
if Russisch then PageSize:=960;
ReadIndex:=0; {Annahme: fehlerfrei}
IndexReAlloc(LongDiv(_llSeek(VTFile,0,2),PageSize));
_llSeek(VTFile,0,0);
{Anzahl der Seiten = Länge in Kilobytes}
if IndexCnt>0 then begin {Einen Bug ausbauen}
if Russisch then ReadRussischIndex
else begin
_lRead(VTFile,@ph,sizeof(ph)); {Headerbytes einlesen}
_llSeek(VTFile,0,0); {Dateizeiger zurⁿcksetzen}
if ph=MAGIC then ReadNewIndex(INDEXPP)
else if ph=MAGIC_HS then ReadNewIndex(INDEXPP_HS)
else readall;
end;
end;
end; {TVT.ReadIndex}
procedure TVT.CloseFile;
begin
_lClose(VTFile);
{ Dispose(LinkList,Done); {Objekt entfernen}
{ Linklist:=nil; {Programmierfehler aufspüren}
end;
{Die Flags beinhalten:
bit 0 Mit Quiz(1)
bit 1 Mit Blink(1)
bit 2 Mit Doppelter H÷he(1)
bit 3 Mit Transparent (MIX-Betrieb)(1)
bit 4 Invertierte Farben (schwarz->wei▀ usw)
bit 5 Einfarbig/Bunt(1)
bit 6 Debug-Flag (Anzeige der Schaltcodes)
bit 7 Rollende Unterseiten
bit 8 Doppelte Ausgabegroesze
bit 9 40 oder 41(1) Spalten
bit 10 24 oder 25(1) Zeilen
bit 11 Nur 1. Zeile (1)
bit 12 Berechnung in Pixel, bitte!
bit 12..15 Sprach (Font-) auswahl
0 default (je nach Header)
1 deutsch (usw.)
Topleft ist ein Ersatzstring fⁿr ganz links oben}
const
fQuiz=1 shl 0; fBlink=1 shl 1; fDblH=1 shl 2; fMix=1 shl 3;
fInvers=1 shl 4; fBunt=1 shl 5; fDebug=1 shl 6; fRoll=1 shl 7;
fDblSize=1 shl 8; f41=1 shl 9; f25=1 shl 10; f1=1 shl 11; fFont=$F000;
fPixels=1 shl 12;
fGraf=1 shl 8; fHold=1 shl 9; fSep=1 shl 10; fShift=1 shl 11; fLatin=1 shl 12;
fPrevDblH=1 shl 4;
fTwoFonts=1 shl 5;
{ Hilfsfunktionen fⁿr MkBitmap }
type tRGBWerte=array[0..8]of TColorRef;
const
RGBWerte:tRGBWerte=($000000,$0000FF,$00FF00,$00FFFF,
$FF0000,$FF00FF,$FFFF00,$FFFFFF,$808080);
RGBInversWerte:tRGBWerte=($FFFFFF,$0000FF,$008000,$0060A0,
$FF0000,$800060,$602000,$000000,$C0C0C0);
type
pCharImg=^tCharImg;
tCharImg=array[0..FONTH-1]of byte; {Ein Zeichenbild}
tCharImgTable=array[0..$1FF]of tCharImg; {die Zeichenbildtabelle zum Type-Casten}
{procedure Tele8x10; external; {$L Tele8x10} {der Font}
(*var GraphCharBuf:tCharImg; {eine statische VARIABLE}
{procedure DoubleBuf(var src,dest;count:word;Attr:byte); assembler;
{hΣngt an jedes Byte das Attribut an, hier zum Ausrichten der Bitmapzeilen auf Wortgrenzen}
asm mov cx,count
jcxz @@e
mov dx,ds
cld
mov ah,Attr
lds si,src
les di,dest
@@l: lodsb
stosw
loop @@l
mov ds,dx
@@e: end;
function GetCharImg(Code:integer):PCharImg;
procedure GenChar8x10(Code:Integer; var Buf); assembler;
asm mov ah,byte ptr Code
les di,Buf
cld
xor al,al
test ah,1 shl 6
jnz @@sep ;{Separierte Grafik}
call @@22 ;{Oberes Drittel}
call @@221
call @@2 ;{Mittleres Drittel}
call @@221 ;{Unteres Drittel}
jmp @@e
@@221: shr ah,2
@@22: call @@2
call @@2
@@2: test ah,1
jz @@2a
or al,$F0
@@2a: test ah,2
jz @@2b
or al,$F
@@2b: stosb
xor al,al
ret
@@111:
shr ah,2
@@11: call @@1
@@1: test ah,1
jz @@1a
or al,$60
@@1a: test ah,2
jz @@2b
or al,$6
jmp @@2b
@@sep:
stosb
call @@11 ;{Oberes Drittel}
stosb
call @@111
stosb ;{Mittleres Drittel}
call @@111
stosb ;{Unteres Drittel}
@@e: end;
begin
if Code<0 then begin
GenChar8x10(Code,GraphCharBuf); GetCharImg:=@GraphCharBuf;
end else if code<512 then
GetCharImg:=@tCharImgTable((@Tele8x10)^)[Code] {Dickes Typecasting}
else begin
MessageBox(0,'Code>=512!',nil,mb_ok);
GetCharImg:=@tCharImgTable((@Tele8x10)^)[32] {Dickes Typecasting}
end;
end;
*)
function memchr(const Buf; size:word; c:char):PChar; assembler;
{Enthaltensein eines Bytes im Speicherbereich testen}
asm mov cx,size
cld
mov al,c
les di,Buf
repne scasb {absuchen}
jnz @@1 {nicht gefunden: NIL}
dec di
mov ax,di
mov dx,es {Gefunden: DX:AX:=ES:DI-1}
jmp @@e
@@1: xor ax,ax
cwd {DX:AX:=0:0}
@@e: end;
function GetSlawicCase(Number:Integer):Integer;
{liefert Fall-Code für slawische Sprachen:
0 für Singular (1 god, 21 god, 101 god usw.), Fall Sg. Nominativ
1 für Plural "2..4" (2 goda, 23 goda, 154 goda), Fall Sg. Genitiv
2 für Plural sonst (5 let, 13 let, 100 let), Fall Pl. Genitiv}
(* begin
Number:=Abs(Number) mod 100;
{nur Zehner- und Einerstellen sind von Interesse}
if Number div 10 =1 then GetSlavicCase:=2 {immer 2 wenn Zehner=1}
else case Number mod 10 do {nur noch Einerstelle von Interesse}
1: GetSlavicCase:=0; {1: richtiger Singular}
2..4: GetSlavicCase:=1; {2..4}
else GetSlavicCase:=2; {5..0}
end;
end;*)
assembler; asm
mov ax,[Number]
or ax,ax
jns @@1
neg ax
@@1: mov dl,100
div dl {AX/DL=AL, AH=Rest}
xchg al,ah
cbw
mov dl,10
div dl
dec al
jz @@sc2
xor al,al
dec ah
jz @@sc0
inc al
cmp ah,4
jc @@sc1
@@sc2: mov al,2
@@sc0:
@@sc1:
cbw
end;
function MkSgPl(Wort:PChar; Zahl: Integer; Ziel:PChar):PChar;
{Singular, Plural oder Plural II aus der Wortvorgabe formen.
Enthält die Wortvorgabe ein &, wird der Plural slawisch ausgewertet, sonst
deutsch/englisch. Beispiele für Wort-Templates:
m#ouse$ice für mouse (Maus) oder mice (Mäuse)
#god$goda&let für god (Jahr), goda oder let (Jahre)
bab#y$ies für baby und babies (englische Kleinkinder)
Baby$s für Baby und Babys (deutsche -"- nach der Rechtschreibreform)
Das erste Sonderzeichen (#,$ oder &) markiert das Ende des (festen)
Wortstamms, nach # befindet sich die Singular-Endung, nach $ die Plural-
Endung, ist & enthalten, dann nach & die Plural2-Endung.
Im Falle deutsch/englisch darf # weggelassen werden}
var
C,ScanChar: Char;
begin
ScanChar:=#0; {Keine Token-Suche}
MkSgPl:=Ziel; {durchkoppeln}
repeat
C:=Wort^; Inc(Wort);
case C of
'#': if StrScan(Wort,'&')<>nil then begin
case GetSlawicCase(Zahl) of
1: ScanChar:='$';
2: ScanChar:='&';
end;
end else begin
if Zahl<>1 then ScanChar:='$'
end;
'$': if (ScanChar='$') or (Zahl<>1) then ScanChar:=#0 else ScanChar:='#';
'&': if ScanChar='&' then ScanChar:=#0 else ScanChar:='#';
#0: ; {Nichts tun}
else if ScanChar=#0 then begin {Zeichen kopieren erlaubt...}
Ziel^:=C; Inc(Ziel);
end;
end;
until C=#0;
Ziel^:=#0;
end;
procedure TVT.SetupPage;
var
Line: Integer;
CurTime,PageTime: TDateTime;
SixInts: array[0..5]of Integer absolute CurTime;
const Namen: array[0..5]of PChar=(
'Jahr$e','Monat$e','Tag$e','Stunde$n','Minute$n','Sekunde$n');
var
Params: record {für wvsprintf}
I1: Integer; S1: PChar;
I2: Integer; S2: PChar;
end;
S1,S2: array[0..31]of Char;
Trash: Word;
procedure SetBit(Mask:Byte);
begin
LineInfo[Line]:=LineInfo[Line] or Mask;
end;
procedure CheckLineBits(Line:Integer);
var
L: ^VTLine; {Rechnungen reduzieren}
begin
LineInfo[Line]:=0; {rücksetzen}
L:=@Page.L[Line];
if memchr(L^,40,#$18)<>nil then SetBit(fQuiz);
if memchr(L^,40,#$08)<>nil then SetBit(fBlink);
if memchr(L^,40,#$0A)<>nil then SetBit(fMix);
if memchr(L^,40,#$1B)<>nil then SetBit(fTwoFonts);
if memchr(L^,40,#$0D)<>nil then SetBit(fDblH);
end;
procedure CheckDblHChaining;
var
Line: Integer;
PDblH: Boolean;
begin
PDblH:=false;
for Line:=0 to 24 do begin
if PDblH then begin
SetBit(fPrevDblH);
PDblH:=false;
{egal, ob die aktuelle Zeile auch doppelt hohe Zeichen enthielt!}
end else begin
if LineInfo[Line] and fDblH <>0 then PDblH:=true;
end;
end;
end;
begin
if Russisch then begin
Move(Page.L[0][30],S1[1],6); {in einen Puffer kopieren}
S1[0]:='$'; S1[4]:=#0; Val(S1,Header.Page,Trash);
S1[4]:='$'; S1[7]:=#0; Val(PChar(@S1[4]),Header.Subp,Trash);
Header.CBits:=0; Header.errors:=0; {C-Bits usw. sind nicht verfügbar}
end else begin
Move(Page.H,Header,sizeof(tHeader)); {Header auslagern}
end;
Page.B[0]:=5; {magenta (also lila)}
FillChar(Page.B[1],6,' '); {mit Spaces füllen}
for Line:=0 to 24 do CheckLineBits(Line);
CheckDblHChaining;
{Altersbestimmung}
with CurTime do begin
GetDate(Year,Month,Day,Trash);{DayOfWeek in den Skat drücken}
GetTime(Hour,Min,Sec,Trash); {Hundertstelsekunden weg}
Inc(Hour,LokaleZeitzone);
end;
UnpackTime(Page.E.MsDosTime.L,PageTime);
Inc(PageTime.Hour,QuellZeitzone);
asm {Differenz bilden, in Assembler immer noch am schönsten}
mov ax,[CurTime.Sec]
sub ax,[PageTime.Sec]
jnc @@1
add ax,60 {der Trick: CY bleibt 1 !!}
@@1: mov [CurTime.Sec],ax
mov ax,[CurTime.Min]
sbb ax,[PageTime.Min]
jnc @@2
add ax,60
@@2: mov [CurTime.Min],ax
mov ax,[CurTime.Hour]
sbb ax,[PageTime.Hour]
cmp ax,24
{hier Probleme umgehen, die durch negative Stundenangaben entstehen können,
die duch das simple Addieren der Zeitzone s.o. auftreten können}
cmc
jnc @@3
add ax,24
@@3: mov [CurTime.Hour],ax
mov ax,[CurTime.Day]
sbb ax,[PageTime.Day]
cmp ax,30
{hier Probleme umgehen, da 1. die Tage 1-basiert sind und 2. die Tage bis 31
laufen können}
cmc
jnc @@4
add ax,30 {im Mittel hat ein Monat 30 Tage}
@@4: mov [CurTime.Day],ax
mov ax,[CurTime.Month]
sbb ax,[PageTime.Month]
cmp ax,12
{hier Probleme wegen 1-basierter Monatsangabe umgehen (??)}
cmc
jnc @@5
add ax,12
@@5: mov [CurTime.Month],ax
mov ax,[CurTime.Year]
sbb ax,[PageTime.Year]
mov [CurTime.Year],ax
end;
{nun String formen}
for Line:=0 to 4 do begin
if SixInts[Line]<>0 then break; {Erste Zahl ungleich Null auffinden}
end;
Params.I1:=SixInts[Line]; {Erste Zahl}
MkSgPl(Namen[Line],Params.I1,S1);
Params.S1:=S1; {2. Parameter ist Sg/Pl-Flag}
Inc(Line);
Params.I2:=SixInts[Line];
MkSgPl(Namen[Line],Params.I2,S2);
Params.S2:=S2;
wvsprintf(AlterStr,'%d %s %d %s',Params);
end;
function TVT.PageContain(b:byte):boolean; {Test ob Seite dieses Zeichen enthΣlt}
begin
PageContain:=memchr(Page,40*25,char(b))<>nil;
end;
function CalculateWidth(Flags:word):word;
var w:word;
begin
w:=40; if Flags and f41 <>0 then Inc(w);
if Flags and fPixels <>0 then begin
w:=w*FONTW;
if Flags and fDblSize <>0 then w:=w*2;
end;
CalculateWidth:=w;
end;
function CalculateHeight(Flags:word):word;
var w:word;
begin
w:=24; if Flags and f25 <>0 then Inc(w);
if Flags and f1 <>0 then w:=1;
if Flags and fPixels <>0 then begin
w:=w*FONTH;
if Flags and fDblSize <>0 then w:=w*2;
end;
CalculateHeight:=w;
end;
{C4 - Loeschen einer Seite
C5 - Schlagzeilen
C6 - Untertitel
C7 - Unterdruecken der Kopfzeile
C8 - Texterneuerung
C9 - Unterbrochene Sequenz
C10 - Unterdrueckung der Darstellung
C11 - Serielle Magazinfolge
C12 .. C14
000 - Englisch(0)
001 - Deutsch(4)
010 - Schweden/Finnisch(2)
011 - Italienisch(6)
100 - Belgisch/Franzoesisch(1)
101 - Portugisisch/Spanisch(5)
110 - dynamische Zeichenzuordnung(3)
111 - reserviert(7)
Ersetzkette 40 60 7B 23 24 ** ** ** 7C 7D 7E 5B 5C 5D 5E 5F }
const
LandMap:array[0..7]of byte=(2,7,3,0,1,8,6,0);
ErsetzKette:array[0..15]of char=
#$40#$60#$7B#$23#$24#$40#$40#$40#$7C#$7D#$7E#$5B#$5C#$5D#$5E#$5F;
{zum Vertauschen der Reihenfolge in die im Menⁿ:
default(0), *deutsch(1), *englisch(2), *schwedisch(3), polnisch(4), tschechisch(5),
*italienisch(6), *franz÷sisch(7), *spanisch(8), islΣndisch(9),
ungarisch(10), tⁿrkisch(11), reserve(12), reserve(13): Umcodierung der Zeichen in Ersetzkette;
kyrillisch(14),arabisch(15): Sonderrolle;
Fonts mit * werden auch automatisch erkannt}
const Grafik=0;OEM=1;ANSI=2;U7Bit=3; UseGrafikFillchar=4;
{Für die Vergleichsroutine}
const AnsiUmcodTab:array[192..255]of char=
'AAAAAAACEEEEIIIIDNOOOOO'#$d7+
'OUUUUYPsaaaaaaaceeeeiiiidnooooo'#$f7'ouuuuypy';
{Für die Erzeugung von blankem Text aus der Videotextseite}
const AnsiTab:array[32..255]of char=
' !"#$%&''()*+,-./0123456789:;<=>?'+
#$a7'ABCDEFGHIJKLMNOPQRSTUVWXYZ'#$c4#$d6#$dc'^_'+
#$b0'abcdefghijklmnopqrstuvwxyz'#$e4#$f6#$fc#$df' '+
'@-'#$bc#$a3'$ '#$a6#$be#$ad#$ab#$bd#$bb'^#'+
#$c9#$e9#$e4'#'#$a4' '#$f6#$e5#$fc#$c4#$d6#$c5#$dc'_'+
#$20#$20#$20#$20#$20#$20#$20'l'#$20#$20'SL'#$20#$20#$20#$20+
'c'#$e9#$e1'#'#$f9#$20#$20#$20#$e8#$fa'stz'#$ff#$ed'r'+
#$e9#$f9#$e0#$a3'$'#$e3#$f5#$b7#$f2#$e8#$ec#$b0#$e7#$bb'^#'+
#$e0#$e8#$e2#$e9#$ef#$c3#$d5#$c7#$f4#$fb#$e7#$eb#$ea#$f9#$ee'#'+
#$a1#$bf#$fc#$e7'$'#$aa#$ba#$d1#$f1#$e8#$e0#$e1#$e9#$ed#$f3#$fa+
#$c1#$c0#$c8#$cd#$cf#$d3#$d2#$da#$e6#$c6'dD'#$f8#$d8#$fe#$ee;
function Translate(c:byte;FlagReg,Land,DFlags:Word):integer;
var
ChChar:PChar;
code:integer;
begin
code:=c; {Standardfall}
if FlagReg and (fBlink or fQuiz) <>0 then
code:=32 {Leerzeichen ausgeben (Information verstecken)}
else if FlagReg and fGraf <>0 then begin
case code of
32..63: code:=integer(c)-128-32;
96..127: code:=integer(c)-128-96+32; {Negative Codes fⁿr Grafikzeichen}
end;
if (code<0)
and (FlagReg and fSep <>0)
then code:=code+64; {Separierte Grafik}
end;
if code>0 then begin {Wenn kein Grafikzeichen geworden
(Großbuchstaben) dann auch hier Landesregeln anwenden!}
case Land of
2..13: begin
ChChar:=memchr(ErsetzKette,16,char(code)); {12 = reserve I, 13 = reserve II}
if ChChar<>nil then
Code:=integer(Land+6) shl 4 + (ChChar-ErsetzKette); {Code im Bereich 80..13F}
end;
14..15:
if FlagReg and fLatin =0 then begin
if (code>=32) and (code<128) then
{8-bit-Codes sowie Debuginfos nicht transferieren}
Code:=integer(Land-14)*96+$140+(code-32); {Kyrillisch, arabisch im Bereich 140..1FF}
end else begin
ChChar:=memchr(ErsetzKette,16,char(code)); {12 = reserve I, 13 = reserve II}
if ChChar<>nil then
Code:=integer(2+6) shl 4 + (ChChar-ErsetzKette);
{Bei Lateinumschaltung gelten offenbar englische Codes}
end;
end; {case}
end; {if}
case DFlags and 3 of
Grafik: Translate:=code; {endlich ausgeben}
OEM: begin
if (code>=32) and (code<256) then begin
code:=Integer(AnsiTab[code]);
AnsiToOem(PChar(@code),PChar(@Code)); {Haarig, aber geht!?}
Translate:=code;
end else if DFlags and UseGrafikFillchar <>0 then
TransLate:=$B1
else
Translate:=$20;
end;
ANSI: begin
if (code>=32) and (code<256) then
Translate:=Integer(AnsiTab[code])
else if DFlags and UseGrafikFillchar <>0 then
TransLate:=$7F
else
Translate:=$20;
end;
U7BIT: begin
if (code>=32) and (code<=255) then begin
code:=Integer(AnsiTab[code]);
if (code>=192) and (code<=255) then
code:=Integer(AnsiUmcodTab[code]);
end;
if (code<32) or (code>=127) then begin
if DFlags and UseGrafikFillchar <>0 then
TransLate:=Integer('X')
else
Translate:=$20;
end;
end;
end;
end;
function TVT.MkText(Buf:PChar;Flags,Land:word; var Bereich:TRect):integer;
{Bereich bezeichnet den darzustellenden Ausschnitt}
var Lines: Integer;
Cur: TPoint;
HFarbe,VFarbe: byte; {Farbattribute}
FlagReg: word; {Sonstige laufende Attribute}
CurByte,OldByte: byte; {um nicht jedesmal das Array adressieren zu mⁿssen}
procedure WriteCharTranslate(c:byte);
begin
if (Bereich.left<=Cur.X) and (Cur.X<Bereich.right)
{PtInRect(Bereich,Cur)} then begin {später: Region!}
Buf^:=Char(Translate(c,FlagReg,Land,ANSI));
Inc(Buf);
end;
end;
begin
{mit Schleifen loslegen}
if Land=0 then Land:=LandMap[(Header.CBits shr 12) and 7]; {Wenn default(Auto-detect) dann aus den code-Bits}
for Cur.Y:=Bereich.top to Bereich.bottom do
if LineInfo[Cur.Y] and fPrevDblH =0 then begin
HFarbe:=0; VFarbe:=7; {Wei▀ auf Schwarz}
FlagReg:=0; {alle Flags aus}
if (Flags and fMix <>0) or (Header.CBits and $60 <>0) then
FlagReg:=fMix; {in diesen beiden FΣllen mit MIXED starten}
OldByte:=32; {auch das vorhergehende Byte zu Space machen}
for Cur.X:=0 to 39 do begin
CurByte:=byte(Page.L[Cur.Y,Cur.X]); {aus der Seite}
{Sofort wirksame Schalter}
case CurByte of
28:HFarbe:=0; {Hintergrund schwarz}
29:HFarbe:=VFarbe; {Hintergrund=Vordergrund}
end;
{Ein Zeichen ausgeben}
if (CurByte<$20) and (Flags and fDebug =0) then begin
if (FlagReg and (fHold or fGraf) = (fHold or fGraf)) and {HoldGrafix und GrafikFlag}
((OldByte and not $40 >=$20) and (OldByte and not $40 <$40))
then WriteCharTranslate(OldByte)
else WriteCharTranslate(32);
end else begin
WriteCharTranslate(CurByte);
OldByte:=CurByte;
end;
{Nachher wirksame Schalter}
if (CurByte<$20) then
FlagReg:= FlagReg and not fQuiz; {Secret aus}
case CurByte of
0..7: begin
FlagReg:= FlagReg and not fGraf; {Grafikflag aus}
VFarbe:=CurByte; end; {Farbe setzen}
8: if Flags and fBlink =0 then {wenn "blinkende Zeichen AUS"}
FlagReg:= FlagReg or fBlink; {Blinken ein}
9: FlagReg:= FlagReg and not fBlink; {Blinken aus}
10: if Flags and fMix <>0 then {Wenn Mix-Betrieb EIN}
FlagReg:= FlagReg or fMix; {InBox aus}
11: FlagReg:= FlagReg and not fMix; {InBox ein}
12: FlagReg:= FlagReg and not fDblH; {DoubleHeigth aus}
13: {wenn nicht verboten}
FlagReg:= FlagReg or fDblH; {DoubleHeigth ein}
14: FlagReg:= FlagReg and not fShift; {Shift aus (spΣter verwendet)}
15: FlagReg:= FlagReg or fShift; {Shift ein (spΣter verwendet)}
16..23: begin
FlagReg:= FlagReg or fGraf; {Grafikflag ein}
VFarbe:=CurByte and 7; {Farbe setzen}
end;
24: if Flags and fQuiz =0 then {wenn "Quiz-Zeichen AUS"}
FlagReg:= FlagReg or fQuiz; {Secret ein}
25: FlagReg:= FlagReg and not fSep; {separated aus}
26: FlagReg:= FlagReg or fSep; {separated ein}
27: FlagReg:= FlagReg xor fLatin; {Sprachumschaltung Lateinisch}
30: FlagReg:= FlagReg or fHold; {holdgrafix ein}
31: FlagReg:= FlagReg and not fHold; {holdgrafix aus}
end; {case}
end; {1 Zeile}
if Flags and f41 <>0 then begin
HFarbe:=0; {Schwarz}
FlagReg:=0; {alle Flags aus}
if (Flags and fMix <>0) or (Header.CBits and $60 <>0) then
FlagReg:=fMix; {in diesen beiden FΣllen mit MIXED das Space ausgeben}
Cur.X:=40;
WriteCharTranslate(32); {noch ein Space dran}
end;
Buf^:=#13; Inc(Buf); Buf^:=#10; Inc(Buf);
end; {else, KEIN END fⁿr FOR}
Buf^:=#0; {das Nullterminieren nicht vergessen!}
end;
function TVT.MkBitmap(dc:HDC;Flags,Land:word;const Bereich:TRect):integer;
{Bereich bezeichnet den darzustellenden Ausschnitt}
var Lines,Line,Col: byte;
HFarbe,VFarbe: byte; {Farbattribute}
FlagReg: word; {Sonstige laufende Attribute}
LineContainsDblh: boolean;
BitmapHandle,OldBitmapHandle: HBitmap;
MemoryDC: HDC; {ein Hilfs-GerΣtekontext}
CurByte,OldByte: byte; {um nicht jedesmal das Array adressieren zu mⁿssen}
mode:LongInt; {BitBlt-Mode}
RGBWertePtr:^tRGBWerte; {Auswahl der "Palette"}
procedure WriteChar(Code:integer);
{schreibt ein Zeichen in das Device Context}
var
{ Bitbuf:array[0..FONTH-1]of word;}
CharPos:TPoint;
begin
{ DoubleBuf(GetCharImg(Code)^,Bitbuf,FONTH,0); {die Null ist wichtig fⁿrs Ausfⁿllen}
{ SetBitmapBits(BitmapHandle,FONTH*2,@Bitbuf); {Bits ⁿbernehmen lassen}
Inc(Code,128); {Bitmap hat vorn die Grafikzeichen}
CharPos.X:=(Code mod 32) * fontw;
CharPos.Y:=(Code div 32) * fonth;
if Flags and fBunt <>0 then begin
if (Flags and fDebug <>0)
and (HFarbe=VFarbe) {Schwarzer Adler auf schwarzem Grund?}
then SetBkColor(dc,RGBWertePtr^[7-VFarbe]) {Komplementärfarbe!}
else SetBkColor(dc,RGBWertePtr^[VFarbe]); {1-Pixel werden auf BkColor gesetzt!!}
if FlagReg and fMix <>0 then
SetTextColor(dc,RGBWertePtr^[8])
else SetTextColor(dc,RGBWertePtr^[HFarbe]); {Farben am Ziel-DC einstellen}
end;
if FlagReg and fDblH <>0 then
StretchBlt(dc,Col*FONTW,Line*FONTH,FONTW,FONTH*2,MemoryDC,
CharPos.X,CharPos.Y,fontw,fonth,mode)
{Zeichen in doppelter H÷he kopieren}
else begin
BitBlt(dc,Col*FONTW,Line*FONTH,FONTW,FONTH,MemoryDC,
CharPos.X,CharPos.Y,mode);
{Zeichen normal kopieren}
if LineContainsDblH then
BitBlt(dc,Col*FONTW,(Line+1)*FONTH,FONTW,FONTH,MemoryDC,
0,0,mode);
{Notgedrungenen Leeraum aus der kreierten Bitmap darunter kopieren}
end;
end; {WriteChar}
procedure WriteCharTranslate(c:byte);
var
ChChar:PChar;
code:integer;
begin
Code:=Translate(c,FlagReg,Land,Grafik); {Übersetzen in "Integer-Zeichen"}
WriteChar(code); {endlich ausgeben}
end;
function CanDblH:boolean; {Doppelte Zeichenh÷he erlaubt?}
begin
CanDblH:=(Line<>0) and (Line<>Lines-1) and (Flags and fDblH <>0);
end;
begin
{Kontext erstellen}
MemoryDC := CreateCompatibleDC(dc); {Hilfsbitmap erstellen}
{ BitmapHandle:=CreateBitmap(FONTW*2,FONTH,1,1,nil); {Ein leeres Bitmap}
BitmapHandle:=LoadBitmap(HInstance,MakeIntResource(10));
OldBitmapHandle:=SelectObject(MemoryDC, BitmapHandle); {wie im Lehrbuch}
{Randwerte initialisieren}
Lines:=CalculateHeight(Flags and not fPixels);
Mode:=SRCCOPY; {BitBlt-Modus festlegen}
if (flags and fBunt =0) and (Flags and fInvers <>0) then Mode:=NOTSRCCOPY;
RGBWertePtr:=@RGBWerte;
if flags and fInvers <>0 then RGBWertePtr:=@RGBInversWerte;
{mit Schleifen loslegen}
LineContainsDblH:=FALSE;
if Land=0 then Land:=LandMap[(Header.CBits shr 12) and 7]; {Wenn default(Auto-detect) dann aus den code-Bits}
for Line:=0 to Lines-1 do
if LineContainsDblH then {hier: vorhergehende Linie!}
LineContainsDblH:=FALSE {nichts weiter tun, dann nΣchste Zeile}
else begin
LineContainsDblH:=CanDblH and (memchr(Page.L[Line],40,#13)<>nil); {Stellen}
HFarbe:=0; VFarbe:=7; {Wei▀ auf Schwarz}
FlagReg:=0; {alle Flags aus}
if (Flags and fMix <>0) or (Header.CBits and $60 <>0) then
FlagReg:=fMix; {in diesen beiden FΣllen mit MIXED starten}
OldByte:=32; {auch das vorhergehende Byte zu Space machen}
for Col:=0 to 39 do begin
CurByte:=byte(Page.L[Line,Col]); {aus der Seite}
{Sofort wirksame Schalter}
case CurByte of
9: FlagReg:= FlagReg and not fBlink; {Blinken aus}
12: FlagReg:= FlagReg and not fDblH; {DoubleHeigth aus}
24: if Flags and fQuiz =0 then {wenn "Quiz-Zeichen AUS"}
FlagReg:= FlagReg or fQuiz; {Secret ein}
28:HFarbe:=0; {Hintergrund schwarz}
29:HFarbe:=VFarbe; {Hintergrund=Vordergrund}
30: FlagReg:= FlagReg or fHold; {holdgrafix ein}
end;
{Ein Zeichen ausgeben}
if (CurByte<$20) and (Flags and fDebug =0) then begin
if (FlagReg and (fHold or fGraf) = (fHold or fGraf)) and {HoldGrafix und GrafikFlag}
((OldByte and not $40 >=$20) and (OldByte and not $40 <$40))
then WriteCharTranslate(OldByte)
else begin
WriteCharTranslate(32);
OldByte:=32;
end;
end else begin
WriteCharTranslate(CurByte);
OldByte:=CurByte;
end;
{Nachher wirksame Schalter}
if (CurByte<$20) and (CurByte<>24) then
FlagReg:= FlagReg and not fQuiz; {Secret aus}
case CurByte of
0..7: begin
FlagReg:= FlagReg and not fGraf; {Grafikflag aus}
VFarbe:=CurByte; end; {Farbe setzen}
8: if Flags and fBlink =0 then {wenn "blinkende Zeichen AUS"}
FlagReg:= FlagReg or fBlink; {Blinken ein}
10: if Flags and fMix <>0 then {Wenn Mix-Betrieb EIN}
FlagReg:= FlagReg or fMix; {InBox aus}
11: FlagReg:= FlagReg and not fMix; {InBox ein}
13: if CanDblH then {wenn nicht verboten}
FlagReg:= FlagReg or fDblH; {DoubleHeigth ein}
14: FlagReg:= FlagReg and not fShift; {Shift aus (spΣter verwendet)}
15: FlagReg:= FlagReg or fShift; {Shift ein (spΣter verwendet)}
16..23: begin
FlagReg:= FlagReg or fGraf; {Grafikflag ein}
VFarbe:=CurByte and 7; {Farbe setzen}
end;
25: FlagReg:= FlagReg and not fSep; {separated aus}
26: FlagReg:= FlagReg or fSep; {separated ein}
27: FlagReg:= FlagReg xor fLatin; {Sprachumschaltung Lateinisch}
31: FlagReg:= FlagReg and not fHold; {holdgrafix aus}
end; {case}
end; {1 Zeile}
if Flags and f41 <>0 then begin
HFarbe:=0; {Schwarz}
FlagReg:=0; {alle Flags aus}
if (Flags and fMix <>0) or (Header.CBits and $60 <>0) then
FlagReg:=fMix; {in diesen beiden FΣllen mit MIXED das Space ausgeben}
Col:=40;
WriteCharTranslate(32); {noch ein Space dran}
end;
end; {else, KEIN END fⁿr FOR}
{Kontext aufl÷sen}
SelectObject(MemoryDC,OldBitmapHandle);
DeleteDC(MemoryDC);
DeleteObject(BitmapHandle); {Alles lehrbuchmΣ▀ig}
end;
function TVT.MkLinkList(Wnd:HWnd;Flags:word):integer; {eine Rechteckliste erzeugen}
var Lines,Line,Col: byte;
FlagReg: word; {Sonstige laufende Attribute}
LineContainsDblh: boolean;
CurByte: byte; {um nicht jedesmal das Array adressieren zu mⁿssen}
Ziffern,Winkel:byte; Seite:word;
cWinkel:char;
function CanDblH:boolean; {Doppelte Zeichenh÷he erlaubt?}
begin
CanDblH:=(Line<>0) and (Line<>Lines-1) and (Flags and fDblH <>0);
end;
procedure TestZiffern;
var i:word;
begin
if (Ziffern=3) and (Seite>=$100) and (Seite<=$899) then begin {Treffer}
i:=SelectPage(Seite and $7FF, 0, NEXTSUB);
if (i<>$FFFF) and (Index^[i].L<>Header.Idx.L) then begin
{Wenn Seite tatsächlich gefunden und nicht die gerade angezeigte ist}
AppendNew(Wnd,Col-Ziffern,Line,Ziffern,1+byte(FlagReg and fDblH <>0),
Index^[i].Page, Index^[i].Subp); {eintragen (Keine Telefonnummern verfolgen}
end;
end;
Ziffern:=0; {ZΣhler erneut scharfmachen}
Seite:=0;
end;
procedure TestWinkel;
var i:word; sm:TSearchMode; {Gefundenen Index sowie Suchmodus}
begin
if (Winkel>=1) and (Winkel<=3) then begin {Hier: Nur 1..3 Winkel zulassen}
if cWinkel='>' then sm:=ADDNEXTSUBPAGE
else sm:=SUBPREVSUBPAGE;
i:=SelectPage(Header.Page,Header.Subp,sm); {Neue Seite suchen}
if i<>$FFFF then
AppendNew(Wnd,Col-Winkel,Line,Winkel,1+byte(FlagReg and fDblH <>0),
Index^[i].Page, Index^[i].Subp);
end;
Winkel:=0; {ZΣhler erneut scharfmachen}
end;
begin
{ LinkList^.FreeAll; {Liste leeren}
DestroyInvisibles(Wnd);
Lines:=CalculateHeight(Flags and not fPixels);
{mit Schleifen loslegen}
LineContainsDblH:=FALSE;
for Line:=0 to Lines-1 do
if LineContainsDblH then {hier: vorhergehende Linie!}
LineContainsDblH:=FALSE {nichts weiter tun, dann nΣchste Zeile}
else begin
FlagReg:=0; Ziffern:=0; Winkel:=0; Seite:=0; cWinkel:=' ';
for Col:=0 to 39 do begin
CurByte:=byte(Page.L[Line,Col]); {aus der Seite}
if (CurByte<$20) then
FlagReg:= FlagReg and not fQuiz; {Secret aus}
case CurByte of
0..7: FlagReg:= FlagReg and not fGraf; {Grafikflag aus}
12: FlagReg:= FlagReg and not fDblH; {DoubleHeigth aus}
13: if CanDblH then begin {wenn nicht verboten}
FlagReg:= FlagReg or fDblH; {DoubleHeigth ein}
LineContainsDblH:=TRUE; {markieren, nΣchste Zeile auszulassen}
end;
16..23: FlagReg:= FlagReg or fGraf; {Grafikflag ein}
24: if Flags and fQuiz =0 then {wenn "Quiz-Zeichen AUS"}
FlagReg:= FlagReg or fQuiz; {Secret ein}
end;
if FlagReg and (fGraf or fQuiz) <>0 then
CurByte:=32; {Leerzeichen annehmen}
if (CurByte>=$30) and (CurByte <=$39) then begin {Ziffer?}
Inc(Ziffern); Seite:=Seite shl 4 +(CurByte-$30); {Seitennummer akkumulieren}
end else TestZiffern;
if Char(CurByte)<>cWinkel then TestWinkel;
cWinkel:=Char(CurByte);
case cWinkel of
'>','<': Inc(Winkel) {Winkel? (Zähler erhöhen)}
end;
end;{for}
Col:=40;
TestZiffern; {41. Spalte}
TestWinkel;
end;{else}
end;
{*****************************}
{* Ende Objektdefinition TVT *}
{*****************************}
var
VT:tVT; {Statisches Objekt}
const
SDM:boolean=false; {Self Destruction Mode Flag}
SDM_EXE:boolean=false;
SDM_Dir:boolean=false;
SDM_WININI:boolean=true;
SDM_REGDAT:boolean=true; {Destruction Items}
function GetFileAttr(Name:PChar):Word; assembler;
asm
push ds
lds dx,[Name]
mov ax,4300h
int 21h
pop ds
jc @@err
xor ax,ax {kein Dosenerror melden}
@@err:
mov cx,-1
mov [DosError],ax
mov ax,cx
@@e:
end;
type
PSDMDlg=^TSDMDlg;
TSDMDlg=object(TDialog)
procedure SetupWindow; virtual;
function CanClose:boolean; virtual;
end;
procedure TSDMDlg.SetupWindow;
var
S,S1: array[byte]of char;
begin
GetArgStr(S,0,sizeof(S)); {Eigener Programmname}
GetDlgItemText(HWindow,111,S1,sizeof(S1));
wvsprintf(S1,S1,S[0]); {Dateiname einsetzen}
SetDlgItemText(HWindow,111,S1);
if GetFileAttr(S) and faReadOnly <>0 then
SendDlgItemMessage(HWindow,101,WM_Enable,0,0); {Grau schalten}
CheckDlgButton(HWindow,103,1); {ankreuzen}
CheckDlgButton(HWindow,104,1); {ankreuzen}
end;
function TSDMDlg.CanClose:boolean;
begin
CanClose:=true;
MessageBeep(MB_IconExclamation);
SDM:=true;
SDM_Exe:=Boolean(IsDlgButtonChecked(HWindow,101)); {angekreuzt?}
SDM_Dir:=Boolean(IsDlgButtonChecked(HWindow,102)); {angekreuzt?}
SDM_WinIni:=Boolean(IsDlgButtonChecked(HWindow,103)); {angekreuzt?}
SDM_RegDat:=Boolean(IsDlgButtonChecked(HWindow,104)); {angekreuzt?}
PostQuitMessage(0);
end;
type
{****************************}
{* Objektdefinition TVTWApp *}
{****************************}
TVTWApp = object(TApplication)
constructor Init(AName:PChar);
procedure InitMainWindow; virtual;
procedure InitInstance; virtual;
function ProcessAppMsg(var Message:TMsg):boolean; virtual;
destructor done; virtual;
end;
var
VTWApp: TVTWApp;
constructor TVTWApp.Init;
begin
FileMode:=0; {Nichts anbrennen lassen}
VT.Init; {Erst mal unser eigenes Objekt}
inherited Init(AName);
end;
procedure TVTWApp.InitInstance;
begin
inherited InitInstance;
hAccTable:=LoadAccelerators(hInstance,'MAIN');
end;
destructor TVTWApp.Done;
var
S,P:array[0..127]of char;
ReOpenBuf: TOfStruct;
begin
inherited Done;
if SDM then begin
GetArgStr(S,0,sizeof(S));
if SDM_Exe then begin
OpenFile(S,ReOpenBuf,OF_Delete);
end;
if SDM_Dir then begin
FileSplit(S,P,nil,nil);
RemoveDir(P);
end;
if SDM_WinIni then begin
WriteProfileString(VTW_Name,nil,nil) {wegputzen}
end;
if SDM_RegDat then begin
RegDeleteKey(HKEY_Classes_Root,'.VT');
RegDeleteKey(HKEY_Classes_Root,'h#s Videotext Betrachter');
end;
end;
end;
{*********************************}
{* Ende Objektdefinition TVTWApp *}
{*********************************}
function Contain(const R:TRect;P:TPoint):boolean; {Punkt in Rechteck?}
begin
Contain:=(R.Left<=P.x) and (P.x<R.Right) and (R.Top<=P.y) and (P.y<R.Bottom);
end;
{*********************************************************}
{* THistory, ein Objekt zur Verwaltung der History-Liste *}
{*********************************************************}
const
HISTSIZE=100; {das Objekt merkt sich maximal 100 EintrΣge}
type
tHistory=object
Hist:array[0..HISTSIZE-1]of tIdx; {das "GedΣchtnis"}
HistPtr,HistLen:word; {2 Indizes}
constructor Init;
destructor Done;
procedure Append(const That:tIdx); {geht immer, notfalls wird das Array verschoben}
function Fwd(var That:tIdx):boolean; {Ergebnis=FALSE, wenn Schritt nicht m÷glich}
function CanFwd:Boolean;
function Back(var That:tIdx):boolean;
function CanBack:Boolean;
end;
constructor tHistory.Init;
begin HistPtr:=0; HistLen:=0; end;
destructor tHistory.Done;
begin end;
procedure tHistory.Append(const That:tIdx); {geht immer, notfalls wird das Array verschoben}
begin
if HistPtr=HISTSIZE then begin
Move(Hist[1],Hist[0],sizeof(tIdx)*(HISTSIZE-1)); {Jeden Index vorschieben}
Dec(HistPtr);
end;
Hist[HistPtr]:=That;
Inc(HistPtr);
HistLen:=HistPtr; {LΣnge kⁿrzen}
end;
function tHistory.Fwd(var That:tIdx):boolean; {Ergebnis=FALSE, wenn Schritt nicht m÷glich}
begin
Fwd:=CanFwd;
if CanFwd then begin
That:=Hist[HistPtr];
Inc(HistPtr);
end;
end;
function tHistory.CanFwd:Boolean;
begin CanFwd:=(HistPtr<HistLen); end;
function tHistory.Back(var That:tIdx):boolean;
begin
Back:=CanBack;
if CanBack then begin
Dec(HistPtr);
That:=Hist[HistPtr-1];
end;
end;
function tHistory.CanBack:Boolean;
begin CanBack:=(HistPtr>=2); end;
{Dialog "Neue Seite"}
{objektfrei}
function GotoDlgProc(hWindow:HWnd; Msg,wParam:Word; lParam: LongInt):
Bool; export;
var
lPtr: PChar absolute lParam; {Vereinfachung des lParam-Zugriffs}
S: array[0..31]of Char;
Pg: Word; ec: Integer;
const
IdxP: ^TIdx=nil; {"Transfer-Zeiger"}
begin
GotoDlgProc:=false;
case Msg of
WM_InitDialog: begin
IdxP:=Pointer(lParam); {schlucken}
Pg:=UsualPage(IdxP^.Page);
wvsprintf(S,'%X',Pg); {in Hexzahl konvertieren}
SendDlgItemMessage(hWindow,101,CB_AddString,0,LongInt(@S));
SendDlgItemMessage(hWindow,101,CB_SetCurSel,0,0);
GotoDlgProc:=true; {?? Immer diese Objekte !!}
end;
WM_Command: case wParam of
IDOK: begin
{ Pg:=Word(SendDlgItemMessage(hWindow,101,CB_GetCurSel,0,0));
SendDlgItemMessage(hWindow,101,CB_GetLBText,Pg,LongInt(@S[1]));}
GetDlgItemText(hWindow,101,@S[1],sizeof(S)-1);
S[0]:='$'; {Hexzahl erzwingen}
Val(S,Pg,ec);
if ec=0 then begin
IdxP^.Page:=Pg and $7FF;
IdxP^.SubP:=0;
EndDialog(hWindow,1);
end else begin
MessageBox(hWindow,'Falsche Ziffern!',S,MB_OK or MB_IconExclamation);
end;
end;
IDCancel: EndDialog(hWindow,0);
101: begin
{hier Routinen zum Zeichnen der künftigen Owner-Draw-Listbox}
end;
end;
end;
end;
{Dialog "Ränder"}
type
TMargin=record
left,right: Integer;
enabled, Strichkiller: Bool;
end;
{objektfrei}
function MarginDlgProc(hWindow:HWnd; Msg,wParam:Word; lParam: LongInt):
Bool; export;
var
TranslateOK: Bool;
Margin: TMargin; {Kopie auf Stack fürs Einsammeln der Werte}
const
MP: ^TMargin=nil; {"Transfer-Zeiger"}
begin
MarginDlgProc:=false;
case Msg of
WM_InitDialog: begin
MP:=Pointer(lParam); {schlucken}
SetDlgItemInt(hWindow,101,MP^.left,true);
SetDlgItemInt(hWindow,102,MP^.right,true);
CheckDlgButton(hWindow,103,Word(MP^.enabled));
CheckDlgButton(hWindow,104,Word(MP^.StrichKiller));
SendMessage(hWindow,WM_Command,103,MakeLong(0,BN_Clicked));
MarginDlgProc:=true; {?? Immer diese Objekte !!}
end;
WM_Command: case wParam of
IDOK: begin
Margin.left:=GetDlgItemInt(hWindow,101,@TranslateOK,true);
if TranslateOK then begin
Margin.right:=GetDlgItemInt(hWindow,102,@TranslateOK,true);
if TranslateOK then begin
if (0<Margin.left)
and (Margin.left<=Margin.right)
and (Margin.right<=40) then begin
Margin.enabled:=Bool(IsDlgButtonChecked(hWindow,103));
Margin.Strichkiller:=Bool(IsDlgButtonChecked(hWindow,104));
MP^:=Margin; {Transfer 'runter}
EndDialog(hWindow,1);
exit;
end;
end;
end;
MessageBox(hWindow,'Falsche Eingabe!',nil,MB_OK or MB_IconExclamation);
end;
IDCancel: EndDialog(hWindow,0);
103: if HiWord(lParam)=BN_Clicked then begin
Margin.enabled:=Bool(IsDlgButtonChecked(hWindow,103));
EnableWindow(GetDlgItem(hWindow,101),Margin.enabled);
EnableWindow(GetDlgItem(hWindow,102),Margin.enabled);
end;
end{case wParam};
end{case Msg};
end;
{Dialog "Info"}
{objektfrei}
function InfoDlgProc(hWindow:HWnd; Msg,wParam:Word; lParam: LongInt):
Bool; export;
const
Inf1: array[4..11]of PChar=(
'C4-L÷schen einer Seite','C5-Schlagzeilen',
'C6-Untertitel','C7-Unterdrⁿcken der Kopfzeile',
'C8-Texterneuerung','C9-Unterbrochene Sequenz',
'C10-Unterdrⁿckung der Darstellung','C11-Serielle Magazinfolge');
Inf2: array[0..7]of PChar=(
'Englisch(0)','Belgisch/Franz÷sisch(4)',
'Schwedisch/Finnisch(2)','dynamische Zeichenzuordnung(6)',
'Deutsch(1)','Portugisisch/Spanisch(5)',
'Italienisch(3)','reserviert(7)');
var
I: Integer;
begin
InfoDlgProc:=false;
case Msg of
WM_InitDialog: begin {lParam enthält die C-Bits}
SetDlgItemText(hWindow,101,Inf2[(lParam shr 12)and 7]);
for I:=4 to 11 do
if lParam and (1 shl I) <>0 then
SendDlgItemMessage(hWindow,102,LB_AddString,0,LongInt(Inf1[I]));
InfoDlgProc:=true; {?? Immer diese Objekte !!}
end;
WM_Command: case wParam of
IDOK: EndDialog(hWindow,1);
end{case wParam};
end{case Msg};
end;
{Flags für momentan angezeigte doppelte Höhen usw. setzen,
wichtig für eine korrekte Markierungsfunktion}
const
fdDblH=$40;
fdPrevDblH=$80;
procedure CheckVisibleDblHs(ShowDblH: Bool);
var
Line: Integer;
PDblH: Boolean;
begin
PDblH:=false;
for Line:=0 to 24 do begin
{Bits vorsorglich löschen}
VT.LineInfo[Line]:=VT.LineInfo[Line] and not (fdPrevDblH or fdDblH);
if ShowDblH then begin
if PDblH then begin
VT.LineInfo[Line]:=VT.LineInfo[Line] or fdPrevDblH;
PDblH:=false;
{egal, ob die aktuelle Zeile auch doppelt hohe Zeichen enthielt!}
end else if VT.LineInfo[Line] and fDblH <>0 then begin
if Line<>24 then VT.LineInfo[Line]:=VT.LineInfo[Line] or fdDblH;
PDblH:=true;
end;
end;
end;
end;
{ TVTWindow, a TWindow descendant }
const
DOSShowCmd:Integer=SW_Hide;
var
DirName: array[0..fsPathName] of Char; {Aktuelles Verzeichnis}
AFileName: array[byte] of Char;
const
Unzipper: array[0..127]of Char='pkunzip -o -j';
type
PVTWindow = ^TVTWindow;
TVTWindow = object(TWindow)
Bitmaps:array[1..2]of record
h:HBitmap;
valid:boolean;
end;
hCurArrow,hCurHand: hCursor; {Unsere 2 Mauspfeile}
{ IconImageValid: Boolean;}
sWidth,sHeight: Integer; {40 oder 41, 24 oder 25}
Mode: Longint;
CurBitmapIdx:integer; {Dieser schaltet hin und her (1 oder 2)}
MenuFlags:word; {hier sind die Flags wie QUIZ usw. drin}
MenuFont:word; {hier ist die Font-Nummer gespeichert}
Current:tIdx; {Aktuell angezeigte Seite/Unterseite}
History:tHistory; {GeschichtsObjekt}
{Suchen-Standard-Dialogbox}
HFind: HWnd;
FindReplace: TFindReplace; {So 'ne Struktur fürs CommDlg}
FindWhat: array[0..127]of char; {Suchstring}
IDFR: Word; {ID von Find/Replace}
SuchStart: TIdx; {Index, bei der die Suche begann}
{Gepackter Videotext}
TempFileName: PChar; {Zum Löschen einer evtl. temporären Datei}
SelectedRect: TRect; {der erste Punkt ist hierbei nicht unbedingt oben links}
SelectedRegion: HRgn; {So löst man das Markierungsproblem elegant!}
Margin: TMargin;
hStatic: HWnd;
hGray: HWnd;
hFwdBtn,hBackBtn: HWnd;
{ sfontw,sfonth:Integer; {Bildschirm-Fontgrößen}
constructor Init(ATitle: PChar);
destructor Done; virtual;
{ function GetClassName : PChar; virtual;}
procedure GetWindowClass(var WndClass: TWndClass); virtual;
procedure DefWndProc(var Msg: TMessage); virtual;
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure CMFileOpen(var Msg: TMessage); virtual cm_First+102;
procedure CMFileSave(var Msg: TMessage); virtual cm_First+104;
procedure CMSetUnzipper(var Msg: TMessage); virtual cm_First+2020;
procedure CMQuit(var Msg: TMessage); virtual cm_First+108;
procedure CMSDM(var Msg: TMessage); virtual cm_First+109;
{Oh, ich hasse Kapselklassen! Alles muss man 6* schreiben!}
procedure CMNextPage(var Msg: TMessage); virtual cm_First+301;
procedure CMPrevPage(var Msg: TMessage); virtual cm_First+302;
procedure CMNextSubp(var Msg: TMessage); virtual cm_First+303;
procedure CMPrevSubp(var Msg: TMessage); virtual cm_First+304;
procedure CMHomePage(var Msg: TMessage); virtual cm_First+305;
procedure CMCertainPage(var Msg: TMessage); virtual cm_First+306;
procedure CMNext(var Msg: TMessage); virtual cm_First+307;
procedure CMBack(var Msg: TMessage); virtual cm_First+308;
procedure CMFwd(var Msg: TMessage); virtual cm_First+309;
procedure IDNextPage(var Msg: TMessage); virtual ID_First+301;
procedure IDPrevPage(var Msg: TMessage); virtual ID_First+302;
procedure IDNext(var Msg: TMessage); virtual ID_First+303;
procedure IDPrev(var Msg: TMessage); virtual ID_First+304;
procedure IDBack(var Msg: TMessage); virtual ID_First+308;
procedure IDFwd(var Msg: TMessage); virtual ID_First+309;
procedure CMCopy(var Msg: TMessage); virtual cm_First+202;
procedure CMInfo(var Msg: TMessage); virtual cm_First+205;
procedure CMFind(var Msg: TMessage); virtual cm_First+203;
procedure CMFindNext(var Msg: TMessage); virtual cm_First+204;
procedure CMSetMargin(var Msg: TMessage); virtual cm_First+208;
procedure Suche; {Suchfunktion, benutzt FindReplace.Flags}
procedure CMQuiz(var Msg:TMessage); virtual cm_First+401;
procedure CMBlink(var Msg:TMessage); virtual cm_First+402;
procedure CMDblH(var Msg:TMessage); virtual cm_First+403;
procedure CMMix(var Msg:TMessage); virtual cm_First+404;
procedure CMInvers(var Msg:TMessage); virtual cm_First+405;
procedure CMS_W(var Msg:TMessage); virtual cm_First+406;
procedure CMDebug(var Msg:TMessage); virtual cm_First+407;
procedure CMRoll(var Msg:TMessage); virtual cm_First+408;
procedure CMSetDblSize(var Msg:TMessage); virtual cm_First+409;
procedure CMSet41(var Msg:TMessage); virtual cm_First+410;
procedure CMSet25(var Msg:TMessage); virtual cm_First+411;
procedure CMFontA(var Msg:TMessage); virtual cm_First+501; {auto}
procedure CMFontD(var Msg:TMessage); virtual cm_First+502; {deutsch}
procedure CMFontE(var Msg:TMessage); virtual cm_First+503; {engl.}
procedure CMFontW(var Msg:TMessage); virtual cm_First+504; {schwed./finn.}
procedure CMFontP(var Msg:TMessage); virtual cm_First+505; {poln.}
procedure CMFontT(var Msg:TMessage); virtual cm_First+506; {tschech./slowak.}
procedure CMFontI(var Msg:TMessage); virtual cm_First+507; {ital.}
procedure CMFontF(var Msg:TMessage); virtual cm_First+508; {frz./belg.}
procedure CMFontS(var Msg:TMessage); virtual cm_First+509; {span./port.}
procedure CMFontL(var Msg:TMessage); virtual cm_First+510; {dΣn./islΣnd.}
procedure CMFontU(var Msg:TMessage); virtual cm_First+511; {ungar.}
procedure CMFontR(var Msg:TMessage); virtual cm_First+512; {tⁿrk.}
procedure CMFontK(var Msg:TMessage); virtual cm_First+515; {kyrill.}
procedure CMFontB(var Msg:TMessage); virtual cm_First+516; {arab.}
procedure CMHelp(var Msg:TMessage); virtual cm_First+901; {Hilfe}
procedure CMAbout(var Msg:TMessage); virtual cm_First+999; {About-Box}
procedure FontFail; {Fehlermeldung: Font nicht da}
procedure WMGetMinMaxInfo(var Msg: TMessage); virtual wm_First + wm_GetMinMaxInfo;
procedure WMSysCommand(var Msg: TMessage); virtual wm_First + wm_SysCommand;
procedure WMMove(var Msg: TMessage); virtual WM_First + WM_Move;
procedure WMSize(var Msg: TMessage); virtual WM_First + WM_Size;
{ procedure AdjustScroller;}
function LoadVTFile(Name: PChar): Boolean;
{ function OpenDIB(var TheFile: File): Boolean;}
{ procedure GetBitmapData(var TheFile: File;
BitsHandle: THandle; BitsByteSize: Longint);}
procedure WMTimer(var Msg: TMessage); virtual wm_First+wm_Timer;
{ procedure WM_INITMENU(var Msg: TMessage); virtual wm_First+wm_INITMENU;}
procedure StartBlink;
procedure StopBlink;
procedure RemoveAnySelection;
procedure WMLButtonDown(var Msg: TMessage); virtual wm_First+WM_LBUTTONDOWN;
procedure WMRButtonDown(var Msg: TMessage); virtual wm_First+WM_RBUTTONDOWN;
procedure WMMouseMove(var Msg: TMessage); virtual WM_First+WM_MouseMove;
procedure WMLButtonUp(var Msg: TMessage); virtual WM_First+WM_LButtonUp;
procedure WMParentNotify(var Msg: TMessage); virtual WM_First+WM_ParentNotify;
procedure SetupWindow; virtual;
procedure WMUser88(var Msg: TMessage); virtual WM_First + WM_User+88;
{ procedure Destroy; virtual;}
function ToggleCheck(TheFlag,MenuItem:word):boolean; {liefert TRUE wenn Flag gesetzt wird}
function FontCheck(NewFont:word):integer; {liefert void}
procedure UpdateBitmaps;
procedure UpdateBitmap(BitmapNr:Byte);
{fⁿllt die beiden Bitmaps mit der aktuellen Seite mit den aktuellen Flags}
function MBox(StrTableNr:word;var Params;Stil:word):integer;
procedure Resize; {Fenstergroesze nach rechts unten aendern}
procedure RemoveTemporaryFile;{Falls vorhanden temporäre Datei löschen}
procedure CalcWindowSize(MFlags:Word; var P:TPoint); {Fenstergröße (nicht nur Client) berechnen}
procedure CalcSFontX;
end;
procedure TVTWindow.CalcSFontX;
begin
sfontw:=FONTW; if MenuFlags and fDblSize <>0 then sfontw:=2*FONTW;
sfonth:=FONTH; if MenuFlags and fDblSize <>0 then sfonth:=2*FONTH;
end;
procedure TVTWindow.CMQuit(var Msg: TMessage);
begin
CloseWindow;
end;
{procedure TVTWindow.WM_INITMENU(var Msg: TMessage);
begin
MessageBeep(MB_OK);
CheckMenuItem(Msg.WParam,SC_MOVE,MF_BYCOMMAND);
end;}
procedure TVTWindow.WMGetMinMaxInfo(var Msg: TMessage);
begin
with TMinMaxInfo(Pointer(Msg.LParam)^) do begin
ptMaxPosition.X:=Attr.X;
ptMaxPosition.Y:=Attr.Y; {Linke obere Ecke bleibt}
ptReserved.X:=Attr.X;
ptReserved.Y:=Attr.Y; {Linke obere Ecke bleibt}
CalcWindowSize(MenuFlags or fDblSize,ptMaxSize); {Größe wird hier vorgegeben}
end;
end;
procedure TVTWindow.WMMove(var Msg: TMessage);
var R: TRect;
begin
if not IsIconic(HWindow) then begin
GetWindowRect(HWindow,R);
Attr.X:=R.Left; {Attr's mitführen, auch wenn großgestellt!}
Attr.Y:=R.Top;
end {else inherited WMMove(Msg)};
end;
procedure TVTWindow.WMSize(var Msg: TMessage);
var R: TRect;
begin
inherited WMSize(Msg);
if not IsIconic(HWindow) then begin
GetClientRect(HWindow,R);
MoveWindow(hStatic,0,R.bottom-20,
CalculateWidth(MenuFlags or fPixels),20,true);
end;
end;
procedure TVTWindow.DefWndProc(var Msg: TMessage);
begin
if Msg.Message=IDFR then begin
{ MessageBeep(Word(-1));}
if FindReplace.Flags and FR_DialogTerm <>0 then begin
HFind:=0;
FindReplace.Flags:=FindReplace.Flags and not FR_DialogTerm;
end else begin
if FindReplace.Flags and FR_FindNext =0 then begin
Suchstart:=Current;
MessageBeep(Word(-1)); {Beep wenn Neue Suche}
end;
FindReplace.Flags:=FindReplace.Flags and not FR_FindNext;
Suche;
end;
end else inherited DefWndProc(Msg);
end;
procedure TVTWindow.WMSysCommand(var Msg: TMessage);
begin
case (Msg.wParam and $FFF0) of
SC_MAXIMIZE: begin
if MenuFlags and fDblSize =0 then ToggleCheck(fDblSize,409);
end;
SC_RESTORE: begin
if not IsIconic(HWindow) then
if MenuFlags and fDblSize <>0 then ToggleCheck(fDblSize,409);
end;
end;
inherited WMSysCommand(Msg);
end;
procedure TVTWindow.CMSDM(var Msg: TMessage);
begin
VTWApp.ExecDialog(New(PSDMDlg,Init(@self,'SDM')));
end;
procedure TVTWindow.CMHelp(var Msg:TMessage);
begin
MessageBox(hWindow,'Hilfe nicht verfügbar!','Pardon',MB_OK);
{ WinHelp(hWindow,'VTW.HLP',HELP_INDEX,0);}
end;
procedure TVTWindow.CMNextPage(var Msg: TMessage);
begin
if VT.SelectLoadPage(Current,ADDNEXTPAGE)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end;
end;
procedure TVTWindow.CMPrevPage(var Msg: TMessage);
begin
if VT.SelectLoadPage(Current,SUBPREVPAGE)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end;
end;
procedure TVTWindow.CMNextSubp(var Msg: TMessage);
begin
if VT.SelectLoadPage(Current,ADDNEXTSUB)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end;
end;
procedure TVTWindow.CMPrevSubp(var Msg: TMessage);
begin
if VT.SelectLoadPage(Current,SUBPREVSUB)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end;
end;
procedure TVTWindow.CMHomePage(var Msg: TMessage);
begin
if VT.SelectLoadPage(Current,HOMEPAGE)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end;
end;
procedure TVTWindow.CMCertainPage(var Msg: TMessage);
var
TempIdx: TIdx;
begin
TempIdx:=Current; {statische Variable; etwas russisch}
if DialogBoxParam(hInstance,'GOTO',hWindow,@GotoDlgProc,LongInt(@TempIdx))
=IDOK then begin
if VT.SelectLoadPage(TempIdx,NEXTSUB)<>$FFFF then begin
Current:=TempIdx; {rückschreiben}
History.Append(Current);
UpdateBitmaps;
end else begin
MBox(3,TempIdx.Page,MB_OK or MB_IconExclamation)
end;
end;
end;
procedure TVTWindow.CMNext(var Msg: TMessage);
begin
if VT.SelectLoadPage(Current,ADDNEXTSUBPAGE)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end;
end;
procedure TVTWindow.CMBack(var Msg: TMessage);
begin
if History.Back(Current) then begin
if VT.SelectLoadPage(Current,EQUALPAGE)<>$FFFF then begin
UpdateBitmaps
end else begin
{MBox}
end;
end;
end;
procedure TVTWindow.IDNextPage(var Msg: TMessage);
begin
CMNextPage(Msg);
end;
procedure TVTWindow.IDPrevPage(var Msg: TMessage);
begin
CMPrevPage(Msg);
end;
procedure TVTWindow.IDNext(var Msg: TMessage);
begin
CMNext(Msg);
end;
procedure TVTWindow.IDPrev(var Msg: TMessage);
begin
if VT.SelectLoadPage(Current,SUBPREVSUBPAGE)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end;
end;
procedure TVTWindow.IDBack(var Msg: TMessage);
begin
CMBack(Msg);
end;
procedure TVTWindow.IDFwd(var Msg: TMessage);
begin
CMFwd(Msg);
end;
procedure TVTWindow.WMRButtonDown(var Msg: TMessage);
begin CMBack(Msg); end;
procedure TVTWindow.CMFwd(var Msg: TMessage);
begin
if History.Fwd(Current) then begin
if VT.SelectLoadPage(Current,EQUALPAGE)<>$FFFF then begin
UpdateBitmaps
end else begin
{MBox}
end;
end;
end;
procedure TVTWindow.CMInfo(var Msg: TMessage);
begin
DialogBoxParam(hInstance,'INFO',hWindow,@InfoDlgProc,VT.Header.CBits);
end;
procedure SortRect(var R:TRect); forward;
procedure TVTWindow.CMCopy(var Msg: TMessage);
var
Puffer: array[0..1200]of Char;
HMem: THandle;
OldBitmap, HBM: HBitmap;
HilfDC, BMDC: HDC;
P: PChar;
R: TRect;
begin
CopyRect(R,SelectedRect); SortRect(R);
VT.MkText(Puffer,MenuFlags or fBlink,MenuFont,R);
HMem:=GlobalAlloc(GMEM_Share,StrLen(Puffer));
P:=GlobalLock(HMem);
StrCopy(P,Puffer);
GlobalUnlock(HMem);
HilfDC:=GetDC(HWindow);
BMDC:=CreateCompatibleDC(HilfDC);
HBM:=CreateCompatibleBitmap(HilfDC,41*FONTW,25*FONTH);
ReleaseDC(HWindow,HilfDC);
OldBitmap:=SelectObject(BMDC,HBM);
VT.MkBitmap(BMDC,MenuFlags or fBlink,MenuFont,R);
SelectObject(BMDC,OldBitmap);
DeleteDC(BMDC);
OpenClipboard(HWindow);
EmptyClipboard;
SetClipboardData(CF_Bitmap,HBM);
SetClipboardData(CF_Text,HMem);
CloseClipboard;
end;
procedure TVTWindow.CMFind(var Msg: TMessage);
begin
if HFind=0 then
HFind:=FindText(FindReplace)
else ShowWindow(HFind,SW_Restore);
Suchstart:=Current; {Kopieren}
end;
procedure TVTWindow.CMFindNext(var Msg: TMessage);
begin
Suche;
end;
procedure TVTWindow.CMSetMargin(var Msg: TMessage);
begin
DialogBoxParam(hInstance,'MARGIN',hWindow,@MarginDlgProc,LongInt(@Margin));
end;
function _Upcase:Char; assembler;
asm cmp al,'a'
jc @@e
cmp al,'z'
ja @@e
sub al,20h
@@e: end;
function StrIPos(S,SubS:PChar):PChar; assembler;
asm push ds
lds si,[S]
les di,[SubS]
@@o: mov al,es:[di]
or al,al
jz @@em {Substring leer: "Gefunden" melden}
call _UpCase
mov ah,al
cld
@@l: lodsb {AnsiNext}
or al,al
jz @@e1 {String zu Ende: abbrechen mit NIL}
call _UpCase
cmp al,ah
jne @@l
push si
push di
@@l1: inc di {AnsiNext}
mov al,es:[di]
or al,al
jz @@f {Substring zu Ende: Suche geschafft!}
call _UpCase
mov ah,al
lodsb
call _UpCase
cmp al,ah
jz @@l1 {Zeichen ungleich oder String zu Ende: hier abbrechen}
pop di
pop si
jmp @@o {AH neuladen}
@@f:
pop di
pop si
dec si {Gefunden, Zeiger 1 Zeichen zurück}
@@em: mov dx,ds
mov ax,si
jmp @@e
@@e1: cbw
cwd
@@e: pop ds
end;
procedure TVTWindow.Suche;
var
OldCursor: HCursor;
Puffer: array[0..1200]of Char;
R: TRect;
Richtung: TSearchMode;
SP: PChar;
label
l1;
begin
OldCursor:=SetCursor(LoadCursor(0,IDC_WAIT));
{ MessageBox(HWindow,FindWhat,'Suche jetzt:',0);}
SetRect(R,0,0,40,24);
Richtung:=ADDNEXTSUBPAGE;
if FindReplace.Flags and FR_Down <>0 then Richtung:=SUBPREVSUBPAGE;
repeat
if VT.SelectLoadPage(Current,Richtung)=$FFFF then break;
VT.MkText(Puffer,MenuFlags or fBlink,MenuFont,R);
if FindReplace.Flags and FR_MatchCase <>0
then SP:=StrPos(Puffer,FindWhat)
else SP:=StrIPos(Puffer,FindWhat);
if SP<>nil then begin
History.Append(Current);
UpdateBitmaps;
goto l1;
end;
until Suchstart.L=Current.L;
MessageBox(HWindow,'Suchbegriff nicht gefunden!',
'VTW',MB_OK or MB_IconAsterisk);
l1:
SetCursor(OldCursor);
end;
function TVTWindow.MBox(StrTableNr:word;var Params;Stil:word):integer;
var tmp,tmp2:array[0..255]of char;
p:PChar;
begin
p:=nil; {Standard-Header}
if LoadString(hInstance,StrTableNr,tmp,sizeof(tmp))>strlen(tmp) then
p:=strend(tmp)+1; {Zeiger hinter die Trenn-Null versetzen}
wvsprintf(tmp2,tmp,Params);
MBox:=MessageBox(HWindow,tmp2,p,Stil);
end;
procedure TVTWindow.CMAbout;
begin MBox(6,Mem[0:0],MB_OK OR MB_ICONEXCLAMATION); end;
procedure TVTWindow.StartBlink;
begin
if (MenuFlags and fBlink <>0) and VT.PageContain(8) then
if SetTimer(HWindow,12,1500,nil)=0 then begin
MBox(2,self,MB_OK);
end;
end;
procedure TVTWindow.StopBlink;
begin
KillTimer(HWindow,12);
if CurBitmapIdx=2 then begin
CurBitmapIdx:=1;
InvalidateRect(HWindow,nil,FALSE); {mit true wⁿrde es wei▀ aufflackern}
end;
end;
procedure TVTWindow.CMQuiz(var Msg:TMessage);
begin
ToggleCheck(fQuiz,401);
if VT.PageContain(24) then UpdateBitmaps; {Nur wenn Quiz-Zeichen enthalten}
end;
procedure TVTWindow.CMBlink(var Msg:TMessage);
begin
if ToggleCheck(fBlink,402) then StartBlink
else StopBlink;
end;
procedure TVTWindow.CMDblH(var Msg:TMessage);
begin
ToggleCheck(fDblH,403);
CheckVisibleDblHs(MenuFlags and fDblH <>0);
if VT.PageContain(13) then UpdateBitmaps; {Nur wenn Doppelte H÷he enthalten}
end;
procedure TVTWindow.CMMix(var Msg:TMessage);
begin
ToggleCheck(fMix,404);
if VT.Header.CBits and $60 =0 then UpdateBitmaps;
end;
procedure TVTWindow.CMInvers(var Msg:TMessage);
begin
ToggleCheck(fInvers,405);
UpdateBitmaps;
end;
procedure TVTWindow.CMS_W(var Msg:TMessage);
begin
MenuFlags:=MenuFlags xor fBunt;
ToggleCheck(fBunt,406); {Hier ist's intern andersherum}
MenuFlags:=MenuFlags xor fBunt;
UpdateBitmaps;
end;
procedure TVTWindow.CMDebug(var Msg:TMessage);
begin
ToggleCheck(fDebug,407);
UpdateBitmaps;
end;
procedure TVTWindow.CMRoll(var Msg:TMessage);
begin
ToggleCheck(fRoll,408);
{UpdateBitmaps;}
end;
function TVTWindow.ToggleCheck;
var Check: word;
begin
if MenuFlags and TheFlag <>0 then Check:=MF_BYCOMMAND or mf_unchecked
else Check:=mf_bycommand or mf_checked;
MenuFlags:=MenuFlags xor TheFlag;
CheckMenuItem(Attr.Menu,MenuItem,Check);
ToggleCheck:=MenuFlags and TheFlag <>0; {Rⁿckgabewert}
end;
procedure TVTWindow.CMFontA(var Msg:TMessage);
begin FontCheck(0); UpdateBitmaps; end;
procedure TVTWindow.CMFontD(var Msg:TMessage);
begin FontCheck(1); UpdateBitmaps; end;
procedure TVTWindow.CMFontE(var Msg:TMessage);
begin FontCheck(2); UpdateBitmaps; end;
procedure TVTWindow.CMFontW(var Msg:TMessage);
begin FontCheck(3); UpdateBitmaps; end;
procedure TVTWindow.CMFontP(var Msg:TMessage);
begin FontCheck(4); UpdateBitmaps; end;
procedure TVTWindow.CMFontT(var Msg:TMessage);
begin FontCheck(5); UpdateBitmaps; end;
procedure TVTWindow.CMFontI(var Msg:TMessage);
begin FontCheck(6); UpdateBitmaps; end;
procedure TVTWindow.CMFontF(var Msg:TMessage);
begin FontCheck(7); UpdateBitmaps; end;
procedure TVTWindow.CMFontS(var Msg:TMessage);
begin FontCheck(8); UpdateBitmaps; end;
procedure TVTWindow.CMFontL(var Msg:TMessage);
begin FontCheck(9); UpdateBitmaps; end;
procedure TVTWindow.CMFontU(var Msg:TMessage);
begin FontCheck(10); UpdateBitmaps; end;
procedure TVTWindow.CMFontR(var Msg:TMessage);
begin FontCheck(11); UpdateBitmaps; FontFail; end;
procedure TVTWindow.CMFontK(var Msg:TMessage);
begin FontCheck(14); UpdateBitmaps; end;
procedure TVTWindow.CMFontB(var Msg:TMessage);
begin FontCheck(15); UpdateBitmaps; FontFail; end;
function TVTWindow.FontCheck;
begin
CheckMenuItem(Attr.Menu,501+MenuFont,MF_BYCOMMAND or MF_UNCHECKED);
MenuFont:=NewFont;
CheckMenuItem(Attr.Menu,501+MenuFont,MF_BYCOMMAND or MF_CHECKED);
end;
procedure TVTWindow.FontFail;
begin
MBox(1,self,MB_OK);
end;
procedure TVTWindow.UpdateBitmaps;
begin
Bitmaps[1].valid:=false;
Bitmaps[2].valid:=false;
CurBitmapIdx:=1;
StopBlink;
CheckVisibleDblHs(MenuFlags and fDblH <>0);
EnableWindow(hBackBtn,History.CanBack);
EnableWindow(hFwdBtn,History.CanFwd);
VT.MkLinkList(hWindow,MenuFlags); {Neue Linkliste erzeugen (dauert nicht lange??)}
InvalidateRect(HWindow,nil,FALSE); {mit true wⁿrde es wei▀ aufflackern}
SetWindowText(hStatic,VT.AlterStr);
StartBlink;
end;
procedure TVTWindow.CalcWindowSize(MFlags:Word; var P: TPoint);
var
R: TRect;
begin
CalcSFontX; {Neue Bildschirmfontgrößen berechnen}
R.Left:=0; R.Top:=0;
R.Right:=CalculateWidth(MFlags or fPixels);
R.Bottom:=CalculateHeight(MFlags or fPixels);
AdjustWindowRect(R,Attr.Style,TRUE);
P.X:=R.Right-R.Left;
P.Y:=R.Bottom-R.Top+20+20; {Button- und Statuszeile}
end;
procedure TVTWindow.Resize; {Keine Übergabe der neuen Größen}
var
P: TPoint;
begin
CalcWindowSize(MenuFlags,P);
MoveWindow(HWindow,Attr.X,Attr.Y,P.X,P.Y,TRUE);
{mit Befehl zum Neuzeichnen}
end;
procedure TVTWindow.CMSet25;
begin
if ToggleCheck(f25,411) then begin
Bitmaps[1].valid:=false; Bitmaps[2].valid:=false;
end;
Resize;
end;
procedure TVTWindow.CMSet41;
begin
if ToggleCheck(f41,410) then begin
Bitmaps[1].valid:=false; Bitmaps[2].valid:=false;
end;
Resize;
end;
procedure TVTWindow.CMSetDblsize;
begin
if IsZoomed(HWindow) then
PostMessage(HWindow,WM_SYSCOMMAND,SC_RESTORE,0)
else
PostMessage(HWindow,WM_SYSCOMMAND,SC_ZOOM,0);
{ ToggleCheck(fDblSize,409);
Resize;}
end;
procedure TVTWindow.UpdateBitmap(BitmapNr:byte);
var DC,MemDC:HDC;
OldCursor:hCursor;
OldBitmap:hBitmap;
R: TRect; {noch Dummy}
begin
DC := GetDC(HWindow);
MemDC:= CreateCompatibleDC(DC);
ReleaseDC(HWindow, DC);
OldCursor := SetCursor(LoadCursor(0,IDC_WAIT)); {LoadCursor(HWindow,'CURSOR_1'))}
OldBitmap:= SelectObject(MemDC, Bitmaps[BitmapNr].h);
if BitmapNr=2 then
VT.MkBitmap(MemDC,MenuFlags and not fBlink,MenuFont,R)
else VT.MkBitmap(MemDC,MenuFlags or fBlink,MenuFont,R);
SelectObject(MemDC,OldBitmap);
DeleteDC(MemDC);
SetCursor(OldCursor);
Bitmaps[BitmapNr].valid:=TRUE;
end;
procedure TVTWApp.InitMainWindow;
begin
MainWindow := New(PVTWindow, Init(VTW_Name));
end;
constructor TVTWindow.Init(ATitle: PChar);
var
e,f,i,TheFlag:word;
DCHandle: HDC;
R:TRect;
begin
SDM:=false;
CurBitmapIdx:=0; {nichts anbrennen lassen!}
inherited Init(nil, ATitle);
MenuFlags:=fBunt;
MenuFont:=0; {Default Font}
SelectedRegion:=0; {nichts selektiert}
TempFileName:=nil; {Keine temporäre Datei zu löschen}
HFind:=0; {sonst gehen keine Hotkeys!!!}
Margin.left:=2;
Margin.right:=40;
Margin.enabled:=false; {Ränder festlegen}
Margin.StrichKiller:=true; {Strichkiller aktivieren}
Attr.Menu := LoadMenu(HInstance,MAKEINTRESOURCE(49));
{ Attr.ExStyle:=WS_EX_Transparent;}
e:=GetProfileInt(VTW_Name,'Flag',fDblH or fBlink or fBunt or f41) xor fBunt;
f:=GetProfileInt(VTW_Name,'Font',0);
TheFlag:=1;
for i:=401 to 411 do begin
if e and TheFlag <>0 then ToggleCheck(TheFlag,i); {MenⁿhΣkchen setzen}
TheFlag:=TheFlag shl 1; {naechstes Flag}
end;
FontCheck(f); {Font setzen wie letztens}
GetProfileString(VTW_Name,'LDir','',DirName,sizeof(DirName));
{NIL statt '' ist nicht erlaubt}
with Attr do begin
Style := Style and not ws_thickframe or CS_BYTEALIGNWINDOW;
X:=Integer(GetProfileInt(VTW_Name,'OrgX',64)); {aus den WIN.INI EintrΣgen}
Y:=Integer(GetProfileInt(VTW_Name,'OrgY',64));
CalcWindowSize(MenuFlags and not fDblSize,TPoint(Pointer(@W)^)); {W und H füllen}
end;
GetProfileString(VTW_Name,'Unzipper',Unzipper,Unzipper,sizeof(Unzipper));
if MenuFlags and fDblSize <>0 then CmdShow:=SW_ShowMaximized;
CalcSFontX; {Bildschirm-Fontgröße}
DCHandle := CreateDC('Display', nil, nil, nil);
Bitmaps[1].h:= CreateCompatibleBitmap(DCHandle,41*FONTW,25*FONTH);
Bitmaps[2].h:= CreateCompatibleBitmap(DCHandle,41*FONTW,25*FONTH);
if GetDeviceCaps(DCHandle, numColors) < 3 then Mode := notSrcCopy
else Mode := srcCopy; {Müßte auf Monochrom getestet werden!}
DeleteDC(DCHandle);
end;
function TVTWApp.ProcessAppMsg;
begin
if PVTWindow(MainWindow)^.HFind<>0 then
ProcessAppMsg:=IsDialogMessage(PVTWindow(MainWindow)^.HFind,Message)
{Klimmzug erforderlich, sonst gehen keine Tasten im Suchfenster}
else ProcessAppMsg:=inherited ProcessAppMsg(Message);
end;
procedure tVTWindow.SetupWindow;
var
Sysmenu:hMenu;
R: TRect;
begin
inherited SetupWindow;
hCurArrow:=LoadCursor(0,IDC_ARROW);
hCurHand:=LoadCursor(hInstance,'HAND');
Sysmenu:=GetSystemMenu(hWindow,FALSE);
{ if sysmenu=attr.menu then messagebeep(MB_OK);
AppendMenu(Sysmenu,MF_BYCOMMAND or MF_STRING,$E000,'Hallo');
CheckMenuItem(Sysmenu,SC_MOVE,MF_BYCOMMAND or MF_CHECKED);}
DeleteMenu(Sysmenu,SC_SIZE,MF_BYCOMMAND);
ModifyMenu(Sysmenu,SC_Zoom,MF_ByCommand,SC_Zoom,'Gro▀&bild');
{Die FindReplace-Struktur vorbelegen}
FillChar(FindReplace,sizeof(FindReplace),#0);
with FindReplace do begin
lStructSize:=sizeof(FindReplace);
hWndOwner:=HWindow;
{ Flags:=FR_Down or }
FindWhat[0]:=#0;
lpstrFindWhat:=FindWhat; {String-Zeiger festsetzen}
wFindWhatLen:=sizeof(FindWhat); {Länge übermitteln}
end;
IDFR:=RegisterWindowMessage('commdlg_FindReplace');
{ DeleteMenu(Sysmenu,SC_ZOOM,MF_BYCOMMAND);} {Ohne Menüpunkt geht's nicht?}
{ DrawMenuBar(hwindow);}
{ Attr.Menu:=Sysmenu;}
StartBlink;
{ SetRect(R,0,0,20,20);
CreateInvisible(HWindow,R,MakeLong($100,$100));}
hBackBtn:=CreateWindow('BUTTON','Zurⁿck',BS_PushButton or WS_Child or WS_Visible or WS_Disabled,
0,0,60,20,HWindow,308,HInstance,nil);
{ CreateWindow('BUTTON','S100',BS_PushButton or WS_Child or WS_Visible,
40,0,40,20,HWindow,305,HInstance,nil);}
CreateWindow('BUTTON','Seite-',BS_PushButton or WS_Child or WS_Visible,
60,0,50,20,HWindow,302,HInstance,nil);
CreateWindow('BUTTON','Unter-',BS_PushButton or WS_Child or WS_Visible,
110,0,50,20,HWindow,304,HInstance,nil);
CreateWindow('BUTTON','Unter+',BS_PushButton or WS_Child or WS_Visible,
160,0,50,20,HWindow,303,HInstance,nil);
CreateWindow('BUTTON','Seite+',BS_PushButton or WS_Child or WS_Visible,
210,0,50,20,HWindow,301,HInstance,nil);
{ CreateWindow('BUTTON','Mag+',BS_PushButton or WS_Child or WS_Visible,
250,0,40,20,HWindow,307,HInstance,nil);}
hFwdBtn:=CreateWindow('BUTTON','VorwΣrts',BS_PushButton or WS_Child or WS_Visible or WS_Disabled,
260,0,60,20,HWindow,309,HInstance,nil);
hStatic:=CreateWindow('STATIC','Statuszeile',WS_Child or WS_Visible or SS_Center,
0,CalculateHeight(MenuFlags or fPixels)+20,320,20,HWindow,709,HInstance,nil);
hGray:=CreateWindow('STATIC','',WS_Child or WS_Visible or SS_GrayRect,
320,0,660,20,HWindow,$FFFF,HInstance,nil);
PostMessage(HWindow,WM_User+88,0,0); {Fortfahren...}
end;
procedure tVTWindow.WMUser88(var Msg: TMessage);
begin
if lStrLen(CmdLine)>0 then begin
UpdateWindow(HWindow); {Erst mal darstellen}
if LoadVTFile(CmdLine)=false then {Datei im voraus laden}
MBox(5,CmdLine,mb_ok);
end;
UpdateBitmaps;
end;
procedure tVTWindow.WMTimer(var Msg: TMessage);
var NextTime:word;
begin
NextTime:=0;
if CurBitmapIdx=1 then begin
CurBitmapIdx:=2; NextTime:=500; {1/2 Sekunde AUS}
end else if CurBitmapIdx=2 then begin
CurBitmapIdx:=1; NextTime:=1500; {1 1/2 Sekunden EIN}
end;
if NextTime<>0 then begin
if not IsIconic(HWindow) then {Sonst flackert das Icon}
InvalidateRect(HWindow,nil,FALSE); {mit true wⁿrde es wei▀ aufflackern}
SetTimer(HWindow,12,NextTime,nil);
end;
end;
{Funktionen zur Markierungsverwaltung, mit Rundung}
{Ursprung der Ergebnisparameter an der linken oberen Ecke unterhalb der
Buttons}
procedure PointToRaster(var P:TPoint);
begin
P.X:=(P.X+sFontW div 2) div sFontW;
P.Y:=(P.Y-20) div sFontH;
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;
function CreateTRectRegion(var R:TRect; LeftMarg,RightMarg:Integer):HRgn;
{umschaltbar auf Markierungsform mit linkem und rechtem Rand,
Bedingung dafür ist, ob Left<=Right gilt.
Die Ränder sind "inklusive" gesehen, die Schreibrichtung hier VLNR.
Die Bezüge auf LineInfo beziehen sich auf momentan _sichtbare_ Statii}
var
R2: TRect;
Rgn1,Rgn2: HRgn; {Hilfsregion zum Zusammensetzen}
I,K: Integer; {Hilfs-Int für Zeilenhöhe}
label
L1;
begin
CopyRect(R2,R); {irgendein Heini hat CopyRect falsch deklariert}
if (LeftMarg<=RightMarg) and (R2.top<>R2.bottom) then begin
{So umsortieren, daß der 1. Punkt oben und der 2. Punkt unten ist}
if R2.top>R2.bottom then SetRect(R2,R2.right,R2.bottom,R2.left,R2.top);
{Koordinaten zur Erfassung doppelt hoher Buchstaben ausrichten}
if VT.LineInfo[R2.top] and fdPrevDblH <>0 then Dec(R2.top);
if VT.LineInfo[R2.bottom] and fdDblH <>0 then Inc(R2.bottom);
{Zeilenhöhen für 1. und letzte Zeile erfassen}
I:=1; if VT.LineInfo[R2.top] and fdDblH <>0 then I:=2;
K:=0; if VT.LineInfo[R2.bottom] and fdPrevDblH <>0 then K:=1;
{Test auf Anomalie (Mittelbereich hat negative Breite)}
if R2.top+I>R2.bottom-K then begin
SortRect(R2); {richtig sortieren}
goto L1; {weiter wie ohne Ränder}
end;
{Oberer Schwanz}
if R2.left<=RightMarg then begin
Rgn1:=CreateRectRgn(R2.left,R2.top,RightMarg+1,R2.top+I);
end else Rgn1:=0;
Inc(R2.top,I); {weiter 'runter}
{Unterer Schwanz}
if R2.right>LeftMarg then begin
Rgn2:=CreateRectRgn(LeftMarg,R2.bottom-K,R2.right,R2.bottom+1);
end else Rgn2:=0;
Dec(R2.bottom,K);
{Kombinieren zu Rgn1}
if Rgn2<>0 then begin
if Rgn1=0 then Rgn1:=Rgn2
else begin
CombineRgn(Rgn1,Rgn1,Rgn2,RGN_XOR);
DeleteObject(Rgn2);
end;
end;
{Mittelbereich}
if R2.top<R2.bottom then begin
Rgn2:=CreateRectRgn(LeftMarg,R2.top,RightMarg+1,R2.bottom);
end else Rgn2:=0;
{Kombinieren zu Rgn1}
if Rgn2<>0 then begin
if Rgn1=0 then Rgn1:=Rgn2
else begin
CombineRgn(Rgn1,Rgn1,Rgn2,RGN_XOR);
DeleteObject(Rgn2);
end;
end;
{Wert-Rückgabe}
CreateTRectRegion:=Rgn1;
end else begin
SortRect(R2);
{Nun Rechteck auf (mindestens) Buchstabenhöhe aufblasen}
if VT.LineInfo[R2.top] and fdPrevDblH <>0 then Dec(R2.top);
if VT.LineInfo[R2.bottom] and fdDblH <>0 then Inc(R2.bottom);
L1:
Inc(R2.bottom);
CreateTRectRegion:=CreateRectRgnIndirect(R2);
end;
end;
procedure TVTWindow.RemoveAnySelection;
var
DC:HDC;
begin
if SelectedRegion<>0 then begin
DC:=GetDC(HWindow);
SetMapMode(DC,MM_AnIsotropic);
SetViewportOrg(DC,0,20);
SetViewportExt(DC,sFontW,sFontH);
SetWindowExt(DC,1,1); {in Buchstaben vorgehen!}
InvertRgn(DC,SelectedRegion);
DeleteObject(SelectedRegion);
SelectedRegion:=0; {Nichts mehr selektiert}
ReleaseDC(HWindow,DC);
end;
end;
procedure TVTWindow.WMLButtonDown(var Msg: TMessage);
var
P1: TPoint absolute SelectedRect;
begin
RemoveAnySelection; {Selektion weg vom Bildschirm}
{ P1.X:=Msg.LParamLo div FONTW;
P1.Y:=Msg.LParamHi div FONTH;}
P1:=MakePoint(Msg.LParam);
PointToRaster(P1);
{if LineHidden then Dec(P1.Y)}
SelectedRect.right:=SelectedRect.left;
SelectedRect.bottom:=SelectedRect.top;
SetCapture(HWindow); {Mausereignisse GLOBAL abfangen}
SetFocus(HWindow); {vielleicht gehen dann die Hotkeys?}
end;
procedure TVTWindow.WMParentNotify(var Msg: TMessage);
begin
case Msg.wParam of
WM_LButtonDown, WM_RButtonDown, WM_MButtonDown:
SendMessage(hWindow,Msg.wParam,0,Msg.lParam);
end;
end;
procedure TVTWindow.WMMouseMove(var Msg: TMessage);
var
Pn:TPoint;
DC:HDC;
hReg:HRgn;
ml,mr: Integer; {Ränder}
{ function TestProc(Item:pRI):boolean; far;
begin
TestProc:=Contain(Item^.R,Pn);
end;}
begin
Pn:=MakePoint(Msg.LParam);
PointToRaster(Pn);
if Msg.WParam and MK_LBUTTON <>0 then begin
if (SelectedRect.right<>Pn.X) or (SelectedRect.bottom<>Pn.Y) then begin
ml:=Margin.left-1; mr:=Margin.right-1;
if not Margin.enabled then ml:=255;
SelectedRect.right:=Pn.X;
SelectedRect.bottom:=Pn.Y;
DC:=GetDC(HWindow);
SetMapMode(DC,MM_AnIsotropic);
SetViewportExt(DC,sfontw,sfonth);
SetViewportOrg(DC,0,20);
SetWindowExt(DC,1,1);
if SelectedRegion<>0 then begin
hReg:=CreateTRectRegion(SelectedRect,ml,mr);
CombineRgn(SelectedRegion,SelectedRegion,hReg,RGN_XOR);
InvertRgn(DC,SelectedRegion); {die Differenzmenge "umklappen"}
DeleteObject(SelectedRegion); {alte Selektierung weg!}
SelectedRegion:=hReg; {neue Region setzen}
end else begin
SelectedRegion:=CreateTRectRegion(SelectedRect,ml,mr);
InvertRgn(DC,SelectedRegion);
end;
ReleaseDC(HWindow,DC);
end;
end else begin {Linke Taste nicht gedrückt}
{ if VT.LinkList^.FirstThat(@TestProc)<>nil then
{ SetCursor(hCurHand) {Job erledigt, Rechteck gefunden}
{ else
{ SetCursor(hCurArrow); {Kein Rechteck gefunden}
end;
end;
procedure TVTWindow.WMLButtonUp(var Msg: TMessage);
var
Punkt:TPoint;
hChild: HWnd;
L: LongInt absolute Current;
{ RI:pRI;}
Result:Word;
Fill,Page:word; {ich hoffe so steht Result gleich richtig}
{ function TestProc(Item:pRI):boolean; far;
begin
TestProc:=Contain(Item^.R,Punkt);
end;}
begin
ReleaseCapture; {Globale Mausereignisse abschalten}
if SelectedRegion=0 then begin
Punkt:=MakePoint(Msg.LParam);
hChild:=ChildWindowFromPoint(hWindow,Punkt);
if (hChild<>0) and (hChild<>hWindow)
and (hChild<>hStatic) and (hChild<>hGray) then begin
L:=GetWindowLong(hChild,0); {gespeichertes Ziel}
{
RI:=pRI(VT.LinkList^.FirstThat(@TestProc));
if RI<>nil then begin
Current:=RI^.I; {Index so übernehmen}
if VT.SelectLoadPage(Current,EQUALPAGE)<>$FFFF then begin
History.Append(Current);
UpdateBitmaps;
end else begin
MBox(3,Current,MB_OK); {Seite nicht gefunden}
end;
{ MBox(4,Page,MB_OK)}
end;
end;
end;
procedure TVTWindow.GetWindowClass;
begin
inherited GetWindowClass(WndClass);
WndClass.hIcon := LoadIcon(HInstance,'MAIN');
WndClass.hbrBackground:=0;
{ WndClass.hCursor := 0; {Maus in Eigenregie verwalten}
end;
destructor TVTWindow.Done;
function WriteProfileInt(KeyName,Template:PChar;value:word):bool;
var s:array[0..127]of char;
begin
wvsprintf(s,Template,value); {je nach Wunsch}
WriteProfileInt:=WriteProfileString(VTW_Name,KeyName,s);
end;
begin
WinHelp(hWindow,'VTW.HLP',HELP_QUIT,0);
RemoveTemporaryFile;
WriteProfileInt('Flag','%#04X',MenuFlags);
WriteProfileInt('Font','%u',MenuFont);
WriteProfileString(VTW_Name,'LDir',DirName); {Fehlermeldungen bool vergessen}
WriteProfileInt('OrgX','%d',Word(Attr.X));
WriteProfileInt('OrgY','%d',Word(Attr.Y));
WriteProfileString(VTW_Name,'Unzipper',Unzipper);
SendMessage(HWND_BroadCast,WM_WinIniChange,0,LongInt(@VTW_Name));
StopBlink;
DestroyCursor(hCurHand);
if Bitmaps[1].h <> 0 then DeleteObject(Bitmaps[1].h);
if Bitmaps[2].h <> 0 then DeleteObject(Bitmaps[2].h);
{ DeleteObject(IconizedBits);}
inherited Done;
end;
const
ofn: TOpenFileName=(
lStructSize: sizeof(TOpenFileName);
hWndOwner: 0;
hInstance: 0;
lpstrFilter: 'Videotext-Dateien'#0'*.vt;*.mgz'#0+
'Komprimierter Videotext'#0'*.vt_;*.vtz;*.zip'#0+
'Alle Dateien'#0'*.*'#0;
lpstrCustomFilter: nil;
nMaxCustFilter: 0;
nFilterIndex: 0;
lpstrFile: AFileName;
nMaxFile: sizeof(AFileName);
lpstrFileTitle: nil;
nMaxFileTitle: 0;
lpstrInitialDir: DirName;
lpstrTitle: nil;
Flags: OFN_HideReadOnly or OFN_OverwritePrompt or OFN_FileMustExist;
nFileOffset: 0;
nFileExtension: 0;
lpstrDefExt: '.VT';
lCustData: 0;
lpfnHook: nil;
lpTemplateName: nil);
procedure TVTWindow.CMFileOpen(var Msg: TMessage);
var
Filter: array[byte]of Char;
begin
ofn.hWndOwner:=HWindow;
LoadString(HInstance,10,Filter,Sizeof(Filter));
ofn.lpstrFilter:=Filter;
AFileName[0]:=#0;
if GetOpenFileName(ofn) then begin
lStrCpyn(DirName,AFileName,ofn.nFileOffset-1); {Pfad ohne "\" sichern}
if LoadVTFile(AFileName) then begin
UpdateBitmaps;
end{ else MBox(5,AFileName,mb_ok)};
end;
end;
procedure TVTWindow.CMFileSave(var Msg: TMessage);
var
Filter,Title: array[0..255] of Char;
begin
ofn.hWndOwner:=HWindow;
LoadString(HInstance,11,Filter,sizeof(Filter));
ofn.lpstrFilter:=Filter;
{ nFilterIndex:=1; {damit korrekte Nummer hier zurückgegeben wird}
AFileName[0]:=#0;
LoadString(HInstance,12,Title,sizeof(Title));
ofn.lpstrTitle:=Title;
if GetSaveFileName(ofn) then begin
wvsprintf(Filter,'Nicht unterstⁿtzte Funktion %ld',ofn.nFilterIndex);
{Als Titel Nummer anzeigen (tmp)}
SetWindowText(hStatic,Filter);
end;
ofn.lpstrTitle:=nil;
end;
function ShortFileName(TheName:PChar; MaxLen:word):PChar;
{verkürzt den Dateinamen im Puffer durch Einfügen von ... im Pfad}
var
Len:word;
P:PChar;
begin
Len:=StrLen(TheName);
if Len>MaxLen then begin
P:=StrScan(TheName,'\');
if P=nil then begin
P:=StrScan(TheName,':');
if P=nil then P:=TheName+2 {vorn 3 Zeichen}
end;
StrMove(StrECopy(P+1,'...'),P+Len-MaxLen+4,MaxLen-4);
end;
ShortFileName:=TheName; {Pointer durchreichen}
end;
function OpenZipFile(FileName:PChar; OpenMode:Integer; Wnd:HWnd;
var fh:HFile; var TempFile:PChar):Integer;
{weitere Parameter: Unzip-Fenstertitel, Name oder Nummer der Auspack-Datei..}
{Rückgaben:
0: alles OK, Datei ist unkomprimiert
>0: alles OK, Datei war komprimiert (Nummer=Auspack-Routine EXP/ZIP/ARJ/...)
<0: Fehler beim Öffnen oder Auspacken:
-1: ...beim Öffnen der Ursprungsdatei
-2: ...beim Auswerten der Dateiinformationen
-3: ...beim Kreieren der .PIF-Datei
-4: ...beim Starten des Entpackers
-5: ...beim Öffnen der ausgepackten Datei}
{Mögliches Problem: Codeseiten - es fehlt AnsiToOem() und umgekehrt}
const
ZipSign=$4B50; {"PK"}
ExpSign=$5A53; {"SZ"}
var
f: HFile;
w:Word;
PFile,TFile,CmdLine: array[0..255]of Char;
SP,EFile: PChar;
APif:TPif;
begin
TempFile:=nil;
f:=_lopen(FileName,OpenMode);
OpenZipFile:=-1; {Fehler beim ersten Öffnen}
if f=HFILE_Error then exit;
if _lread(f,PChar(@w),2)=2 then begin;
case w of
ExpSign: begin
GetTempFileName(#0,'DKZ',0,TFile); {Künftiger Ziel-Dateiname}
_llseek(f,0,0); {Quelldatei schon offen}
fh:=_lcreat(TFile,0); {Zieldatei}
if fh=HFILE_Error then exit;
if LZCopy(f,fh)<0 then exit; {Auspacken}
_lclose(f);
OpenZipFile:=1; {Auspacken mit EXPAND OK}
TempFile:=StrNew(TFile);
_llseek(fh,0,0); {"Zurückspulen"}
exit;
end;
ZipSign: begin
OpenZipFile:=-2;
GetTempFileName(#0,'DKZ',0,PFile);
_ldelete(PFile); {Windows ist schon mächtig komisch!}
lStrCpy(GetFileNameExt(PFile),'.PIF');{PIF-Dateiname im TEMP-Vrz.}
EFile:=GetFileNamePtr(PFile); {Dateiname adressieren}
lStrCpy(CmdLine,PFile); {Erstes Element der Kommandozeile}
{Name der ersten Datei extrahieren und an TEMP-Pfad anhängen}
_llseek(f,$1A,0); {_llseek macht niemals Fehler!}
if _lread(f,PChar(@w),2)<>2 then exit;{Name-Länge}
if w>255 then exit; {Notbremse!}
_llseek(f,$1E,0);
if _lread(f,TFile,w)<>w then exit; {Name selbst}
TFile[w]:=#0; {nullterminieren}
_lclose(f); {fertig mit Auslesen}
{Kommandozeile für Unzipper zusammenstellen}
OpenZipFile:=-3;
lStrCat(lStrCat(CmdLine,' /C '),Unzipper);
SP:=StrEnd(CmdLine);
SP^:=' '; Inc(SP); {trennt Optionen vom .ZIP-File}
SP:=StrEnd(FileExpand(SP,FileName));{ZIP-Pfad+Dateiname+Ext}
SP^:=' '; Inc(SP);
lStrCpy(SP,TFile); {Dateiname aus .ZIP-Datei}
{PIF-Datei kreieren}
SP:=nil;
if ((EFile-1)^='\') then begin
SP:=EFile-1; {Backslash wegpatchen,}
if (SP-1)^<>':' then SP^:=#0; {Pfad benötigt}
end;
CreatePif(MakeIntResource(26),nil,nil,PFile,APif);
if SP<>nil then SP^:='\'; {Backslash wieder zurückpatchen}
f:=_lcreat(PFile,0); {PIF-Datei kreieren}
if f=HFILE_Error then exit;
if _lwrite(f,PChar(@APIF),sizeof(APIF))<>sizeof(APIF) then exit;
_lclose(f);
{Auspacken starten}
OpenZipFile:=-4;
if ExecAndWait(CmdLine,DOSShowCmd,Wnd)>$4000 then exit;
_ldelete(PFile);
{Ergebnisdatei öffnen und fürs Löschen vorbereiten}
OpenZipFile:=-5;
lStrCpy(EFile,TFile); {Temp-Pfad plus ausgepackte Datei}
f:=_lopen(PFile,OpenMode);
if f=HFILE_Error then exit;
OpenZipFile:=2;
fh:=f;
TempFile:=StrNew(PFile); {auf dem Heap}
exit;
end;
end{case};
end;
_llseek(f,0,0);
fh:=f;
OpenZipFile:=0; {Nicht ausgepackt}
end;
function CloseZipFile(f:HFile; TempFile:PChar):Integer;
begin
CloseZipFile:=_lclose(f);
if TempFile<>nil then begin
_ldelete(TempFile);
StrDispose(TempFile);
end;
end;
function SetWaitCursor: HCursor;
begin
ShowCursor(true);
SetWaitCursor:=SetCursor(LoadCursor(0,IDC_Wait));
end;
procedure RemoveWaitCursor(OldCursor: HCursor);
begin
SetCursor(OldCursor);
ShowCursor(false);
end;
procedure TVTWindow.RemoveTemporaryFile;
begin
if TempFileName<>nil then begin
_ldelete(TempFileName);
StrDispose(TempFileName);
TempFileName:=nil; {Gelöscht markieren}
end;
end;
function TVTWindow.LoadVTFile(Name: PChar): Boolean;
label
LoadFail;
var
OldCursor:HCursor;
CatBuf,PBuf: array[byte]of Char; {Puffer "kurzer" Dateiname}
SomeSP: array[0..1]of PChar; {für WVSPRINTF}
F: HFile;
TempFile,LoadFile:PChar;
begin
OldCursor:=SetWaitCursor;
SetWindowText(hStatic,'Lade bzw. packe Datei aus...');
UpdateWindow(hStatic);
LoadVTFile:=TRUE;
if OpenZipFile(Name,0,HWindow,F,TempFile)<0 then goto LoadFail;
_lclose(F);
LoadFile:=Name;
if TempFile<>nil then begin
LoadFile:=TempFile;
end;
SetWindowText(hStatic,'Erstelle Index...');
UpdateWindow(hStatic);
if VT.LoadFile(LoadFile)<>0 then goto LoadFail;
RemoveTemporaryFile; {Alte Datei löschen!}
TempFileName:=TempFile; {Neu setzen}
lStrCpy(CatBuf,Name);
AnsiLower(ShortFileName(CatBuf,20));
SomeSP[0]:=VTW_Name;
SomeSP[1]:=CatBuf;
wvsprintf(PBuf,'%s: %s',SomeSP);
{AnsiLower macht nur "Name" zu Kleinbuchstaben!}
SetWindowText(HWindow,PBuf);
History.Init;
VT.SelectLoadPage(Current,HOMEPAGE);
SetWindowText(hStatic,VT.AlterStr); {Alter der Seite anzeigen}
History.Append(Current);
RemoveWaitCursor(OldCursor);
exit;
LoadFail:
SetWindowText(hStatic,'Fehler beim ╓ffnen!');
LoadVTFile := False;
RemoveWaitCursor(OldCursor);
end;
procedure TVTWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
dc:HDC;
OldBitmap:HBitmap;
R:TRect;
BitmapDesc: TBitmap;
begin
if CurBitmapIdx>0 then begin
with Bitmaps[CurBitmapIdx] do begin
if valid=FALSE then begin
UpdateBitmap(CurBitmapIdx);
end;
GetClientRect(HWindow,R);
DC:=CreateCompatibleDC(PaintDC); {Ein gleichartiges DC besorgen}
OldBitmap:=SelectObject(DC,h); {unser Bitmap dranhΣngen}
GetObject(h,sizeof(BitmapDesc),@BitmapDesc);
SetMapMode(PaintDC,MM_AnIsotropic);
SetViewportOrg(PaintDC,0,20);
SetViewportExt(PaintDC,sFontW,sFontH);
SetWindowExt(PaintDC,FONTW,FONTH); {in Buchstaben vorgehen!}
BitBlt(PaintDC,0,0,41*FONTW,25*FONTH,DC,0,0,Mode);
SetWindowExt(PaintDC,1,1); {in Buchstaben vorgehen!}
if SelectedRegion<>0 then InvertRgn(PaintDC,SelectedRegion);
SelectObject(DC,OldBitmap);
DeleteDC(DC);
end;
end;
end;
function ZipDlgProc(hWindow:HWnd; Msg,wParam:Word; lParam: LongInt): Bool; export;
begin
ZipDlgProc:=false;
case Msg of
WM_InitDialog: begin
SetDlgItemText(hWindow,101,Unzipper);
ZipDlgProc:=true; {?? Immer diese Objekte !!}
end;
WM_Command: case wParam of
IDOK: begin
GetDlgItemText(hWindow,101,Unzipper,sizeof(Unzipper));
EndDialog(hWindow,1);
end;
IDCancel: EndDialog(hWindow,0);
{ IDHelp: WinHelp(hWindow,VTW_HELP,HELP_Context,2020);}
end;
end;
end;
procedure TVTWindow.CMSetUnzipper(var Msg: TMessage);
begin
DialogBoxParam(Seg(HInstance),'ZIP',HWindow,@ZIPDlgProc,0);
end;
function Param0: PChar; assembler;
{liefert eigenen Programmnamen, besser als GetArgStr}
asm call GetDosEnvironment
mov es,dx
mov di,ax
xor ax,ax
cld
jmp @@2 ;{falls ENV leer! - könnt ja sein...}
@@1: scasb
jnz @@1
@@2: scasb
jnz @@1
inc ax ;{ax=1}
scasw
jnz @@err
mov dx,es
mov ax,di
jmp @@e
@@err:
dec ax
cwd ;{NIL liefern}
@@e:
end;
{Neuen Menüpunkt "Prozeß abspalten" hinzufügen:
CM_Spawn: WinExec(Param0,SW_Show);}
begin
Register;
VTWApp.Init(VTW_Name);
VTWApp.Run;
VTWApp.Done;
end.
| Detected encoding: OEM (CP437) | 1
|
|
|