program rs485dde;
{$D Burster/Gernsbach RS485<->DDE-Schnittstelle h#s 02/03 -- 04/04}
{auch für Gantner ISK100, auch für Windows NT (wegen Zeitmessung)?}
{Ein beliebiger Kommandozeilenschalter deaktiviert den direkten Portzugriff
unter Windows 3.x/9x/Me und lässt RS485DDE genauso wie unter NT arbeiten
* Überarbeitung 04/04 für detaillierte Fehler-Ereignis-Liste; Wegfall
des About-Fensters, neue Programmstruktur mit permanentem Dialog
SYMBOL LEUCHTET BEI FEHLER ZU KURZ, ein T3 (maximale "Bedenkzeit") muss rein}
{$F-,A+,G+,K+,W-}
{$I-,Q-,R-,S-}
{$V+,B-,X+,T+,P+}
{$M $3000,$1000}
{$N-}
{$R rs485dde}
uses WinProcs,WinTypes,Win31,Ddeml,ToolHelp, WUtils,{Parser,}Tray16;
const
AppName='RS485DDE'; {Fensterklassenname}
HelpFileName='RS485DDE.HLP';
FLASH=200; {ms Aufblitzen bei Transaktion}
{************* Hauptprogramm *************************}
var
DdeHelpString: array[0..1024] of Char; {zum Zusammensetzen}
const
MAXCOM=3; {Anzahl unterstützter Schnittstellen -1}
QUEUESIZE=80; {Schlangengröße bei OpenComm, = max. Stringlänge}
DdeLastSystem=4; {Anzahl der System-Items}
DefT=20; {Standard-TimeOut für T1 und T2 [ms], COM-Port ist blockiert}
WM_IconChange=WM_User+101;
DdeSystemS: array[0..DdeLastSystem] of PChar=(
'System','Topics','Formats','Help','SysItems');
{System-Item-Stringkonstanten}
DdeStrings:array[0..DdeLastSystem] of PChar=(nil,
'<COMx parameters timeouts>','CF_TEXT',
DdeHelpString,
'Topics Formats Help SysItems');
{Stringkonstanten als Antwort auf Anfragen auf System-Items}
DdeService='RS485';
var
Inst: LongInt; {Instanz-Variable ("Handle"), GLOBAL}
ServiceHsz: Hsz; {Stringhandle für Service (RS485)}
{ DataHsz: array[0..DdeNumData] of Hsz; {Stringhandles für normale Items}
SysHsz: array[0..DdeLastSystem]of Hsz; {System-Stringhandles}
SysConnections: Integer; {ist mit Null initialisiert}
DdeConnections: array[0..MAXCOM] of Integer;
{Anzahl aktiver Verbindungen pro COM-Port, Index=Cid von OpenComm}
Talking: array[0..MAXCOM] of Byte; {TRUE solange Daten nicht gelesen!}
ComTimers: array[0..MAXCOM] of Word;
{Zeitmarken der letzten Kommunikation, wichtig zur Einhaltung von Pausen}
{Rechenzeit-Hergabe und Reentranz-Auflösung ist eingebaut (via CBR_Block)}
PortAccess: Boolean; {=false}
{$IFDEF HaveWindow}
var
MainWnd: HWnd;
Icons: array[0..3] of HIcon; {4 Icons für ruhend, verbunden, Fehler, OK}
CurIcon: Integer;
Statistik: array[0..3] of Word; {Zugriffszähler, Indizes:
0=DDE-Verbindungen inklusive SYSTEM, 1=DDEPokes+DDERequests (alle),
2=RS485-Fehler (Format, Prüfsumme), 3=RS485-Okay}
Listbox: HWnd;
{************* Unterprogramme *************************}
procedure IncStatistik(index,add:Integer);
begin
if add<>0 then Inc(Statistik[index],add) else Statistik[index]:=0;
SetDlgItemInt(MainWnd,101+index,Statistik[index],false);
end;
procedure AddError(nr: Integer; src:PChar);
var
s: TS255;
i: Integer;
begin
i:=LoadString(Seg(HInstance),nr,s,sizeof(s));
if src<>nil then begin
lstrcpy(s+i,' (');
Inc(i,2);
Inc(i,EscapeStr(src,lstrlen(src),s+i,sizeof(s)-i-1));
lstrcpy(s+i,')');
end;
i:=SendMessageP(Listbox,LB_AddString,0,@s);
SendMessage(Listbox,LB_SetCurSel,i,0);
if i>1000
then SendMessage(Listbox,LB_DeleteString,0,0); {ältesten Fehler löschen}
end;
procedure ChangeDdeIcon(NewIcon:Integer);
var
Msg:TMsg;
begin
if NewIcon>=2 then begin
IncStatistik(NewIcon,1);
SetTimer(MainWnd,102,FLASH,nil); {Timer neu starten}
end;
if CurIcon=NewIcon then exit;
CurIcon:=NewIcon;
PeekMessage(Msg,MainWnd,WM_IconChange,WM_IconChange,PM_Remove);
PostMessage(MainWnd,WM_IconChange,NewIcon,0);
end;
function GetDdeConnections:Integer; {liefert nicht die SYSTEM-Verbindungen!}
var
Cid,i: Integer;
begin
i:=SysConnections;
for Cid:=0 to MAXCOM do Inc(i,DdeConnections[Cid]);
GetDdeConnections:=i;
end;
procedure ChangeDdeDisplay;
var
Cid: Integer;
vsrec:record
s: PChar;
i: Integer;
end;
s: TS31;
begin
vsrec.s:=WUtils.StdMBoxTitle;
vsrec.i:=GetDdeConnections;
wvsprintf(s,'%s [%d]',vsrec);
SetWindowText(MainWnd,s);
ChangeDdeIcon(Integer(vsrec.i<>0));
end;
{$ELSE}
procedure AddError(nr:Integer; src:PChar); begin; end;
{$ENDIF}
procedure DdeError(Code:Integer);
begin
vMBox({$IFDEF HaveWindow}MainWnd{$ELSE}0{$ENDIF},102,0,Code);
end;
function CreateStringHandle(Str:PChar):Hsz;
var Stringhandle: Hsz;
begin
Stringhandle:=DdeCreateStringHandle(Inst,Str,CP_WinAnsi);
CreateStringHandle:=StringHandle;
if StringHandle=0 then DdeError(2);
end;
procedure FreeStringHandle(Stringhandle:Hsz);
begin
if Stringhandle<>0 then
DdeFreeStringHandle(Inst,StringHandle);
end;
function GetSystemNumber(Hsz2: Hsz; Fmt:Word):Integer;
var
I: Integer;
begin
GetSystemNumber:=0; {Kein Datum!}
if Fmt<>CF_Text then exit;
for I:=1 to DdeLastSystem do
if DdeCmpStringHandles(Hsz2,SysHsz[I])=0 then begin
GetSystemNumber:=I;
exit;
end;
end;
function GetPrecisTick:Word;
{wie GetTickCount, jedoch wirklich ms-genau;
WORD reicht für Zeitdifferenzen von 1 Minute,
ein Kandidat für WUtils?}
var
ti:TTimerInfo;
begin
InitStruct(ti,sizeof(ti));
TimerCount(@ti);
GetPrecisTick:=LongRec(ti.dwmsSinceStart).lo;
end;
procedure BeginCriticalSection; assembler;
asm mov ax,1681h
int 2Fh
end;
procedure EndCriticalSection; assembler;
asm mov ax,1682h
int 2Fh
end;
function Make_Summe(s:PChar; slen:Integer):Byte; assembler;
{Prüfsumme über die Zeichen des Strings berechnen,
Attach_Summe verlässt sich auf ES und SI bei Rückgabe!}
asm les si,[s]
mov cx,slen
mov ah,0
jcxz @@e
cld
@@l: seges lodsb
add ah,al {AH = Summenzähler}
loop @@l
@@e: xchg ah,al
end;
procedure Attach_Summe(s:PChar; slen:Integer); assembler;
{Prüfsumme in Hex (2 Stellen) an String anhängen}
const
format: array[0..4] of Char='%02X';
asm les si,[s]
push es
push si
push [slen]
call Make_Summe
mov ah,0
push ax
push ds
push offset format
push es
push si
call wsprintf
add sp,5*2 {eigentlich unnötigt, erledigt Returncode}
end;
function GetUD(Conv:HConv):LongInt;
{holt zugeortnetes COM-Handle und Umschaltzeit T2 aus Conv heraus}
var
ci: TConvInfo;
begin
DdeQueryConvInfo(Conv,QID_Sync,@ci);
GetUD:=ci.hUser;
end;
function SendRecv(Cid:Integer; T1: Word; s:PChar; slen:Integer;
T2: Word; buf:PChar; bufsize:Integer; TermBelow: Char):Integer;
{Sendet und empfängt String zum und vom RS485-Gerät.
T1 ist die Zeit, die vor dem Senden bzgl. vorheriger Übertragung
zu warten ist.
Der Sendestring sollte mit einem Zeichencode <20h abgeschlossen sein
(=ASCII-Protokoll), slen=Stringlänge, -1 für nullterminiert;
der Empfang des Strings bricht ab bei Zeitüberschreitung,
Puffer voll oder bei Empfang eines Zeichencodes < TermBelow.
T2 ist die maximale Wartezeit zwischen Senden und Empfang in ms.
Rückgabe: Anzahl empfangener Zeichen (auch bei TimeOut),
-1 bei Sendefehler, -2 bei Reentranzfehler.
Der gelesene String ist nicht nullterminiert!
Der Burster/Gernsbach RS485-Umsetzer Typ 5401-Z001 schaltet die
Datenrichtung mit Hilfe der RTS-Leitung um.
Deshalb muss dieses Programm unmittelbar nach der Ausgabe des letzten Bytes
RTS löschen und nicht verzögern, sonst gibt es Buskollisionen und verlorene
Datenbytes.
Wegen des dazu notwendigen Portzugriffs läuft diese Warteschleife nicht
unter Windows NT; stattdessen arbeitet eine berechnete Warteschleife,
die den Umschaltzeitpunkt mit einer Zugabe von 1..2 ms schätzt.
Auch die Portabfrage selbst wäre nicht sicher vor Taskumschaltungen;
deshalb erfolgt eine Einrahmung in einen (hoffentlich funktionierenden)
"kritischen Abschnitt".
Der Gantner RS485-Umsetzer Typ ISK100 detektiert die Richtungsumschaltung
anhand des Sendesignals TxD (kompliziertere Schaltung).
Dieser Umsetzer läuft daher problemlos auch unter Windows NT.}
label exi;
var
ret,bytesread: Integer;
bitper1000byte:Integer;
tic: Word;
DCB: TDCB;
ComStat: WinTypes.TComStat absolute DCB; {kürzer als DCB}
ls_reg: Word absolute bytesread;
begin
Ret:=-2;
Inc(Talking[Cid]); {Hoffentlich atomar!}
if Talking[Cid]>1 then goto exi; {Keine verschachtelten Zugriffe!}
if slen=-1 then slen:=lstrlen(s);
ret:=-1;
GetCommError(Cid,ComStat); {"auftauen" bei Fehler}
ls_reg:=0; {Portzugriffe sind möglich?}
if PortAccess then ls_reg:=Word(EscapeCommFunction(Cid,GetBaseIrq))+5;
if ComStat.cbInQue<>0 {"Verirrte" Zeichen gekommen?}
then ComTimers[Cid]:=GetPrecisTick; {Wartezeit neu starten}
FlushComm(Cid,1); {Empfangswarteschlange leeren}
GetCommState(Cid,DCB); {Baudrate für TimeOut-Bestimmung}
bitper1000byte:=(((2+DCB.bytesize
+Integer(DCB.parity<>0))shl 1)+DCB.stopbits)*500;
while GetPrecisTick-ComTimers[Cid]<T1 do ShortYield; {T1 warten}
EscapeCommFunction(Cid,SetRTS); {RTS aktiv (nach -12V) setzen}
BeginCriticalSection; {Keine Taskumschaltung zulassen!}
WriteComm(Cid,s,slen); {Ab in die Warteschlange!}
tic:=GetPrecisTick; {Jetzt geht das Rennen los!}
if ls_reg>=$100 then repeat {Ja, hier wird Windows blockiert!}
if GetPrecisTick-tic > MulDiv(slen,bitper1000byte,DCB.baudrate)+1
then begin {wenn's mal wieder länger dauert}
EndCriticalSection;
EscapeCommFunction(Cid,ClrRTS);
FlushComm(Cid,0); {Sendewarteschlange leeren}
goto exi;
end;
until Port[ls_reg] and $60 = $60 {Hardware-Zugriff! Sender leer?}
else repeat
until GetPrecisTick-tic > MulDiv(slen,bitper1000byte,DCB.baudrate)+1;
EscapeCommFunction(Cid,ClrRTS); {RTS inaktiv (nach +12V) setzen}
EndCriticalSection; {Ab jetzt haben wir Zeit...}
ret:=0;
repeat {T2 und den Empfang der Bytes abwarten}
bytesread:=ReadComm(Cid,buf,bufsize);
Inc(ret,bytesread);
Inc(buf,bytesread);
Dec(bufsize,bytesread);
ShortYield; {Gut gemeint, aber ein Anlass zur Verschachtelung}
if bytesread<>0 then begin
ComTimers[Cid]:=GetPrecisTick; {nur wenn Zeichen kommen, akt.}
if Ord((buf-1)^)<Ord(TermBelow) then break; {eine Endekennung}
end;
until (bufsize=0) {Puffer voll}
or (GetPrecisTick-tic > MulDiv(slen+ret+1,bitper1000byte,DCB.baudrate)+T2);
exi:
Dec(Talking[Cid]);
SendRecv:=ret;
end;
type
PCid=^TCid;
TCid=record {Daten-Ensemble zur Speicherung an der DDE-Transaktion}
id: Integer; {Comm-ID 0..3}
t1,T2: Byte; {T1- und T2-TimeOut in ms}
end;
function DdeCallback(CallType,Fmt:Word; Conv:hConv; HSz1,HSz2:HSz;
Data:hDdeData; Data1,Data2: LongInt): hDdeData; export;
label set_ico;
const {zum Hinüberretten nach XTYP_Connect_Confirm}
ConnectingC:TCid=(id:-1); {Zeitvorgaben unnötig}
var
SendSum, EmpfSum, SRNaked: Boolean;
EmpfChar: Char;
Sum: Byte;
sp,sp2,sp3: PChar;
i,ec,ico: Integer;
C: TCid;
dcb,dcb2: TDcb;
S,buf: array[0..QUEUESIZE] of Char; {1 Byte extra für Null lassen}
begin
DdeCallback:=0;
ico:=2; {von Fehlschlag ausgehen}
case CallType of
XTYP_Connect: begin
if DdeCmpStringHandles(Hsz1,SysHsz[0])=0 then begin {1. "system"}
end else begin
i:=DdeQueryString(Inst,Hsz1,s,sizeof(s),CP_WinAnsi); {2. "COMx"}
sp:=s; {Weil Kommata bei Netzwerk-DDE}
while i<>0 do begin { nicht erlaubt sind...}
if sp^='+' then sp^:=','; {alle Plus zu Komma wandeln}
Inc(sp); Dec(i);
end;
C.t1:=DefT;
C.t2:=DefT;
sp:=lstrchr(s,' ');
if sp=nil then begin {ohne Angabe der Baudrate usw.}
Val(s+3,C.id,ec);
if ec<>0 then begin AddError(1,s); exit; end;
Dec(C.id);
end else begin
sp2:=lstrchr(sp+1,' '); {TimeOut-Parameter}
if sp2<>nil then begin
sp2^:=#0;
sp3:=lstrchr(sp2+1,',');
if sp3<>nil then begin
sp3^:=#0;
Val(sp3+1,C.t2,ec); {getrennte Zeiten}
if ec<>0 then begin AddError(2,sp3+1); exit; end;
end;
Val(sp2+1,C.t1,ec);
if ec<>0 then begin
AddError(2,sp2+1); {falsche TimeOut-Zahl}
exit;
end;
if sp3=nil then C.t2:=C.t1; {gleiche Zeiten}
if C.t2=0 then begin AddError(2,nil); exit; end;
end;
if BuildCommDCB(s,dcb)<>0 then begin
AddError(3,s);
exit;
end;{mit Angabe der Baudrate}
C.id:=dcb.id;
end;
if Word(C.id)>MAXCOM then begin AddError(1,nil); exit; end;
if DdeConnections[C.id]<>0 then begin
if sp<>nil then begin
GetCommState(C.id,dcb2);
if memcmp(PChar(@dcb),PChar(@dcb2),sizeof(dcb))<>0 then begin
AddError(4,nil); {Müssen gleiche Parameter sein!}
exit;
end;
end;
end else begin
if sp<>nil then sp^:=#0; {Parameter abhacken}
C.id:=OpenComm(s,QUEUESIZE,QUEUESIZE);
if Word(C.id)>MAXCOM then begin
i:=5;
case C.id of
IE_Open: i:=6;
IE_NOpen: i:=7;
IE_Hardware: i:=8;
end;
AddError(i,s);
exit; {Bereits (woanders) geöffnet!}
end;
if (sp<>nil) and (SetCommState(dcb)<>0) then begin
CloseComm(C.id);
AddError(9,sp);
exit;
end;
end;
ConnectingC:=C;
end;
DdeCallback:=1; {Verbindung okay!}
end;
XTYP_Connect_Confirm: begin
C:=ConnectingC;
ConnectingC.id:=-1;
DdeSetUserHandle(Conv,QID_Sync,LongInt(C)); {nachträgliche Zuordnung!}
if C.id>=0 then Inc(DdeConnections[C.id])
else Inc(SysConnections);
{$IFDEF HaveWindow}
ChangeDdeDisplay;
IncStatistik(0,1);
{$ENDIF}
end;
XTYP_Disconnect: begin
LongInt(C):=GetUD(Conv); {Deskriptor holen}
if C.id>=0 then begin
Dec(DdeConnections[C.id]);
if DdeConnections[C.id]=0 then CloseComm(C.id);
end else Dec(SysConnections);
{$IFDEF HaveWindow}
IncStatistik(0,-1);
ChangeDdeDisplay;
{$ENDIF}
end;
XTYP_Request: begin
(*Aufbau Request-Item:
Sende-String{:|;}Empfangs-Maske{|:|;} oder Sende-String*
: = normales Trennzeichen
; = Prüfsumme anhängen (Sende-String) bzw. prüfen (Empfangs-String)
Empfangs-Maske ist hier das erste erwartete Zeichen des Empfangs-Strings
(wird abgeschnitten, genauso wie die Prüfsumme)
Das Request-Item wird von hinten geparst; der Sende-String darf deshalb
':' und ';' enthalten, auch die Empfangs-Maske darf ';' oder ':' sein
Die Übergabe von Sende-String* ermöglicht ungefilterte (Binär-)Übertragung
(z.B. Profibus, ModBus), der Stern wird abgeschnitten,
ggf. "\r" nicht vergessen! *)
{$IFDEF HaveWindow}
IncStatistik(1,1);
{$ENDIF}
if Fmt<>CF_Text
then begin AddError(10,nil); exit; end; {Kann nicht anders!}
LongInt(C):=GetUD(Conv); {Deskriptor holen}
if C.id>=0 then begin
SendSum:=false;
EmpfSum:=false;
SRNaked:=false;
i:=DdeQueryString(Inst,Hsz2,s,sizeof(s),CP_WinAnsi);
if i<2 then begin AddError(11,s); exit; end;
Dec(i);{auch ungefiltert mindestens 1 Zeichen}
EmpfChar:=s[i];
if EmpfChar='*' then SRNaked:=true
else begin
if i<3 then begin
AddError(11,s);
exit; {mindestens 4 Zeichen müssen's hier sein}
end;
if EmpfChar=';' then EmpfSum:=true;
if EmpfChar in [':',';'] then begin
Dec(i);
EmpfChar:=s[i];
end;
Dec(i);
case s[i] of
';': SendSum:=true;
':': ;
else AddError(12,s); exit; {Fehler im DDE-Request}
end;
if SendSum then begin
Attach_Summe(s,i);
Inc(i,2);
end;
s[i]:=#13; Inc(i);
end;
i:=SendRecv(C.id,C.t1,s,i,C.t2,buf,sizeof(buf),
Char(IfThenElse(SRNaked,$00,$20)));
if i=-2 then begin DdeCallback:=CBR_Block; exit; end;
if i<0 then begin AddError(13,nil); goto set_ico; end;
if SRNaked then sp:=buf {ungefiltert übergeben (auch Leerstring)}
else begin
if i<2 then begin
AddError(14,buf); {Mindestens 2 Zeichen müssen kommen!}
goto set_ico;
end;
if buf[0]<>EmpfChar then begin
AddError(15,buf);
goto set_ico; {Falsches Startzeichen}
end;
Dec(i);
if buf[i]<>#13 then begin
AddError(16,buf);
goto set_ico; {Falsches Endezeichen}
end;
buf[i]:=#0;
if EmpfSum then begin
if i<3 then begin
AddError(14,buf);
goto set_ico; {Mindestens 4 Zeichen müssen kommen!}
end;
Dec(i,2); {2 Zeichen hinten weniger}
s[0]:='$';
lstrcpy(s+1,buf+i);
buf[i]:=#0;
Val(s,Sum,ec);
if ec<>0 then begin
AddError(17,buf);
goto set_ico; {Falsche Zeichen in Prüfsumme o.ä.}
end;
if Make_Summe(buf,i)<>Sum then begin
AddError(18,buf);
goto set_ico; {Falsche Prüfsumme}
end;
end;
sp:=buf+1; Dec(i);
end;
sp[i]:=#0; {für DDE terminieren}
DdeCallback:=DdeCreateDataHandle(Inst,sp,i+1,0,hsz2,CF_Text,0);
Inc(ico); {Erfolg}
goto set_ico;
end; {SYSTEM-Thema}
i:=GetSystemNumber(hsz2,fmt);
if i<=0 then begin
AddError(19,nil);
exit;
end;
sp:=DdeStrings[i];
DdeCallback:=DdeCreateDataHandle(Inst,sp,lstrlen(sp)+1,0,hsz2,CF_Text,0);
end;
XTYP_Poke: begin
(*Aufbau Poke-Item:
Sende-String-Kopf{|:|;}
: = normales Trennzeichen (wirkungslos, außer um : zu ermöglichen)
; = Prüfsumme anhängen (Sende-String)
Sende-String-Kopf wird einfach um die Poke-Daten ergänzt,
ggf. mit Prüfsumme ergänzt, und die ACK-Bestätigung vom Gerät eingeholt.
Bei fehlender oder NACK-Bestätigung gibt's ein DDE_fNotProcessed. *)
{$IFDEF HaveWindow}
IncStatistik(1,1);
{$ENDIF}
if Fmt<>CF_Text
then begin AddError(10,nil); exit; end; {Kann nicht anders!}
LongInt(C):=GetUD(Conv); {Deskriptor holen}
if C.id<0 then begin
AddError(20,nil);
exit;
end;
i:=DdeQueryString(Inst,Hsz2,s,sizeof(s),CP_WinAnsi);
if i=0 then begin
AddError(11,nil);
exit;
end;
Dec(i);
SendSum:=false;
if s[i]=';' then SendSum:=true;
if not (s[i] in [':',';']) then Inc(i);
if Data<>0 then begin
lstrcpyn(s+i,DdeAccessData(Data,nil),sizeof(s)-3-i);
{Die Daten von DdeAccessData können keine Nullen enthalten,
weil die DDE-Längenangabe in 32er Stückelung kommt (getestet)}
DdeUnaccessData(Data);
Inc(i,lstrlen(s+i)); {neu durchzählen}
end;
if SendSum then begin
Attach_Summe(s,i);
Inc(i,2);
end;
s[i]:=#13; Inc(i);
i:=SendRecv(C.id,C.t1,s,i,C.t2,buf,sizeof(buf),' ');
if i=-2 then begin DdeCallback:=CBR_Block; exit; end; {Reentranz}
if i<0 then begin AddError(13,nil); goto set_ico; end;
if i=1 then case buf[0] of
#$06: begin
DdeCallback:=DDE_fAck;
Inc(ico); {Erfolg}
goto set_ico;
end;
#$15: begin
AddError(22,buf); {NAK}
goto set_ico;
end;
end else AddError(21,buf); {irgendetwas}
set_ico:
{$IFDEF HaveWindow}
ChangeDdeIcon(ico); {Erfolg oder Misserfolg anzeigen}
{$ENDIF}
DdeEnableCallback(Inst,0,EC_EnableAll); {blockierte neu starten}
end;
end;
end;
procedure DDEInit;
var
W: Word;
begin
if DdeInitialize(Inst,DdeCallBack,CBF_Skip_Registrations
or CBF_Skip_Unregistrations
or CBF_Fail_Executes
or CBF_Fail_Advises,0)<>DMLErr_No_Error
then DdeError(DMLErr_Sys_Error);
W:=LoadString(Seg(HInstance),106,DdeHelpString,256);
Inc(W,LoadString(Seg(HInstance),107,DdeHelpString+W,256));
LoadString(Seg(HInstance),108,DdeHelpString+W,256);
ServiceHsz:=CreateStringHandle(DdeService);
for W:=0 to DdeLastSystem do SysHsz[W]:=CreateStringHandle(DdeSystemS[W]);
if DdeNameService(Inst,ServiceHsz,0,DNS_Register)=0
then DdeError(3);
end;
procedure DdeDone;
var i:Integer;
begin
DdeNameService(Inst,ServiceHsz,0,DNS_Unregister);
for I:=DdeLastSystem downto 0 do
FreeStringHandle(SysHsz[i]);
FreeStringHandle(ServiceHsz);
DdeUninitialize(Inst);
end;
{$IFDEF HaveWindow}
var
traydata: TNotifyIconData;
MinSize: TPoint; {Ausgangsgröße für Dialogfenster}
ListPos: TPoint;
procedure ShellNotify;
begin
if not Shell_NotifyIcon(NIM_Modify,traydata) then begin
LongRec(traydata.uFlags).lo:=NIF_Icon or NIF_Tip or NIF_Message;
Shell_NotifyIcon(NIM_Add,traydata);
end;
end;
procedure GetMinSize;
var
wp:TWindowPlacement;
begin
wp.length:=sizeof(wp);
GetWindowPlacement(MainWnd,@wp);
MinSize.x:=wp.rcNormalPosition.right-wp.rcNormalPosition.left;
MinSize.y:=wp.rcNormalPosition.bottom-wp.rcNormalPosition.top;
GetWindowRect(Listbox,wp.rcNormalPosition);
ListPos:=PPoint(@wp.rcNormalPosition)^;
ScreenToClient(MainWnd,ListPos);
end;
function MainDlgProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):Bool; export;
var
lPar: LongRec absolute lParam;
P: TPoint;
m,sysm: HMenu;
s: TS31;
begin
MainDlgProc:=false;
case Msg of
WM_InitDialog: begin
MainWnd:=Wnd;
Listbox:=GetDlgItem(Wnd,105);
sysm:=GetSystemMenu(Wnd,false);
DeleteMenu(sysm,SC_Maximize,0);
LoadString(Seg(HInstance),111,s,sizeof(s)); {Hilfe}
InsertMenu(sysm,1,MF_ByPosition or MF_String,$1D0,s);
if Swap(Word(GetVersion))>=3*256+95 then begin
LoadString(Seg(HInstance),110,s,sizeof(s)); {In den Tray!}
InsertMenu(sysm,2,MF_ByPosition or MF_String,$1E0,s);
if CmdShow in [SW_Minimize,SW_ShowMinimized,SW_ShowMinNoActive]
then PostMessage(Wnd,WM_SysCommand,$1E0,0);
end;
GetMinSize; {Fokus NICHT setzen! Sonst wirkt ShowMinNoActive nicht}
end;
WM_GetMinMaxInfo: begin
PMinMaxInfo(lParam)^.ptMinTrackSize:=MinSize;
end;
WM_Size: if wParam=SIZE_Minimized then begin
if LongRec(traydata.cbSize).lo<>0 then ShowWindow(Wnd,SW_Hide);
end else begin
SetWindowPos(Listbox,0,0,0,
lPar.lo-8-ListPos.x,lPar.hi-8-ListPos.y,SWP_NoZOrder or SWP_NoMove);
end;
WM_Timer: begin
KillTimer(Wnd,102);
if CurIcon<>0 then ChangeDdeIcon(1);
end;
WM_IconChange: begin
lPar.lo:=Icons[wParam];
SetClassWord(Wnd,GCW_HIcon,lPar.lo);
InvalidateRect(Wnd,nil,true);
if LongRec(traydata.cbSize).lo<>0 then begin
LongRec(traydata.hIcon).lo:=lPar.lo;
LongRec(traydata.uFlags).lo:=NIF_Icon; {nur Icon ändern}
ShellNotify;
end;
SendDlgItemMessage(Wnd,100,STM_SETICON,lPar.lo,0);
end;
WM_SetText: begin
if LongRec(traydata.cbSize).lo<>0 then begin
lstrcpy(traydata.szTip,PChar(lParam));
LongRec(traydata.uFlags).lo:=NIF_Tip; {nur Text ändern}
ShellNotify;
end;
end;
WM_SysCommand: case wParam and $FFF0 of
$1E0: begin {In den Tray!}
LongRec(traydata.cbSize).lo:=sizeof(traydata);
LongRec(traydata.hwnd).lo:=Wnd;
LongRec(traydata.uID).lo:=110;
LongRec(traydata.uFlags).lo:=NIF_Icon or NIF_Tip or NIF_Message;
LongRec(traydata.uCallbackMessage).lo:=WM_User+100;
LongRec(traydata.hIcon).lo:=GetClassWord(Wnd,GCW_HIcon);
GetWindowText(Wnd,traydata.szTip,sizeof(traydata.szTip));
if Shell_NotifyIcon(NIM_Add,traydata)
and IsIconic(Wnd)
then ShowWindow(Wnd,SW_Hide);
end;
$1D0: WinHelp(Wnd,HelpFileName,HELP_Index,0);
end;
WM_User+100: case lParam of
WM_LButtonDown: begin
ShowWindow(Wnd,SW_Restore);
end;
WM_RButtonDown: begin
m:=LoadMenu(Seg(HInstance),MakeIntResource(100));
sysm:=GetSubMenu(m,0);
GetCursorPos(P);
TrackPopupMenu(sysm,TPM_RightAlign or TPM_RightButton,
P.x,P.y,0,Wnd,nil);
DestroyMenu(m);
end;
end;
WM_Command: case wParam of {kommen nur vom System-Tray!}
2: ShowWindow(Wnd,SW_Minimize); {besser als gar nichts}
100: begin {normales Fenster!}
if not IsWindowVisible(Wnd) then ShowWindow(Wnd,SW_Minimize);
Shell_NotifyIcon(NIM_Delete,traydata);
LongRec(traydata.cbSize).lo:=0; {auch künftig deaktivieren}
end;
106: begin {Rücksetzen+Löschen}
SendMessage(Listbox,LB_ResetContent,0,0);
for lPar.lo:=1 to 3 do IncStatistik(lPar.lo,0);
end;
900: WinHelp(Wnd,HelpFileName,HELP_Index,0);
999: ShowWindow(Wnd,SW_Restore);
end;
WM_Close: begin
if (GetDdeConnections>0)
and (MBox1(Wnd,109{WarnClose},MB_IconQuestion or MB_YesNo or MB_Sound,
PChar(GetDdeConnections))<>IDYes)
then exit;
if LongRec(traydata.cbSize).lo<>0
then Shell_NotifyIcon(NIM_Delete,traydata);
WinHelp(Wnd,HelpFileName,HELP_Quit,0);
DestroyWindow(Wnd);
end;
WM_Destroy: PostQuitMessage(0);
end;
end;
const
wc: TWndClass=(
style: {CS_VRedraw or CS_HRedraw}CS_DblClks;
lpfnWndProc: @DefDlgProc{@MainWndProc};
cbClsExtra: 0;
cbWndExtra: DlgWindowExtra;
hInstance: Seg(HInstance);
hIcon: 0;
hCursor: 0;
hbrBackground: COLOR_Background+1;
lpszMenuName: nil;
lpszClassName: AppName);
var
Msg:TMsg;
i: Integer;
AppTitle: TS31;
begin
if HPrevInst<>0 then begin
SetActiveWindow(MemW[HPrevInst:Ofs(MainWnd)]);
exit;
end;
for i:=0 to HIGH(Icons) do
Icons[i]:=LoadIcon(Seg(HInstance),MakeIntResource(100+i));
wc.hIcon:=Icons[0];
wc.hCursor:=LoadCursor(0,IDC_Arrow);
RegisterClass(wc);
CreateDialog(Seg(HInstance),MakeIntResource(100),0,@MainDlgProc);
ShowWindow(MainWnd,SW_ShowMinNoActive);
GetWindowText(MainWnd,AppTitle,sizeof(AppTitle));
{$ELSE}
var
Msg:TMsg;
const
AppTitle='RS485<->DDE';
begin
if HPrevInst<>0 then exit;
{$ENDIF}
WUtils.StdMBoxTitle:=AppTitle;
if (lstrlen(CmdLine) =0) {Portzugriff erlaubt?}
and (GetWinFlags and WF_WinNT =0) {Portzugriff möglich?}
then PortAccess:=true;
DdeInit;
while GetMessage(Msg,0,0,0) do begin
{$IFDEF HaveWindow}
if IsDialogMessage(MainWnd,Msg) then continue;
{$ENDIF}
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
DdeDone;
{$IFDEF HaveWindow}
for i:=0 to HIGH(Icons) do DestroyIcon(Icons[i]);
{$ENDIF}
end.
| Detected encoding: OEM (CP437) | 1
|
|
|