program mio_dde;
{$D AT-MIO-16X-zu-DDE-Schnittstelle h#s 04/01}
{Benötigt NIDAQ.DLL (16bit) zum Zugriff}
{$F-,A+,G+,K+,W-}
{$I-,Q-,R-,S-}
{$V+,B-,X+,T+,P+}
{$M 8192,0}
{$N+}
{$R mio_dde}
{$DEFINE MSGBOX}
{$DEFINE ERRMSG}
uses WinProcs,WinTypes,Win31,Ddeml, WDAQ,WUtils,Parser,Tray16;
const
AppName='MIO_DDE';
AppTitle='DDE<->MIO';
HelpFileName='MIO_DDE.HLP'; {wenn überhaupt}
BOARD=1; {hier: festgelegt}
{************* Unterprogramme *************************}
type
PConstItem=^TConstItem;
TConstItem=record
k: Integer;
s: array[0..7] of Char;
end;
TReal=Double;
PDouble=^Double;
function Real2S(Z:TReal; F:Integer; S:PChar):PChar;
{Diese Funktion arbeitet wie Str(Z:F:F,S), jedoch werden unnötige
Nachkomma-Nullen abgeschnitten.
Als Ergebnis wird der Stringzeiger durchgereicht.
Der Str()-Syntaxcheck ist buggy; daher muß mit einem wilden Typecast
der Compiler ruhiggestellt werden}
begin
Real2S:=S; {Stringzeiger durchreichen}
Str(Z:F:F,TS255(Pointer(S)^)); {mittels Systemfunktion wandeln}
S:=lStrChr(S,'.'); {Dezimalpunkt enthalten?}
if S<>nil then begin
Inc(S,lstrlen(S)); {Auf die Null}
repeat
Dec(S); {Zeiger aufs Stringende (vor die Null)}
if S^='.' then begin {String besteht nur (noch) aus dem Dezimalpunkt?}
S^:=#0; {String kürzen und raus!}
break;
end;
if S^='0' then S^:=#0 {Stringende ist die Null? - Kürzen und weiter}
else break; {sonst raus!}
until false;
end;
end;
function S2Real(S:PChar; var Z: TReal):boolean;
{wie Val(), jedoch vorher Komma zu Punkt wandeln.
Das Ergebnis ist TRUE, wenn die Konversion OK verlief; dann und nur dann
wird auch die Variable Z eingeschrieben.
Weißraum (TAB & SPC) am Anfang wird übergangen, Weißraum (#0..' ')
am Ende auch, beim Abhacken wird das Zeichen zwischendurch gemerkt,
d.h. der String S wird nicht nach außen verändert.
Da die dusselige Pascal-Val()-Funktion bei Fehler 0.0 einschreibt,
geht's nicht ohne Umweg über eine lokale Real-Variable.
Ein Jammer, daß weder Windows noch Pascal vernünftiges Handling mit
Real-Zahlen anbieten}
var
I:Integer;
SP: PChar;
MemChr: Char;
ZT: TReal;
begin
while (S^=' ') or (S^=#9) do Inc(S); {Weißraum am Anfang übergehen}
SP:=lStrChr(S,',');
if SP<>nil then SP^:='.'; {Komma zum Punkt machen}
SP:=S;
while SP^>' ' do Inc(SP); {Ende des Strings suchen}
MemChr:=SP^; SP^:=#0; {Zeichen merken, String abhacken}
Val(S,ZT,I);
SP^:=MemChr; {Zeichen zurückschreiben}
if I=0 then Z:=ZT; {Nur bei fehlerfreier Konversion rückschreiben}
S2Real:= (I=0); {false wenn Fehler in Real-Zahl}
end;
function GetIntArg2(Str:PChar; min,max: Integer;
const ConstList: array of TConstItem; var res:Integer):Boolean;
{mit Auswertung einer Konstantenliste}
label
found;
var
x: Double;
sp: PChar;
argc,e,i,j,y: Integer; {argc=Anzahl Konstanten in Liste}
argv: array[0..15] of PChar; {Tokenisierte Konstantenliste}
begin
GetIntArg2:=false;
argc:=0;
FillChar(argv,sizeof(argv),0);
sp:=Str;
repeat
case sp^ of
#0,' ','|','+': begin {nur ODER erlaubt}
if argv[argc]<>nil then begin
if argc=16 then break; {keine weiteren Argumente!}
inc(argc); {Nächste Konstante erwarten}
end;
if sp^=#0 then break
else sp^:=#0; {Weißraum löschen}
end;
else if argv[argc]=nil then argv[argc]:=sp;
end;
Inc(sp);
until false;
if argc=0 then exit; {Fehler: keine Konstante angegeben}
y:=0;
for j:=argc-1 downto 0 do begin
for i:=HIGH(ConstList) downto 0 do
with ConstList[i] do begin
if lstrcmpi(argv[j],s)=0 then begin
y:=y or k;
goto found;
end;
end;
Val(argv[j],i,e); {Vielleicht ist's ja eine gewöhnliche Zahl?}
if e=0 then y:=y or i
else exit; {Fehler: Konstante nicht gefunden}
found:
end;
res:=y;
GetIntArg2:=true;
end;
{************* Hauptprogramm *************************}
const
ARG_U08 =$01;
ARG_U16 =$02;
ARG_U32 =$04;
ARG_vzb =$80; {bei vzb. Zahl}
ARG_bigend =$20; {Motorola statt Intel}
type
PShortInt=^ShortInt;
var
DdeHelpString: array[0..1024] of Char; {zum Zusammensetzen}
type
eTopic=(SYS,ADC,DAC);
eSysItem=(SYST,TOPICS,FORMATS,HELP,TIL,SYSITEMS);
eItem=(DATA,LIMITS,MODE,WAVE,RATE,BLOCKLEN,REPEATS,CONTROL,VERSION);
const
DdeSystemS: array[eSysItem]of PChar=(
'System','Topics','Formats','Help','TopicItemList','SysItems');
{System-Item-Stringkonstanten}
DdeStrings:array[eSysItem]of PChar=(
nil,
'ADC DAC',
'CF_TEXT CF_XlTable CF_MatTable',
DdeHelpString,
'data limits mode wave rate blocklen repeats control version',
'Topics Formats Help TopicItemList SysItems');
{Stringkonstanten als Antwort auf Anfragen auf System-Items}
DataS: array[eItem] of PChar=(
'data',
'limits',
'mode',
'wave',
'rate',
'blocklen',
'repeats',
'control',
'version');
DdeService='MIO';
const
DdeTopicS: array[etopic] of PChar=(
'SYSTEM',
'ADC',
'DAC');
var
Inst: LongInt; {Instanz-Variable ("Handle"), GLOBAL}
ServiceHsz: Hsz; {Stringhandle für Service (GPIB)}
TopicHsz: array[eTopic] of Hsz; {"System", "ADC", "DAC"}
SysHsz: array[eSysItem] of Hsz; {System-Stringhandles}
DdeConnections: Integer; {Anzahl aktiver Verbindungen}
CF_XlTable: Word; {Handle für Binärdaten}
CF_MatTable: Word;
const
tdtTable =$0010; {atype}
tdtFloat =$0001; {btype}
type
PExcelG=^TExcelG; {generischer Excel-Header}
TExcelG=record
gType, gSize: Word;
end;
PExcelA=^TExcelA; {Array-Header}
TExcelA=record
g: TExcelG; {zuerst generischer Header}
Rows, Cols: Word; {dann Dimensionen}
end;
PExcelHeader=^TExcelHeader;
TExcelHeader=record
a: TExcelA; {Header für Array-Dimensionen}
b: TExcelG; {Header für Doubles}
end;
PMatHeader=^TMatHeader;
TMatHeader=record
datatype: LongInt; {6=Double}
dimensions: LongInt; {Dimensionen, 0=Skalar}
dims: array[0..1] of LongInt;
end;
function DecodeDataType(SH:HSz):Byte;
{liefert 0 wenn String-Handle undekodierbar}
(* Aufbau des Formatbezeichners: [u|i]{8|16|32}[i|m] *)
{Standard ist "u" (für unsigned) und "i" (für Intel)}
var
sp: PChar;
dt: Byte;
s: TS31;
begin
dt:=0;
DecodeDataType:=0;
DdeQueryString(Inst,SH,s,sizeof(s),CP_WinAnsi);
sp:=AnsiUpper(s);
case sp^ of
'U': Inc(sp); {Standard}
'I': begin dt:=dt or ARG_vzb; Inc(sp); end;
end;
case sp^ of
'8': begin dt:=dt or ARG_U08; Inc(sp); end;
'1': if sp[1]='6' then begin dt:=dt or ARG_U16; Inc(sp,2); end;
'3': if sp[1]='2' then begin dt:=dt or ARG_U32; Inc(sp,2); end;
else exit; {ist Pflichtparameter}
end;
case sp^ of
'I': Inc(sp); {Standard}
'M': begin dt:=dt or ARG_bigend; Inc(sp); end;
end;
if sp^<>#0 then exit; {Fehler, wenn String hier nicht zu Ende!}
DecodeDataType:=dt;
end;
function MakeXlBuffer(k:Word):PDouble;
{Erzeugt einen Puffer fürs Excel-Clipboardformat, gefüllt mit dem Header,
Rückgabewert zeigt dahinter, Freigabe mit GlobalFree(PtrRec(k).Sel)}
var
ehp: PExcelHeader;
zh: Integer; {Anzahl der Zwischen-Header, immer 2 pro 32k?}
begin
zh:=k div $1FFF; {also max. $1FFF Doubles pro Block = 64K-8}
ehp:=GlobalAllocPtr(GMEM_Fixed,
sizeof(TExcelA)+LongMul(k,sizeof(Double)+zh*sizeof(TExcelG)));
if ehp<>nil then begin
with ehp^ do begin
a.g.gType:=tdtTable;
a.g.gSize:=4;
a.Rows:=1;
a.Cols:=k;
b.gType:=tdtFloat;
b.gSize:=minW(k,$1FFF)*8;
end;
Inc(ehp);
end;
MakeXlBuffer:=PDouble(ehp);
end;
function MakeMatBuffer(k:LongInt):PDouble;
var
mhp: PMatHeader;
dims: Integer;
begin
dims:=0; if k<>1 then Inc(dims); {null- oder eindimensional}
mhp:=GlobalAllocPtr(GMEM_Fixed,
LongMul(2+dims,sizeof(LongInt))+k*sizeof(Double));
if mhp<>nil then begin
mhp^.datatype:=6;
mhp^.dimensions:=dims;
if dims<>0 then mhp^.dims[0]:=k;
Inc(mhp);
if dims=0 then Dec(PLongInt(mhp));
end;
MakeMatBuffer:=PDouble(mhp);
end;
type
THugeDdeData=record
h: hDdeData; {für DdeCreateDataHandle}
l: LongInt; {Offset für DdeAddData, gleichzeitig Füllstand}
end;
procedure hddeput(var hd:THugeDdeData; dp:PChar; ds:Word);
{FAR-Daten an HUGE-DDE-Puffer anhängen}
begin
hd.h:=DdeAddData(hd.h,dp,ds,hd.l);
Inc(hd.l,ds);
end;
function Double2Dde(dp:PDouble;dlen:LongInt;SH:HSz;cf:Word):HDdeData;
{Wandelt Double-Array in DDE-Daten um}
label
except,except2;
var
readbuf,writebuf,ArgStr: PChar;
writebd: PDouble absolute writebuf;
havehash:Boolean;
z1,z2,e: Integer;
buf: TS15; {Mini-Puffer}
k: Word;
L: LongInt;
outdata: THugeDdeData;
begin
Double2Dde:=0;
outdata.h:=DdeCreateDataHandle(Inst,nil,256,0,SH,cf,0);
if outdata.h=0 then exit; {ENoMem}
outdata.l:=0;
repeat
ArgStr:=readbuf;
begin
k:=dlen;
if cf=CF_XlTable then begin
writebd:=MakeXlBuffer(k);
end else if cf=CF_MatTable then begin
writebd:=MakeMatBuffer(k);
end else begin
writebuf:=GlobalAllocPtr(GMEM_Fixed,dlen*24);
{max. 5 Bytes pro Byte: "-128 "}
end;
if writebuf=nil then goto except; {ENOMEM}
while k>0 do begin
if cf<>CF_Text then begin
writebd^:=L;
Inc(writebd);
end else begin
Str(L,TS31(Pointer(writebuf)^));
if z2>1 then lstrcat(writebuf,' '); {oder Tabulator->Zeilenvektor}
{Leider ist Matlab zu doof, daraus einen Zeilenvektor zu machen, so bleibt
nur der Umweg über str2num. Ich bin an dieser Stelle nicht gewillt,
für Matlab den Trenner 0D0A einzubauen; da wird ein Spaltenvektor draus...}
Inc(writebuf,lstrlen(writebuf));
end;
dec(z2);
dec(k);
end; {k Daten umgewandelt}
hddeput(outdata,Ptr(PtrRec(writebuf).sel,0),PtrRec(writebuf).ofs);
GlobalFreePtr(writebuf);
end;
until z2=0;
{bei TEXT bis zum ENDE-Signal lesen, bei Binärdaten bis zum Ende der Daten}
GlobalFreePtr(readbuf);
if cf=CF_Text then hddeput(outdata,'',1);
{im Fall von Text eine abschließende Null dazu}
Double2Dde:=outdata.h;
exit;
except:
GlobalFreePtr(readbuf);
except2:
DdeFreeDataHandle(outdata.h);
end;
function Long2Dde(l:LongInt;SH:HSz;cf:Word):HDdeData;
{wandelt eine einzelne Zahl ins DDE-Format (Excel oder String) um}
var
S: TS31;
pd: PDouble;
begin
if cf=CF_Text then begin
Str(L,S);
Long2Dde:=DdeCreateDataHandle(Inst,@s,lstrlen(s)+1,0,SH,cf,0);
end else begin
pd:=MakeXlBuffer(1);
pd^:=l;
PtrRec(pd).ofs:=0;
Long2Dde:=DdeCreateDataHandle(Inst,pd,12+8,0,SH,cf,0);
GlobalFreePtr(pd);
end;
end;
function Real2Dde(z:TReal;SH:HSz;cf:Word):HDdeData;
{wandelt eine einzelne Zahl ins DDE-Format (Excel oder String) um}
var
S: TS31;
pd: PDouble;
begin
if cf=CF_Text then begin
Str(z,S);
Real2Dde:=DdeCreateDataHandle(Inst,@s,lstrlen(s)+1,0,SH,cf,0);
end else begin
pd:=MakeXlBuffer(1);
pd^:=z;
PtrRec(pd).ofs:=0;
Real2Dde:=DdeCreateDataHandle(Inst,pd,12+8,0,SH,cf,0);
GlobalFreePtr(pd);
end;
end;
{hier: als Ersatz für TMemoryStream}
type
THugeData=record
h: THandle; {für GlobalAlloc}
p: PChar; {huge Lese- oder Schreibzeiger}
l: LongInt; {Lesen: Noch-Länge, Schreiben: Füllstand}
end;
function hinitw(var hd:THugeData; inisize:LongInt):Boolean;
begin
hd.h:=GlobalAlloc(0,inisize);
hd.p:=GlobalLock(hd.h);
hd.l:=0;
hinitw:=hd.h<>0;
end;
procedure hdonew(var hd: THugeData);
begin
GlobalUnlock(hd.h);
GlobalFree(hd.h);
end;
function hput(var hd:THugeData; inputs:PChar; inputl:Word):Boolean;
{FAR-Daten an HUGE-Puffer anfügen; dieser vergrößert sich ggf. selbst}
var
l: LongInt;
begin
hput:=false;
l:=hd.l+inputl;
if GlobalSize(hd.h)<l then begin
GlobalUnlock(hd.h);
hd.h:=GlobalReAlloc(hd.h,l+$8000,0); {32K extra}
if hd.h=0 then exit; {ENOMEM}
hd.p:=GlobalLock(hd.h);
IncHPL(hd.p,hd.l); {Zeiger neu setzen}
end;
hmemcpy(hd.p,inputs,inputl);
IncHP(hd.p,inputl);
hd.l:=l;
hput:=true;
end;
function hget(var hd:THugeData; outputs:PChar; outputl:Word):Word;
{FAR-Daten aus HUGE-Puffer holen, bei outputl=0 Suche nach Weißraum
PA: wirklich gelieferte Bytes; nullterminiert bei outputl=0}
procedure MoveChar;
begin
outputs^:=hd.p^;
Inc(outputs);
Inc(outputl);
IncHP(hd.p,1);
Dec(hd.l);
end;
begin
if outputl<>0 then begin
if outputl>hd.l then outputl:=LongRec(hd.l).lo;
if outputs<>nil then hmemcpy(outputs,hd.p,outputl);
IncHP(hd.p,outputl);
Dec(hd.l,outputl);
end else begin
while (hd.l>0) and (hd.p^<=' ') do MoveChar;
while (hd.l>0) and (hd.p^>' ') do MoveChar;
outputs^:=#0; {Terminierung setzen}
end;
hget:=outputl;
end;
function putDouble(var hd:THugeData; d:Double):Boolean;
{Steckt Double MemoryStream.
Aufgrund der glücklichen Lage, einen Intel-Prozessor zu haben,
macht die Daten-Größe hier kaum Probleme}
begin
putDouble:=hput(hd,PChar(@d),8);
end;
function Dde2Double(var dp:PDouble; var x,y:LongInt;data:HDdeData;cf:Word):Boolean;
{holt Daten aus <data>, interpretiert sie ggf. binär je nach cf
und macht daraus ein bis zu zweidimensionales Double-Array}
{Hier wird mit huge-Pointern gearbeitet! (igitt!)}
label except;
var
indata,outdata:THugeData;
eha: TExcelA;
ehg: TExcelG absolute eha;
Z: Double;
L: LongInt;
ec: Integer;
cw: Word;
s2: PChar;
ss: TS31;
{$IFDEF MSGBOX}
vsrec: record
x,y:LongInt;
end;
SM: TS255;
{$ENDIF}
begin
Dde2Double:=false;
x:=0; y:=1;
asm int 3 end;
indata.p:=DdeAccessData(data,@indata.l);
if hinitw(outdata,indata.l)=false {ungefähr gleiche Länge}
then goto except;
if cf=CF_XlTable then begin
L:=0;
while hget(indata,PChar(@ehg),4)=4 do begin
if ehg.gType=tdtTable then begin
if ehg.gSize<>4 then break; {Größen-Fehler}
if hget(indata,PChar(@eha.rows),4)<>4 then break;
Inc(L,LongMul(eha.rows,eha.cols)); {was an Doubles so folgt...}
end else if ehg.gType=tdtFloat then begin;
cw:=ehg.gsize;
if L<cw then break;
Dec(L,cw); {was an Doubles später kommt...}
while (cw>0) and (hget(indata,PChar(@Z),8)=8) do begin
if not hput(outdata,PChar(@Z),8) then goto except;
Inc(x);
Dec(cw);
end;
end else begin {unbekannter EXCEL-Binärtyp: übergehen!}
if hget(indata,nil,ehg.gsize)<>ehg.gsize then break;
end;
end;
end else if cf=CF_MatTable then begin
x:=1;
if hget(indata,PChar(@L),4)<>4 then goto except;
if L<>6 then goto except; {Falsches Kennbyte}
if hget(indata,PChar(@L),4)<>4 then goto except;
if L>2 then goto except; {Zu viele Dimensionen}
if L<>0 then begin
if hget(indata,PChar(@x),4)<>4 then goto except;
if L>1 then begin
if hget(indata,PChar(@y),4)<>4 then goto except;
end;
end;
L:=x*y;
while L<>0 do begin
if hget(indata,PChar(@Z),8)<>8 then goto except;
if not hput(outdata,PChar(@Z),8) then goto except;
Dec(L);
end;
end else if cf=CF_Text then begin
while hget(indata,ss,0)>0 do begin
if S2Real(ss,Z) and (not PutDouble(outdata,Z)) then goto except;
Inc(x);
end;
end;
GlobalUnlock(outdata.h);
outdata.p:=GlobalLock(outdata.h); {Zeiger zurückstellen}
dp:=PDouble(outdata.p);
{ hdonew(outdata);}
DdeUnaccessData(data);
Dde2Double:=true; {OK}
{$IFDEF MSGBOX}
vsrec.x:=x;
vsrec.y:=y;
wvsprintf(SM,'Erkannte Array-Dimensionen: x=%ld, y=%ld',vsrec);
MessageBox(0,SM,'MIO_DDE Dde2Double',0);
{$ENDIF}
exit;
except:
DdeUnaccessData(data);
end;
function Dde2Real(var Z:TReal;data:HDdeData;cf:Word):Boolean;
{holt Daten aus <data>, interpretiert sie ggf. binär je nach cf
und macht daraus Z}
label finally;
type
POneReal=^TOneReal;
TOneReal=record
eh: TExcelHeader;
zz: Double;
end;
var
indata: PChar;
begin
Dde2Real:=false;
indata:=DdeAccessData(data,nil);
if cf<>CF_Text then with POneReal(indata)^ do begin
if eh.a.g.gType<>tdtTable then goto finally;
if eh.a.g.gSize<>4 then goto finally;
if eh.a.rows=0 then goto finally;
if eh.a.cols=0 then goto finally;
if eh.b.gType<>tdtFloat then goto finally;
if eh.b.gSize<8 then goto finally;
Z:=zz;
Dde2Real:=true;
end else begin {CF_Text}
Dde2Real:=S2Real(indata,Z);
end;
finally:
DdeUnaccessData(data);
end;
var
MainWnd: HWnd;
procedure ChangeDdeDisplay;
var
s: TS31;
vsrec:record
s: PChar;
i: Integer;
end;
begin
vsrec.s:=AppTitle;
vsrec.i:=DdeConnections;
wvsprintf(s,'%s [%d]',vsrec);
SetWindowText(MainWnd,s);
end;
procedure DdeError(Code:Integer);
begin
MBox(MainWnd,102,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 atoi(var S:PChar):Integer;
{Numerisch wandeln, String-Zeiger vorrücken}
var
i,ec,ec2:Integer;
ch:Char;
begin
Val(S,i,ec);
if ec<>0 then begin
if ec>1 then begin
Dec(ec);
ch:=S[ec];
S[ec]:=#0; {Patch}
Val(S,i,ec2); {i sollte nun stimmen}
S[ec]:=ch; {Rückpatch}
Inc(S,ec); {S vorrücken aufs "falsche" Zeichen}
end;
end else Inc(S,lstrlen(S)); {S vorrücken aufs String-Ende}
atoi:=i;
end;
function GetDataNumber(Hsz2: Hsz; Fmt:Word; Chan: array of ShortInt;
var ChanHigh:Integer):eItem;
label raus,fail;
var
I: eItem;
from_ch,to_ch:Integer;
sp: PChar;
ch_hi: Integer;
S:TS31;
{$IFDEF MSGBOX}
S2: TS255;
{$ENDIF}
begin
if (Fmt=CF_Text) or (Fmt=CF_XlTable) or (Fmt=CF_MatTable) then begin
{wenn passendes HSZ1(Topic) und passendes Format(Text), dann weiter}
ch_hi:=-1;
from_ch:=0;
DdeQueryString(Inst,Hsz2,S,sizeof(s),CP_WinAnsi);
for i:=LOW(eItem) to HIGH(eItem) do begin
if lstrcmp1(dataS[i],S,lstrcmpi)=0 then begin
sp:=S+lstrlen(dataS[i]); {wo die Zahlen losgehen können}
while sp^<>#0 do begin
while sp^ in [#9,' ',',',';'] do Inc(sp); {Weißraum und Trennzeichen übergehen}
if sp^='-' then begin
Inc(sp);
to_ch:=atoi(sp);
if Word(to_ch)>HIGH(chan) then goto fail;
while from_ch<=to_ch do begin
if ch_hi>=HIGH(chan) then goto fail;
Inc(ch_hi);
Chan[ch_hi]:=from_ch;
ChanHigh:=ch_hi; {ohne Zahlen bleibt's unverändert!}
Inc(from_ch);
end;
end else begin
if ch_hi>=HIGH(chan) then goto fail;
from_ch:=atoi(sp);
if Word(from_ch)>HIGH(chan) then goto fail;
if ch_hi>=HIGH(chan) then goto fail;
Inc(ch_hi);
Chan[ch_hi]:=from_ch;
ChanHigh:=ch_hi; {ohne Zahlen bleibt's unverändert!}
Inc(from_ch);
end;
end;
if ChanHigh<0 then goto fail; {ungesetzt? Fehler!}
goto raus;
end;
end;
end;
fail:
ShortInt(i):=-1;
raus:
GetDataNumber:=i;
{$IFDEF MSGBOX}
if i in [LOW(eItem)..HIGH(eItem)] then begin
sp:=s2;
Inc(SP,wvsprintf(SP,'letzter Kanal: %d'#10,ChanHigh));
for ch_hi:=0 to ChanHigh do begin
Inc(SP,wvsprintf(SP,'%d ',Chan[ch_hi]));
end;
MessageBox(0,s2,'MIO_DDE GetDataNumber',0);
end;
{$ENDIF}
end;
function GetSystemNumber(Hsz2: Hsz; Fmt:Word):eSysItem;
label raus;
var
I: eSysItem;
begin
if Fmt<>CF_Text then exit;
for I:=LOW(eSysItem) to HIGH(eSysItem) do
if DdeCmpStringHandles(Hsz2,SysHsz[I])=0 then goto raus;
ShortInt(I):=-1;
raus:
GetSystemNumber:=I;
end;
function GetUD(hszTopic:HSZ):eTopic;
label raus;
var
I: eTopic;
begin
for I:=LOW(TopicHsz) to HIGH(TopicHsz) do
if TopicHsz[i]=hszTopic then goto raus;
ShortInt(I):=-1;
raus:
GetUD:=I;
end;
function Get_Limits(xp:PDouble; l:LongInt; var xa,xe:Double):Boolean;
begin
xa:=100; xe:=-100;
while l<>0 do begin
if xa>xp^ then xa:=xp^; {Minimum suchen}
if xe<xp^ then xe:=xp^; {Maximum suchen}
IncHP(PChar(xp),sizeof(Double));
Dec(l);
end;
Get_Limits:=(-10<=xa) and (xe<=10);
{$IFDEF ERRMSG}
if (xa<10) or (xe>10) then begin
MessageBox(0,'Bereich zu gro▀!','MIO_DDE Get_Limits',0);
end;
{$ENDIF}
end;
function Get_Polarity(xp:PDouble; l:LongInt; var pol:Boolean):Boolean;
var
xa,xe:Double;
begin
Get_Polarity:=Get_Limits(xp,l,xa,xe);
pol:=xa<0; {BIpolar wenn Minimum negativ}
end;
function Get_Gain(xp:PDouble; l:LongInt; var gain:Byte; var pol:Boolean):Boolean;
const
gainEnd: array[0..6] of Single=(10,5,2,1,0.5,0.2,0.1);
gainVal: array[0..6] of Byte=(1,2,5,10,20,50,100);
var
xa,xe:Double;
im: Integer;
begin
Get_Gain:=Get_Limits(xp,l,xa,xe);
pol:=xa<0;
xa:=abs(xa); xe:=abs(xe);
if xe<xa then xe:=xa; {vzl. Maximum in XE ermitteln}
for im:=0 to 6 do begin
if xe>gainEnd[im] then break;
gain:=gainVal[im];
end;
end;
function HandleError(ec:Integer):Boolean;
begin {Wohin soll bloß das Output gehen??}
HandleError:=false;
end;
var
adc_channels: array[0..15] of ShortInt; {enthält aktuelle Zuordnung!}
adc_channel_high: Integer;
adc_bipolar: array[0..15] of Boolean; {hier statische Zuordnung!}
adc_gain: array[0..15] of Byte;
dac_channels: array[0..1] of ShortInt;
dac_channel_high: Integer;
dac_bipolar: array[0..1] of Boolean;
function DdeCallback(CallType,Fmt:Word; Conv:hConv; HSz1,HSz2:HSz;
aData:hDdeData; Data1,Data2: LongInt): hDdeData; export;
const
ConnectingUD:Integer=0; {zum Hinüberretten nach XTYP_Connect_Confirm}
var
SysItemNum: eSysItem;
ItemNum: eItem;
i,k: Integer;
W: Word;
Z: TReal;
S: TS31;
sp: PChar;
ok: Boolean;
ud: eTopic;
ec: Integer;
bdidx,pad,sad,tmo,eot,eos:Integer;
by: Byte;
pd: PDouble;
x,y: LongInt;
um: Integer;
begin
DdeCallback:=0;
case CallType of
XTYP_Connect: begin
case GetUD(hsz1) of
LOW(eTopic)..HIGH(eTopic): begin
Inc(DdeConnections);
ChangeDdeDisplay;
DdeCallback:=1; {Verbindung okay!}
end;
end;
end;
XTYP_Disconnect: begin
Dec(DdeConnections);
ChangeDdeDisplay;
end;
XTYP_Request: begin
ud:=GetUD(hsz1);
case ud of
SYS: begin
SysItemNum:=GetSystemNumber(hsz2,fmt);
case SysItemNum of
LOW(eSysItem)..HIGH(eSysItem): begin
sp:=DdeStrings[SysItemNum];
DdeCallback:=DdeCreateDataHandle(Inst,sp,
lstrlen(sp)+1,0,hsz2,CF_Text,0);
end;
end;
end;
ADC: begin
ItemNum:=GetDataNumber(hsz2,fmt,adc_channels,adc_channel_high);
case ItemNum of
DATA: begin
by:=DecodeDataType(hsz2);
end;
LIMITS:;
MODE:;
WAVE:;
RATE:;
BLOCKLEN:;
REPEATS:; {keine Wiederholungen möglich!}
CONTROL:;
VERSION: begin
DdeCallback:=DdeCreateDataHandle(Inst,
PChar('1.0, h#s 05/01, 16bit National Instruments'),
43,0,hsz2,CF_Text,0);
end;
end{case ItemNum};
end;
DAC: begin
ItemNum:=GetDataNumber(hsz2,fmt,dac_channels,dac_channel_high);
case ItemNum of
DATA:;
LIMITS:;
MODE:;
WAVE:; {kein Wave-Input}
RATE:;
BLOCKLEN:;
REPEATS:; {keine Wiederholungen möglich!}
CONTROL:;
end;
end;
end;
end;
XTYP_Poke: begin
DdeCallback:=DDE_FNotProcessed; {Pessimistisch}
ud:=GetUD(hsz1);
case ud of
SYS:;
ADC: begin
ItemNum:=GetDataNumber(hsz2,fmt,adc_channels,adc_channel_high);
Dde2Double(pd,x,y,aData,fmt);
if y=adc_channel_high+1 then case ItemNum of
LIMITS: begin
OK:=true;
for i:=0 to adc_channel_high do begin
k:=adc_channels[i];
OK:=Get_Gain(pd,x,adc_gain[k],adc_bipolar[k]) and OK;
end;
if OK then DdeCallback:=DDE_FAck;
end;
MODE: if x=1 then begin
z:=pd^;
if (0<=z) and (z<=2) then begin
for i:=0 to adc_channel_high do begin
k:=adc_channels[i];
AI_Configure(BOARD,k,Round(z),0,not adc_bipolar[k],0);
end;
DdeCallback:=DDE_FAck;
end;
end;
RATE:;
BLOCKLEN:;
CONTROL:;
end{case};
GlobalFreePtr(pd);
end;
DAC: begin
ItemNum:=GetDataNumber(hsz2,fmt,dac_channels,dac_channel_high);
Dde2Double(pd,x,y,aData,fmt);
if y=dac_channel_high+1 then case ItemNum of
DATA: if x=1 then begin
for i:=0 to dac_channel_high do begin
k:=dac_channels[i];
ec:=AO_VWrite(BOARD,k,pd^);
if ec=-71 then begin {outOfRangeErr}
if pd^>5
then if dac_bipolar[k] then um:= 32767 else um:=Integer(65535)
else if dac_bipolar[k] then um:=-32768 else um:=0;
ec:=AO_Write(1,k,um);
end;
IncHP(PChar(pd),8);
end;
if dac_channel_high<>0 then AO_Update(1); {in einem Schlag!}
if HandleError(ec) then DdeCallback:=DDE_FAck;
end;
LIMITS: begin
OK:=true;
for i:=0 to dac_channel_high do begin
k:=dac_channels[i];
OK:=Get_Polarity(pd,x,dac_bipolar[k]) and OK;
end;
if OK then DdeCallback:=DDE_FAck;
end;
MODE: if (x=1) or (x=2) then begin
z:=pd^; IncHP(PChar(pd),8);
if (0<=z) and (z<=2) then begin
for i:=0 to dac_channel_high do begin
k:=dac_channels[i];
if x=1
then AO_Configure(BOARD,k,not dac_bipolar[k],0,10 ,Round(z))
else AO_Configure(BOARD,k,not dac_bipolar[k],1,pd^,Round(z));
end;
DdeCallback:=DDE_FAck;
end;
end;
WAVE: begin
end;
RATE:;
REPEATS:;
CONTROL:;
end;
GlobalFreePtr(pd);
end;
end;
end;
end;
end;
procedure DDEInit;
var
W: Word;
I: eTopic;
J: eSysItem;
begin
if DdeInitialize(Inst,DdeCallBack,CBF_Skip_Registrations
or CBF_Skip_Unregistrations
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 I:=LOW(eTopic) to HIGH(eTopic)
do TopicHsz[I]:=CreateStringHandle(DdeTopicS[I]);
for J:=LOW(eSysItem) to HIGH(eSysItem)
do SysHsz[J]:=CreateStringHandle(DdeSystemS[J]);
OemToAnsi(DdeStrings[HELP],DdeStrings[HELP]);
DdeConnections:=0;
if DdeNameService(Inst,ServiceHsz,0,DNS_Register)=0
then DdeError(3);
end;
procedure DdeDone;
var
I: eTopic;
J: eSysItem;
begin
DdeNameService(Inst,ServiceHsz,0,DNS_Unregister);
for J:=LOW(eSysItem) to HIGH(eSysItem)
do FreeStringHandle(SysHsz[J]);
for I:=LOW(eTopic) to HIGH(eTopic)
do FreeStringHandle(TopicHsz[i]);
FreeStringHandle(ServiceHsz);
DdeUninitialize(Inst);
end;
var
traydata: TNotifyIconData;
function MainWndProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):LongInt; export;
var
lPar: LongRec absolute lParam;
P: TPoint;
m,sysm: HMenu;
calldef: Boolean;
s: TS31;
begin
calldef:=false;
MainWndProc:=0;
case Msg of
WM_Create: begin
sysm:=GetSystemMenu(Wnd,false);
DeleteMenu(sysm,SC_Maximize,0);
DeleteMenu(sysm,SC_Restore,0);
DeleteMenu(sysm,SC_Size,0);
DeleteMenu(sysm,SC_Minimize,0);
LoadString(Seg(HInstance),101,s,sizeof(s)); {Über...}
InsertMenu(sysm,0,MF_ByPosition or MF_String,$1F0,s);
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=SW_Minimize) or (CmdShow=SW_ShowMinimized)
or (CmdShow=SW_ShowMinNoActive)
then PostMessage(Wnd,WM_SysCommand,$1E0,0);
end;
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}
Shell_NotifyIcon(NIM_Notify,traydata);
end;
calldef:=true;
end;
WM_SysCommand: case wParam and $FFF0 of
$1F0: MBox1(Wnd,100{about},nil);
$1E0: begin
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;
LongRec(traydata.hIcon).lo:=GetClassWord(Wnd,GCW_HIcon);
GetWindowText(Wnd,traydata.szTip,sizeof(traydata.szTip));
Shell_NotifyIcon(NIM_Add,traydata);
ShowWindow(Wnd,SW_Hide);
end;
$1D0: WinHelp(Wnd,HelpFileName,HELP_Index,0);
else calldef:=true;
end;
WM_QueryOpen: ; {nur Icon}
WM_User: case lParam of
WM_LButtonDown: begin
{ShowWindow(Wnd,SW_ShowMinimized);}
MBox1(0,100{about},nil);
{ShowWindow(Wnd,SW_Hide);}
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: SendMessage(Wnd,WM_Close,0,0);
100: begin
ShowWindow(Wnd,SW_Minimize);
Shell_NotifyIcon(NIM_Delete,traydata);
end;
900: WinHelp(Wnd,HelpFileName,HELP_Index,0);
999: MBox1(Wnd,100{about},nil);
end;
WM_Close: begin
if (DdeConnections>0)
and (MBox1(Wnd,109{WarnClose},PChar(DdeConnections))<>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);
else calldef:=true;
end;
if calldef then MainWndProc:=DefWindowProc(Wnd,Msg,wParam,lParam);
end;
const
wc: TWndClass=(
style: CS_VRedraw or CS_HRedraw;
lpfnWndProc: @MainWndProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: Seg(HInstance);
hIcon: 0;
hCursor: 0;
hbrBackground: COLOR_Window;
lpszMenuName: nil;
lpszClassName: AppName);
var
Msg:TMsg;
begin
if HPrevInst<>0 then begin
wc.hIcon:=FindWindow(AppName,nil);
if wc.hIcon<>0 then begin
SetActiveWindow(wc.hIcon);
end;
exit;
end;
wc.hIcon:=LoadIcon(Seg(HInstance),MakeIntResource(100));
wc.hCursor:=LoadCursor(0,IDC_Arrow);
RegisterClass(wc);
MainWnd:=CreateWindow(AppName,AppTitle,
WS_OverlappedWindow,
0,0,0,0,
0,0,Seg(HInstance),nil);
ShowWindow(MainWnd,SW_ShowMinimized);
WUtils.StdMBoxTitle:=AppTitle;
CF_XlTable:=RegisterClipboardFormat('XlTable');
CF_MatTable:=RegisterClipboardFormat('MatTable');
DdeInit;
while GetMessage(Msg,0,0,0) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
DdeDone;
end.
| Detected encoding: OEM (CP437) | 1
|
|
|