{$A+,B-,D+,F-,G+,I-,K-,L+,N-,P-,Q-,R-,S-,T-,V+,W-,X+,Y+}
{$M $3000,4096}
program fwd; {TCP-Tunnel}
uses WinProcs, WinTypes, Win31, WinDos, Strings, WUtils, WinSock;
{$R fwd}
{$D TCP-Tunnel 0.4 (06/04)}
{06/04: Anpassung an Win32-kompatible WinSock.PAS}
const
AppName: array[0..10]of Char='TCP Tunnel';
HelpFileName: array[0..7]of Char='FWD.HLP';
const
WM_ContinueInit=WM_User+10;
WM_NotifyAccept=WM_User+11;
WM_NotifyGetHostByAddr=WM_User+13;
WM_NotifyTilo =WM_User+$1100;
type
TCon=record
accport:Word; {in Host-Byte-Ordnung}
conserv:PChar;
conport:Word;
sock:TSocket; {Accept-Socket}
inaddr:LongInt; {Ziel-Internetadresse}
timeout:LongInt; {(nicht ständig aufs neue auflösen)}
end;
var
Wnd: HWnd; {Global ist besser im Zugriff!}
Con:array[0..15]of TCon; {Statisches Array (oops!)}
ConFill: Integer; {Füllstand}
const
StartupOK:Boolean=false;
LVerbose:Integer=4; {je kleiner desto mehr Output; 4=nur Errors}
{****** Attach-"Objekt" ******}
{dient zur beliebigen Zuordnung eines 32-bit-Wertes zu einem anderen
32-bit-Wert}
procedure AttInit; external;
{function AttPut(H,P:LongInt):Integer; external;}
function AttPutWW(WH,WL:Word;P:LongInt):Integer; external;
{function AttGet(H:LongInt):LongInt; external;}
function AttGetWW(WH,WL:Word):LongInt; external;
function AttIdxGet(I:Integer):LongInt; external;
{function AttGetRev(P:LongInt):LongInt; external;
function AttDel(H:LongInt):LongInt; external;}
function AttDelWW(WH,WL:Word):LongInt; external;
function AttIdxDel(I:Integer):LongInt; external;
{function AttIdx(H:LongInt):Integer; external;
function AttIdxWW(WH,WL:Word):Integer; external;}
{$L FWD}
{****** Attach-"Objekt" Ende ******}
procedure ChangeSysMenu;
var
SysMenu: HMenu;
S:array[0..31] of Char;
begin
SysMenu:=GetSystemMenu(Wnd,false); {Systemmenü-Handle}
{ DeleteMenu(SysMenu,SC_Maximize,MF_ByCommand);
DeleteMenu(SysMenu,SC_Size,MF_ByCommand);}
LoadString(Seg(HInstance),1,S,sizeof(S));
InsertMenu(SysMenu,0,MF_ByPosition or MF_String,22,S);
LoadString(Seg(HInstance),2,S,sizeof(S));
InsertMenu(SysMenu,1,MF_ByPosition or MF_String,23,S);
LoadString(Seg(HInstance),3,S,sizeof(S));
InsertMenu(SysMenu,2,MF_ByPosition or MF_String,24,S);
InsertMenu(SysMenu,3,MF_ByPosition or MF_Separator,0,nil);
end;
const
MEMDEPTH=10;
var
SM:array[0..MEMDEPTH-1]of PChar; {String-Speicher im Rundumlauf}
SMIDX:Integer;
procedure AddListLine(LInfo:Integer;SP,P:PChar);
var
S1,S2:array[0..255]of Char;
I: Integer;
SPP: ^PChar;
begin
if LVerbose=5 then exit;
if PtrRec(SP).Sel=0 then begin
LoadString(Seg(HInstance),PtrRec(SP).Ofs,S1,sizeof(S1));
SP:=S1;
end;
wvsprintf(S2,SP,P);
if LInfo>=LVerbose then begin {History ausgeben!}
for I:=1 to MEMDEPTH do begin
SPP:=@SM[SMIdx];
if SPP^<>nil then begin
SendDlgItemMsgP(Wnd,13,LB_AddString,0,SPP^);
StrDispose(SPP^); {nunmehr löschen (schon ausgegeben)}
SPP^:=nil; {gelöscht markieren}
end;
SMIdx:=(SMIdx+1) mod MEMDEPTH; {nächster String}
end; {bis Puffer komplett leer}
SendDlgItemMessage(Wnd,13,LB_SetTopIndex,
Word(SendDlgItemMsgP(Wnd,13,LB_AddString,0,@S2)),0);
end else begin
SPP:=@SM[SMIdx];
if SPP^<>nil then StrDispose(SPP^); {String vergessen, sofern vorhanden}
SPP^:=StrNew(S2); {Neuen String eintragen}
SMIdx:=(SMIdx+1) mod MEMDEPTH; {zeigt wieder auf ältesten String}
end;
end;
procedure ListError(SP:PChar);
var
S:array[0..255]of Char;
begin
if LVerbose=5 then exit;
wvsprintf(S,'E%%d: %s()',SP);
AddListLine(4,S,PChar(WSAGetLastError));
end;
function ScanLine(SP:PChar; var Con:TCon):Boolean;
{nimmt eine Zeile aus WIN.INI auseinander}
var
SP2:PChar;
I:Integer;
begin
ScanLine:=false;
SP2:=StrScan(SP,' ');
if SP2=nil then exit; {Fehler: Leerzeichen fehlt!}
SP2^:=#0;
Val(SP,Con.accport,I);
if I<>0 then exit; {Zahlenfehler}
Con.conport:=Con.accport; {kopieren}
Inc(SP2);
SP:=StrRScan(SP2,':');
if SP<>nil then begin
SP^:=#0; {terminieren}
Inc(SP);
Val(SP,Con.conport,I);
if I<>0 then exit; {Zahlenfehler}
end;
Con.conserv:=StrNew(SP2); {String einsetzen}
ScanLine:=true;
end;
procedure LoadConfig;
{Konfigurationszeilen in WIN.INI: <beliebig>=<accport> <conserv[:conport]>}
{später neu: <accport>=<conserv[:conport]>}
var
S,S2:array[0..255]of Char;
SP,SP2:PChar;
I:Integer;
begin
GetProfileString(AppName,nil,'',S,sizeof(S)); {linksseitige Einträge}
SP:=@S;
ConFill:=0;
FillChar(Con,sizeof(Con),0);
while (SP^<>#0) and (ConFill<=High(Con)) do begin
GetProfileString(AppName,SP,'',S2,sizeof(S2)); {rechtsseitig}
if ScanLine(S2,Con[ConFill]) then begin
Inc(ConFill);
end;
SP:=StrEnd(SP)+1;
end;
end;
const
Connections:Integer=0;
procedure ShowConnections;
var
vsrec:record
sp:PChar;
i:Integer;
end;
S:array[0..255]of Char;
begin
if LVerbose=5 then exit;
if Connections=0 then SetWindowText(Wnd,StdMBoxTitle)
else begin
vsrec.sp:=StdMBoxTitle;
vsrec.i:=Connections;
wvsprintf(S,'%s [%d]',vsrec);
SetWindowText(Wnd,S);
end;
end;
const
Pakete:LongInt=0;
procedure ShowPakete;
var
S:array[0..15]of Char;
begin
wvsprintf(S,'%lu',Pakete);
SetDlgItemText(Wnd,17,S);
end;
procedure SplitCmdLine;
var
S: array[byte]of Char;
I,J: Integer;
W:Word;
begin
for I:=1 to GetArgCount do begin
GetArgStr(S,I,sizeof(S)-1);
if S[0] in ['/','-'] then begin
if lStrCmpi(S+1,'title')=0 then begin
Inc(I);
GetArgStr(S,I,sizeof(S)-1);
StdMBoxTitle:=StrNew(S);
SetWindowText(Wnd,S);
end else if lStrCmpi(S+1,'hidden')=0 then begin
CmdShow:=SW_Hide;
end else if lStrCmpi(S+1,'verbose')=0 then begin
LVerbose:=1;
CheckDlgButton(Wnd,12,1);
end else begin
MBox1(Wnd,11,MB_OK,S);
end;
end else begin
MBox1(Wnd,11,MB_OK,S);
end;
end{for};
end;
const
BUFSIZE=4096;
type
PTransferBlock=^TTransferBlock;
TTransferBlock=record
sockfrom, sockto: TSocket;
IdxFrom: Word; {Index des FROM-Sockets, nicht genutzt}
flags: Word;
{Bit 0: FD_Close für SockFrom eingetroffen
Bit 1: CloseSocket() für sockfrom gerufen
Bit 2: Puffer voll (bei gleichen Indizes)
Bit 3: Cleanup-Phase(??)
Bit 4: 2. Kanal OK?
Bit 5: 1. Close eingetroffen
Bit 6: Connected
Bit 15: Speicher freigegeben}
(*
0: (TiloSock,ProxySock:TSocket;
TiloIdx,ProxyIdx:Integer; {Message-Offsets}
Flags:Word); {Bit 2(voll) 3(will schließen) 4(2kanal)}
{5: 1. Close eingetroffen, 6: CONNECTed}
1: (Sock:array[Bool]of TSocket;
Idx:array[Bool]of Integer;
BFlag:array[Bool]of Byte;
SockForFree:TSocket; {zum Vormerken}
*)
readidx,writeidx:Integer;
Buffer: array[0..BUFSIZE-1]of Char;
end;
procedure ReConnect(var Con:TCon);
{füllt die Con-Struktur mit dem Socket und der Internet-Adresse auf}
var
sa:TsockAddrIn;
he:PHostEnt;
se:PServEnt;
S: array[0..255] of Char;
SI: array[0..7] of Char;
vsrec: record
W0: Word;
SP0,SP1,SP2: PChar;
W1: Word;
end;
begin
{Evtl. vorhandene Socket-Verbindung auflösen}
if Con.Sock>0 then CloseSocket(Con.Sock);
{Accept-Socket erstellen}
Con.Sock:=Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if Con.Sock=-1 then ListError('socket');
FillChar(sa,sizeof(sa),0);
sa.sin_family:=PF_INET;
sa.sin_port:=htons(Con.accport);
if Bind(Con.Sock,sa,sizeof(sa))<>0 then ListError('bind');
if Listen(Con.Sock,5)<>0 then ListError('listen');
if WSAAsyncSelect(Con.Sock,Wnd,WM_NotifyAccept,FD_Accept)<>0
then ListError('WSAAsyncSelect');
{Internet-Adresse des Zielrechners ermitteln}
Con.inaddr:=inet_addr(Con.conserv);
if Con.inaddr=INADDR_NONE then begin
he:=GetHostByName(Con.conserv); {hier:synchron, da zum Programmstart}
if he<>nil then Con.inaddr:=PLongInt(he^.h_addr_list^)^;
end;
if (Con.inaddr<>INADDR_NONE) then begin
se:=GetServByPort(Swap(Con.conport),nil);
vsrec.W0:=Con.accport;
vsrec.SP0:=Con.conserv;
if se<>nil then vsrec.SP1:=se^.s_name else begin
wvsprintf(SI,'%d',Con.conport);
vsrec.sp1:=SI;
end;
vsrec.SP2:=inet_ntoa(Con.inaddr);
vsrec.W1:=Con.conport;
wvsprintf(S,'OK: %4u -> %s:%s (%s:%u)',vsrec);
AddListLine(4,S,nil);
end;
if not AttPutWW(3,Con.Sock,LongInt(@Con))>=0 then RunError(220);
{Verknüpfung merken}
end;
function ReadBuf(var TB:TTransferBlock):Boolean;
{2 Mögliche Return-Ursachen: *Puffer voll (TRUE), *Socket leer (FALSE)}
var
i,k:Integer;
begin
ReadBuf:=false; {Annahme: Socket leer}
with TB do repeat
k:=ReadIdx-WriteIdx; {Platz im Puffer}
if (k<0) {Wrap Around}
or (k=0) and (Flags and 4 =0) {Sonderfall gleiche Indizes}
then k:=BUFSIZE-WriteIdx; {Platz bis hinten nehmen}
i:=k; if k=0 then break; {Kein Platz im Puffer!}
i:=Recv(TB.SockFrom,Buffer[WriteIdx],k,0); {Leseversuch}
if i<=0 then exit; {Fehler oder 0 Bytes? - Raus!}
WriteIdx:=(WriteIdx+i) mod BUFSIZE; {Neuer Schreib-Index}
if WriteIdx=ReadIdx then Flags:=Flags or 4; {VOLL setzen}
until false; {bis Puffer voll oder Socket leer}
ReadBuf:=true; {Puffer voll}
end;
function WriteBuf(var TB:TTransferBlock):Boolean;
{2 Mögliche Returncodes: *Puffer leer (TRUE), *Socket voll (FALSE)}
var
i,k:Integer;
begin
WriteBuf:=false;
with TB do repeat
k:=WriteIdx-ReadIdx; {Daten im Puffer}
if (k<0) {Wrap Around}
or (k=0) and (Flags and 4 <>0) {Sonderfall gleiche Indizes}
then k:=BUFSIZE-ReadIdx; {Platz bis hinten nehmen}
i:=k; if k=0 then break; {Keine Daten im Puffer!}
i:=Send(TB.SockTo,Buffer[ReadIdx],k,0); {Schreibversuch}
if i<=0 then exit; {Fehler oder 0 Bytes? - Raus!}
ReadIdx:=(ReadIdx+i) mod BUFSIZE; {Neuer Lese-Index}
Flags:=Flags and not 4; {VOLL löschen}
until false;
WriteBuf:=true;
end;
function GetReadBytes(S:TSocket):Integer;
var
L:LongInt;
begin
if ioctlsocket(S,FIONREAD,L)<>0 then begin
ListError('ioctlsocket');
GetReadBytes:=0;
exit;
end;
if L<>0 then AddListLine(3-Word(L<>0),'I IOCTL: %ld Bytes',PChar(L));
GetReadBytes:=L;
end;
function IsBadTbPtr(TBP:PTransferBlock;Sock:TSocket):Boolean;
begin
if (TBP=nil)
or IsBadWritePtr(TBP,sizeof(TTransferBlock))
or (TBP^.sockfrom<>Sock)
or (TBP^.flags and $8000 <>0)
then begin
AddListLine(4,'E Ungueltiger Zeiger Socket %d',Ptr(0,Sock));
IsBadTbPtr:=true;
exit;
end;
IsBadTbPtr:=false;
end;
function CheckDispose(TBP: PTransferBlock):TSocket;
{liefert sockfrom bei Nicht-Dispose, 0 bei Dispose. Dispose erfolgt,
wenn sockfrom CloseSocket() aufgerufen UND FD_Close erhalten hat.}
begin
with TBP^ do begin
CheckDispose:=sockfrom;
if flags and 3 =3 then begin
AttDelWW(0,sockfrom);
flags:=flags or $8000; {Gelöscht markieren}
AddListLine(1,'Dispose TBP [%d,%d]',Ptr(sockto,sockfrom));
Dispose(TBP);
CheckDispose:=0;
end;
end;
end;
const
FD_CloseLater=$5555;
procedure Transfer(Sock:TSocket; Action,ErrFlag:Word);
{"Aktion" (FD_xxx) auf Socket "Sock" ausführen}
var
BO:Boolean;
TBP,TBP2: PTransferBlock;
Sock2: TSocket;
procedure PutMsg(MsgName:PChar);
var
S: array[0..63] of Char;
begin
if ErrFlag<>0 then ListError(MsgName);
lstrcpy(S,MsgName);
lstrcat(S,' %d [%d]');
AddListLine(1,S,Ptr(Sock2,Sock));
end;
begin
Inc(Pakete); if LVerbose<=2 then ShowPakete;
TBP:=Pointer(AttGetWW(0,Sock));
if IsBadTbPtr(TBP,Sock) then exit;
with TBP^ do begin
TBP2:=nil;
Sock2:=sockto;
if Sock2<>0 then begin
TBP2:=Pointer(AttGetWW(0,Sock2));
if IsBadTbPtr(TBP2,Sock2) then exit;
end;
case Action of
FD_Connect: begin {nur bei ProxySock}
PutMsg('FD_Connect');
Inc(Connections); ShowConnections;
flags:=flags or $50; {Connected! (2Kanal)-Bit}
end;
FD_Close: begin
PutMsg('FD_Close');
if flags and 1 <>0
then AddListLine(2,'i Zweites FD_Close %d [%d]',Ptr(sockto,Sock));
flags:=flags or 1; {FD_CLOSE sockfrom}
if Sock2<>0 then begin
{ WSAAsyncSelect(Sock2,Wnd,WM_NotifyTilo,FD_Read or FD_Write);}
{FD_Close kommt für zweiten Socket nur, wenn schon in Warteschlange}
TBP2^.flags:=TBP2^.flags or 5; {Companion FD_Close sockto}
end;
{ Sock:=CheckDispose(TBP);}
if Sock<>0 then begin
{if SetTimer(Wnd,Sock,1000,nil)=0
then} PostMessage(Wnd,WM_NotifyTilo,Sock,FD_CloseLater);
end else begin
if Sock2<>0 then begin
TBP2^.sockto:=0;
{if SetTimer(Wnd,Sock2,1000,nil)=0
then} PostMessage(Wnd,WM_NotifyTilo,Sock2,FD_CloseLater);
end;
end;
end;
FD_CloseLater: begin
PutMsg('FD_CloseLater');
GetReadBytes(Sock);
if CloseSocket(Sock)<>0 then begin
ListError('CloseSocket');
PostMessage(Wnd,WM_NotifyTilo,Sock,FD_CloseLater);
end else begin
Dec(Connections); ShowConnections;
flags:=flags or 2; {CloseSocket() sockfrom}
if Sock2<>0 then begin
TBP2^.flags:=TBP2^.flags or 8; {Companion CloseSocket() sockto}
end;
Sock:=CheckDispose(TBP);
if Sock2<>0 then begin
TBP2^.sockto:=Sock; {sockto austragen}
PostMessage(Wnd,WM_NotifyTilo,Sock2,FD_CloseLater);
end;
end;
end;
FD_Read: begin
PutMsg('FD_Read');
if Sock2=0 then exit;
repeat
BO:=ReadBuf(TBP^) {Solange Daten zum Lesen...}
until not (WriteBuf(TBP^) and BO);{und solange Ziel aufnahmefähig}
{ CheckClose(IsProxy,TB);
CheckClose(not IsProxy,TB);}
end;
FD_Write: begin
PutMsg('FD_Write');
if Sock2=0 then exit;
while WriteBuf(TBP2^) do begin {Solange Ziel aufnahmefähig...}
if {(TB.Flags and $10 <>0) {Sofern 2 Kanäle bereit sind}
{ and} (ReadBuf(TBP2^) {dann Daten nachziehen, randvoll...}
or (TBP2^.ReadIdx<>TBP2^.WriteIdx)) {oder wenigstens halb gefüllt?}
then else break; {Wenn nicht: RAUS}
end;
{ CheckClose(IsProxy,TB);}
end;
else begin
ListError('unknown msg');
end;
end{case};
end{with};
end;
const
InChange:Boolean=false;
procedure MakeTb(Sock,Sock2:TSocket);
var
TBP: PTransferBlock;
begin
if AttGetWW(0,Sock)<>0
then AddListLine(3,'I ProxySocket %d doppelt',PChar(Sock));
New(TBP);
with TBP^ do begin
TBP^.sockfrom:=Sock;
TBP^.sockto:=Sock2;
TBP^.flags:=0;
TBP^.writeidx:=0;
TBP^.readidx:=0;
end;
if AttPutWW(0,Sock,LongInt(TBP))=-1 then RunError(220);
AddListLine(1,'New TBP (%d,%d)',Ptr(Sock,Sock2));
end;
procedure HandleResize(x,y: Integer);
var
R: TRect;
P: TPoint absolute R;
W: HWnd;
begin
W:=GetDlgItem(Wnd,13);
GetWindowRect(W,R);
ScreenToClient(Wnd,P);
MoveWindow(W,R.left,R.top,x-2*R.left,y-R.top-4,false);
end;
function DialogProc(Window:HWnd; Msg,wParam:Word; lParam:LongInt):Bool; export;
{Struktur für sauberes WSAAsyncGetHostByAddr()}
type
PHE=^THE;
THE=record
headdr: LongInt; {"inaddr" wird von WSAAsyncGetHostByAddr()}
Fill: LongInt;
case integer of {als extra Speicherbereich gebraucht!!}
1: (he: THostEnt); {hier läßt diese Funktion die Daten fallen}
2: (hh: array[0..MaxGetHostStruct-1] of Char);
end;
var
{ S: array[0..255]of Char;}
{ SP: PChar;}
{ B:Byte;}
lPar: LongRec absolute lParam;
I: Integer;
sa: TSockAddrIn;
sasize:Integer;
TiloSocket,ProxySocket: TSocket;
HEP: PHE;
TBP: ^TTransferBlock;
ConP: ^TCon;
WSADP: PWSAData;
begin
asm push es end;
DialogProc:=false;
case Msg of
WM_InitDialog: begin
Wnd:=Window; {Globale Variable setzen}
FillChar(SM,sizeof(SM),0); {löschen: String-Puffer}
SMIdx:=0;
ChangeSysMenu;
ShowWindow(Wnd,CmdShow); {Icon? - Sofort wirksam machen!}
SendDlgItemMessage(Wnd,13,WM_SetFont,GetStockObject(Ansi_Fixed_Font),1);
PostMessage(Wnd,WM_ContinueInit,0,0);
end;
WM_ContinueInit: begin
UpdateWindow(Wnd); {würde in InitDialog nichts bringen !!}
LoadConfig;
SplitCmdLine; {verändert CmdShow}
SetDlgItemInt(Wnd,12,LVerbose,true);
AttInit;
New(WSADP);
if WSAStartup($101,WSADP^)=0 then begin
StartupOK:=true;
AddListLine(2,PChar(7),WSADP^.szDescription);
for I:=0 to ConFill-1 do ReConnect(Con[I]);
AddListLine(2,'%d TCP Tunnel bereit',PChar(ConFill));
end else begin
ListError('WSAStartup');
end;
Dispose(WSADP);
ShowWindow(Wnd,CmdShow);
{SW_Hide darf erst bei sichtbarem Fenster benutzt werden, warum auch immer}
end;
WM_NotifyAccept: begin
if lPar.Hi<>0 then ListError('accept msg');
{Welches Accept?}
ConP:=Pointer(AttGetWW(3,wParam));
{Socket zu Tilo}
sasize:=sizeof(sa);
TiloSocket:=Accept(wParam,sa,sasize);
if TiloSocket=-1 then ListError('accept');
if AttGetWW(0,TiloSocket)<>0
then AddListLine(3,'I TiloSocket %d doppelt',
PChar(TiloSocket));
Inc(Connections); ShowConnections;
AddListLine(2,PChar(8),inet_ntoa(sa.sin_addr.s_addr));
{Tilo's Rechnername ermitteln (funktioniert nicht)}
New(HEP);
FillChar(HEP^,sizeof(THE),0);
HEP^.headdr:=sa.sin_addr.s_addr;
I:=WSAAsyncGetHostByAddr(Wnd,WM_NotifyGetHostByAddr,
PChar(@(HEP^.headdr)),4,PF_INET,HEP^.hh,MaxGetHostStruct);
if I=0 then ListError('WSAAsyncGetHostByAddr')
else if AttPutWW(1,I,LongInt(HEP))=-1 then RunError(220);
AddListLine(2,'OK GetHostByAddr()=%d',PChar(I));
{Socket zu www-cache}
ProxySocket:=Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
MakeTb(TiloSocket,ProxySocket);
MakeTb(ProxySocket,TiloSocket);
{Socket-"Ehe" merken, High=0}
WSAAsyncSelect(TiloSocket,Wnd,WM_NotifyTilo,
FD_Read or FD_Write or FD_Close);
FillChar(sa,sizeof(sa),0);
sa.sin_family:=AF_INET;
sa.sin_port:=htons(ConP^.conport);
sa.sin_addr.s_addr:=ConP^.inaddr;
WSAAsyncSelect(ProxySocket,Wnd,WM_NotifyTilo,
FD_Connect or FD_Read or FD_Write or FD_Close);
Connect(ProxySocket,sa,sizeof(sa)); {Asynchron}
end;
WM_NotifyTilo: Transfer(wParam,lPar.Lo,lPar.Hi);
WM_Timer: begin
KillTimer(Wnd,wParam);
Transfer(wParam,FD_CloseLater,0);
end;
WM_NotifyGetHostByAddr: begin
HEP:=Pointer(AttDelWW(1,wParam));
if HEP<>nil then begin
if lPar.Hi<>0 then begin
ListError('GetHostByAddr msg');
end else begin
AddListLine(2,PChar(8),HEP^.he.h_name);
end;
Dispose(HEP);
end else begin
AddListLine(4,'E NIL bei WM_NotifyGetHostByAddr (%d)',PChar(wParam));
end;
end;
WM_InitMenuPopup: if lPar.Hi<>0 then begin {Systemmenü-Init}
lPar.Lo:=MF_Unchecked;
if GetWindowLong(Wnd,GWL_ExStyle) and WS_EX_TopMost <>0
then lPar.Lo:=MF_Checked;
CheckMenuItem(wParam,24,lPar.Lo);
end;
WM_SysCommand: case wParam of
22: MBox1(Wnd,4,MB_OK,StdMBoxTitle); {About-Box}
23: ShowWindow(Window,SW_Hide); {Verbergen}
24: begin {Vordergrund}
lPar.Hi:=HWND_NoTopmost;
if GetWindowLong(Wnd,GWL_ExStyle) and WS_EX_TopMost =0
then lPar.Hi:=HWND_Topmost;
SetWindowPos(Wnd,lPar.Hi,0,0,0,0,SWP_NoMove or SWP_NoSize);
end;
end;
WM_EndSession: {SaveConfig};
WM_Size: if not IsIconic(Wnd) then HandleResize(lPar.Lo,lPar.Hi);
WM_Command: case wParam of
1: begin {Auswahl setzen}
end;
IDCancel: begin
{SaveConfig};
WinHelp(Wnd,HelpFileName,HELP_Quit,0);
for I:=0 to ConFill-1 do CloseSocket(Con[i].sock);
if StartupOK then WSACleanUp;
EndDialog(Wnd,0);
end;
9: WinHelp(Wnd,HelpFileName,HELP_Index,0);
12: if (lPar.Hi=EN_Change) and not InChange then begin
I:=GetDlgItemInt(Wnd,wParam,nil,true);
if (0<I) and (I<=5) then begin
LVerbose:=I;
if LVerbose=5 then SetWindowText(Wnd,StdMBoxTitle)
end else begin
InChange:=true;
SetWindowText(lPar.Lo,'?');
SendMessage(lPar.Lo,EM_SetSel,0,$FFFF0000);
InChange:=false;
end;
ShowPakete;
end;
14: SendDlgItemMessage(Wnd,13,LB_ResetContent,0,0);
16: begin Pakete:=0; ShowPakete; end; {Zähler nullsetzen}
end;
end;
asm pop es end;
end;
const
wc:TWndClass=(
style: CS_VRedraw or CS_HRedraw;
lpfnWndProc: @DefDlgProc;
cbClsExtra: 0;
cbWndExtra: DlgWindowExtra;
hInstance: Seg(HInstance);
hIcon: 0;
hCursor: 0;
hbrBackground:Color_Background+1;
lpszMenuName: nil;
lpszClassName:'FWD');
begin
WUtils.StdMBoxTitle:=@AppName; {MessageBox-Titel in Unit setzen}
if HPrevInst<>0 then begin {Nicht doppelt starten!}
wc.hIcon:=FindWindow('FWD',nil);
ShowWindow(wc.hIcon,SW_Restore);
SetActiveWindow(wc.hIcon);
halt;
end;
if not SetMessageQueue(64) then halt; {mehr Platz vielleicht?}
wc.hIcon:=LoadIcon(Seg(HInstance),MakeIntResource(100));
wc.hCursor:=LoadCursor(0,IDC_Arrow);
RegisterClass(wc);
DialogBox(Seg(HInstance),MakeIntResource(100),0,@DialogProc);
end.
| Detected encoding: OEM (CP437) | 1
|
|
|