program ddegpib;
{$D Universelle GPIB-zu-DDE-Schnittstelle h#s 08/02}
{hier: für National Instruments GPIB.DLL}
{$F-,A+,G+,K+,W-}
{$I-,Q-,R-,S-}
{$V+,B-,X+,T+,P+}
{$M 8192,0}
{$N+}
{$R ddegpib}
uses WinProcs,WinTypes,Win31,Ddeml, TpwGpib,WUtils,Parser,Tray16;
const
AppName='DDEGPIB';
AppTitle='DDE<->GPIB';
HelpFileName='DDEGPIB.HLP'; {wenn überhaupt}
{************* 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;
const
CI_ibsta: array[0..15] of TConstItem=(
(k:-$8000; s: 'ERR'),
(k: $4000; s: 'TIMO'),
(k: $2000; s: 'END'),
(k: $1000; s: 'RQS'),
(k: $0800; s: 'SRQI'),
(k: $0400; s: 'SPOLL'),
(k: $0200; s: 'EVENT'),
(k: $0100; s: 'CMPL'),
(k: $0080; s: 'LOK'),
(k: $0040; s: 'REM'),
(k: $0020; s: 'CIC'),
(k: $0010; s: 'ATN'),
(k: $0008; s: 'TACS'),
(k: $0004; s: 'LACS'),
(k: $0002; s: 'DTAS'),
(k: $0001; s: 'DCAS'));
CI_ibask: array[0..8] of TConstItem=(
(k: $0001; s: 'PAD'),
(k: $0002; s: 'SAD'),
(k: $0003; s: 'TMO'),
(k: $0004; s: 'EOT'),
(k: $0006; s: 'READDR'),
(k: $000C; s: 'EOSrd'),
(k: $000D; s: 'EOSwrt'),
(k: $000E; s: 'EOScmp'),
(k: $000F; s: 'EOSchar'));
NI_Waits: array[0..17] of Single=(
1E6, 10E-6,30E-6,100E-6,300E-6,
1E-3,3E-3,10E-3,30E-3,100E-3,300E-3,
1,3,10,30,100,300,1000);
function sec2NI_Wait(x:Double):Integer;
{Es wird ggf. aufgerundet}
var
i: Integer;
begin
if (x<0) or (x>1000) then i:=0
else for i:=1 to 17 do if x<=NI_Waits[i] then break;
sec2NI_Wait:=i;
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}
const
DdeLastSystem=5; {Anzahl der System-Items}
DdeNumData=8;
DdeSystemS: array[0..DdeLastSystem]of PChar=(
'System','Topics','Formats','Help','TopicItemList','SysItems');
{System-Item-Stringkonstanten}
DdeStrings:array[0..5]of PChar=(nil,'<various>','CF_TEXT CF_XlTable',
DdeHelpString,
'data "config TMO" "config EOT" iberr ibsta ibcnt ibrsp version',
'Topics Formats Help TopicItemList SysItems');
{Stringkonstanten als Antwort auf Anfragen auf System-Items}
DataS: array[0..DdeNumData] of PChar=
(nil,'data','config TMO','config EOT','iberr','ibsta','ibcnt','ibrsp','version');
DdeService='GPIB';
var
Inst: LongInt; {Instanz-Variable ("Handle"), GLOBAL}
ServiceHsz: Hsz; {Stringhandle für Service (GPIB)}
DataHsz: array[0..DdeNumData] of Hsz; {Stringhandles für normale Items}
SysHsz: array[0..DdeLastSystem]of Hsz; {System-Stringhandles}
DdeConnections: Integer; {Anzahl aktiver Verbindungen}
CF_XlTable: Word; {Handle für Binärdaten}
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;
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;
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 Gpib2Dde(ud:Integer;dt:Byte;SH:HSz;cf:Word):HDdeData;
{holt Daten vom GPIB-Gerät, interpretiert sie ggf. binär je nach dt
und macht daraus ASCII- oder Binärdaten je nach cf
Einschränkung: Alle Datenstrukturen sind auf 64KB begrenzt?}
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
Gpib2Dde:=0;
outdata.h:=DdeCreateDataHandle(Inst,nil,256,0,SH,cf,0);
if outdata.h=0 then exit; {ENoMem}
outdata.l:=0;
{256 Bytes voraussichtlich, kann aber auch mehr werden}
readbuf:=GlobalAllocPtr(GMEM_Fixed,$1000);
if readbuf=nil then goto except2; {ENoMem}
havehash:=false;
repeat
ArgStr:=readbuf;
ibrd(ud,ArgStr^,$1000);
{temporär BEGIN
if ibsta and ERR <>0 then begin
lstrcpy(readbuf,'#209'#1#2#3#4#5#6#7#8#9#13);
ibsta:=CMPL;
ibcnt:=lstrlen(readbuf);
end;
{temporär END}
if ibsta and ERR <>0 then goto except;
if (dt<>0) and (not havehash) then begin
while (ibcnt>0) and (ArgStr^<>'#') do begin
Inc(ArgStr); Dec(ibcnt); {ein "#" muß auftreten}
end;
if ibcnt<2 then goto except; {Fehler! Kein Doppelkreuz-Zeichen!}
Inc(ArgStr); Dec(ibcnt);
z1:=Integer(ArgStr^)-Ord('0'); {danach folgt eine Ziffer,
die die Anzahl der folgenden Ziffern festlegt, welche die Anzahl
der DatenBYTES beinhaltet}
Inc(ArgStr); Dec(ibcnt);
{ lstrcpyn(buf,ArgStr,z1+1); {lt. MSDN-CD terminiert lstrcpyn immer!}
{Diese Windows-Funktion ist aber auch bescheuert!!! Sie sucht das Stringende
im Quellstring, und wenn da keins ist (sondern ungültige Adressen),
dann kopiert diese Funktion gar nichts!}
move(ArgStr^,buf,z1); buf[z1]:=#0;
Val(buf,z2,e); {für die numerische Konvertierung}
Inc(ArgStr,z1); Dec(ibcnt,z1);
if e<>0 then goto except; {ungültige Folgeziffern}
if z2 mod (dt and $0F) <>0 then goto except; {Anzahl "krumm"}
z2:=z2 div (dt and $0F); {Anzahl der Zahlen}
HaveHash:=true;
end;
{4 Fälle gibt es, nur dt=0 und cf=CF_Text ohne Konvertierung}
if dt<>0 then begin
k:=ibcnt div (dt and $0F);
if k>z2 then k:=z2; {evtl. terminierende Linefeeds weglassen}
if cf<>CF_Text then begin
writebd:=MakeXlBuffer(k);
end else begin
writebuf:=GlobalAllocPtr(GMEM_Fixed,ibcnt*5);
{max. 5 Bytes pro Byte: "-128 "}
end;
if writebuf=nil then goto except; {ENOMEM}
while k>0 do begin
asm
mov bl,[dt]
cld
@@l: les si,[ArgStr]
xor dx,dx
test bl,ARG_U08
jnz @@b
test bl,ARG_U16
jnz @@w
seges lodsw
xchg dx,ax
seges lodsw
xchg dx,ax
test bl,ARG_bigend
jz @@z
xchg ah,al
xchg dx,ax
xchg ah,al
jmp @@z
@@b: seges lodsb
mov ah,0
test bl,ARG_vzb
jz @@z
cbw
jmp @@z1
@@w: seges lodsw
test bl,ARG_bigend
jz @@w1
xchg al,ah
@@w1: test bl,ARG_vzb
jz @@z
@@z1: cwd
@@z: {nun in DX:AX die Zahl}
mov word ptr [ArgStr],si
mov LongRec[L].lo,ax
mov LongRec[L].hi,dx
end;
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 else begin
z2:=1;
if cf<>CF_Text then begin
writebd:=MakeXlBuffer($3FF0); {knapp 64K vorab}
ArgStr[ibcnt]:=#0; {zum Parsen terminieren}
while ArgStr^<>#0 do begin
Val(NextItem(ArgStr,0,DELIM_Whitespace),PDouble(writebuf)^,e);
if e=0 then begin {nur numerisches einlesen lassen}
Inc(writebuf,8);
end;
end;
PExcelHeader(Ptr(PtrRec(writebuf).sel,0))^.b.gSize:=
PtrRec(writebuf).ofs-12; {wirkliche Datenmenge eintragen}
PExcelHeader(Ptr(PtrRec(writebuf).sel,0))^.a.Cols:=
(PtrRec(writebuf).ofs-12) div 8;
hddeput(outdata,Ptr(PtrRec(writebuf).sel,0),PtrRec(writebuf).ofs);
GlobalFreePtr(writebuf);
end else begin
hddeput(outdata,readbuf,ibcnt);
end;
end;
until (ibsta and EEND <>0) or (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}
Gpib2Dde:=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 putlong(var hd:THugeData; L:LongInt; dt:Byte):Boolean;
{Steckt Byte, Word oder LongInt (je nach dt) in den MemoryStream.
Aufgrund der glücklichen Lage, einen Intel-Prozessor zu haben,
macht die Daten-Größe hier kaum Probleme}
begin
if dt and ARG_bigend <>0 then case dt and $F of
ARG_U16: LongRec(L).lo:=Swap(LongRec(L).lo);
ARG_U32: asm
mov ax,LongRec[L].lo
xchg ah,al
xchg LongRec[L].hi,ax
xchg ah,al
mov LongRec[L].lo,ax
end;
end;
putlong:=hput(hd,PChar(@L),dt and $F);
end;
function hstrlen(s:PChar):LongInt; assembler;
asm push di
xor ax,ax
xor bx,bx
xor dx,dx {DX:BX=Zähler}
les di,[s]
mov cx,di
neg cx {Anzahl verbleibender Bytes im Segment}
jnz @@0
@@l: mov cx,8000h {Hälfte, wenn volle 64K}
@@0: add bx,cx
adc dx,ax
repne scasb {Null suchen}
jz @@1 {gefunden: DI zeigt hinter die Null}
or di,di {nicht gefunden, DI+=CX}
jnz @@l {noch kein neues Segment...}
mov di,es
add di,offset __AHIncr
mov es,di
xor di,di {ohne Prüfung des Segment-Limits}
jmp @@l
@@1: {selbst wenn die Null sofort kommt, ist CX dekrementiert...}
pop di
inc cx
sub bx,cx
sbb dx,ax
xchg bx,ax {Ergebnis nach DX:AX}
end;
function Dde2Gpib(ud:Integer;dt:Byte;data:HDdeData;cf:Word):HDdeData;
{holt Daten aus <data>, interpretiert sie ggf. binär je nach cf
und macht daraus ASCII- oder Binärdaten je nach dt
und schreibt sie auf ud}
{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;
ss: TS31;
s2: PChar;
begin
Dde2Gpib:=DDE_FNotProcessed;
L:=0; {Gesamtzahl DOUBLEs}
indata.p:=DdeAccessData(data,@indata.l);
if ((cf<>CF_Text) or (dt<>0))
and (hinitw(outdata,indata.l)=false) {ungefähr gleiche Länge}
then goto except;
if cf<>CF_Text then begin
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 dt<>0 then begin
if not PutLong(outdata,Round(Z),dt) then goto except;
end else begin
Str(Z,ss);
if indata.l>0 then lstrcat(ss,' ');
if not hput(outdata,ss,lstrlen(ss)) then goto except;
end;
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 begin {CF_Text}
if dt>0 then begin
while hget(indata,ss,0)>0 do begin
if S2Real(ss,Z) and (not PutLong(outdata,Round(Z),dt)) then goto except;
end;
end else begin {Text nur bis zur terminierenden Null}
ibwrt(ud,indata.p^,hstrlen(indata.p));
end;
end;
if (cf<>CF_Text) or (dt<>0) then begin
GlobalUnlock(outdata.h);
outdata.p:=GlobalLock(outdata.h); {Zeiger zurückstellen}
ibwrt(ud,outdata.p^,outdata.l);
hdonew(outdata);
end;
DdeUnaccessData(data);
if ibsta and ERR =0 then Dde2Gpib:=DDE_FAck; {OK}
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;
{$IFDEF HaveWindow}
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;
{$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 GetDataNumber(Hsz2: Hsz; Fmt:Word):Integer;
var
I:Integer;
begin
if (Fmt=CF_Text) or (Fmt=CF_XlTable) then begin
{wenn passendes HSZ1(Topic) und passendes Format(Text), dann weiter}
if Hsz2=0 then begin GetDataNumber:=1; exit; end; {leere Zeichenkette}
for i:=1 to DdeNumData do begin
if DdeCmpStringHandles(Hsz2,DataHsz[i])=0 then begin
GetDataNumber:=i; exit;
end;
end;
end;
GetDataNumber:=0;
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 GetUD(Conv:HConv):Integer;
{holt zugeortnetes GPIB-Handle aus Conv heraus}
var
ci: TConvInfo;
begin
DdeQueryConvInfo(Conv,QID_Sync,@ci);
GetUD:=ci.hUser;
end;
function DdeCallback(CallType,Fmt:Word; Conv:hConv; HSz1,HSz2:HSz;
Data:hDdeData; Data1,Data2: LongInt): hDdeData; export;
const
ConnectingUD:Integer=0; {zum Hinüberretten nach XTYP_Connect_Confirm}
var
ItemNum: Integer;
W: Word;
Z: TReal;
S: TS31;
sp: PChar;
ok: Boolean;
ud,ec: Integer;
bdidx,pad,sad,tmo,eot,eos:Integer;
by: Byte;
begin
DdeCallback:=0;
case CallType of
XTYP_Connect: begin
if DdeCmpStringHandles(Hsz1,SysHsz[0])=0 then begin {1. "system"}
ConnectingUD:=0;
end else begin
DdeQueryString(Inst,Hsz1,s,sizeof(s),CP_WinAnsi);
ud:=ibfind(s); {2. "devname"}
if ud<=0 then begin {3. "bd pad [sad tmo eot eos]"}
sp:=s;
Val(NextItem(sp,Word('"'),DELIM_Whitespace),bdidx,ec);
Val(NextItem(sp,Word('"'),DELIM_Whitespace),pad,ec);
if ec<>0 then exit; {Fehler!}
Val(NextItem(sp,Word('"'),DELIM_Whitespace),sad,ec);
Val(NextItem(sp,Word('"'),DELIM_Whitespace),Z,ec);
if ec=0 then tmo:=sec2NI_Wait(Z) else tmo:=3; {Default: 3 Sekunden}
Val(NextItem(sp,Word('"'),DELIM_Whitespace),eot,ec);
if ec<>0 then eot:=1; {Default: EOT ein}
Val(NextItem(sp,Word('"'),DELIM_Whitespace),eos,ec);
if ec<>0 then eos:=$100A; {Default: 8bit LF}
ud:=ibdev(bdidx,pad,sad,tmo,eot,eos);
if ud<=0 then exit; {4. Fehler!}
end;
ConnectingUD:=ud;
end;
DdeCallback:=1; {Verbindung okay!}
end;
XTYP_Connect_Confirm: begin
DdeSetUserHandle(Conv,QID_Sync,ConnectingUD); {nachträgliche Zuordnung!}
Inc(DdeConnections);
{$IFDEF HaveWindow}
ChangeDdeDisplay;
{$ENDIF}
end;
XTYP_Disconnect: begin
ud:=GetUD(Conv); {Deskriptor holen}
if ud>0 then ibonl(ud,0);
Dec(DdeConnections);
{$IFDEF HaveWindow}
ChangeDdeDisplay;
{$ENDIF}
end;
XTYP_Request: begin
ud:=GetUD(Conv); {Deskriptor holen}
if ud>0 then begin
ItemNum:=GetDataNumber(hsz2,fmt);
case ItemNum of
0: begin {hier: Binärdaten?}
by:=DecodeDataType(hsz2);
if by>0 then DdeCallback:=Gpib2Dde(ud,by,hsz2,fmt);
end;
1: DdeCallback:=Gpib2Dde(ud,0,hsz2,fmt); {ibrd,ibwrt}
2: begin {ibask TMO}
ibask(ud,TMO,ec);
DdeCallback:=Real2Dde(NI_Waits[ec],hsz2,fmt);
end;
3: begin {ibask EOT}
ibask(ud,EOT,ec);
DdeCallback:=Long2Dde(ec,hsz2,fmt);
end;
4: DdeCallback:=Long2Dde(iberr,hsz2,fmt);
5: DdeCallback:=Long2Dde(ibsta,hsz2,fmt);
6: DdeCallback:=Long2Dde(ibcntl,hsz2,fmt);
7: begin
ibrsp(ud,ec);
DdeCallback:=Long2Dde(ec,hsz2,fmt);
end;
8: begin
DdeCallback:=DdeCreateDataHandle(Inst,
PChar('1.0, h#s 12/00, 16bit National Instruments'),
43,0,hsz2,CF_Text,0);
end;
end{case ItemNum};
end else begin
ItemNum:=GetSystemNumber(hsz2,fmt);
if ItemNum>0 then begin
DdeCallback:=DdeCreateDataHandle(Inst,DdeStrings[ItemNum],
lstrlen(DdeStrings[ItemNum])+1,0,SysHsz[ItemNum],CF_Text,0);
end;
end;
end;
XTYP_Execute: begin
DdeCallback:=DDE_FNotProcessed;
ud:=GetUD(Conv); {Deskriptor holen}
if ud>0 then begin
S[DdeGetData(Data,@S,sizeof(S)-1,0)]:=#0;
DdeCallback:=DDE_FAck;
if lstrcmpi(S,'ibwait')=0 then ibwait(ud,TIMO or CMPL)
else if lstrcmpi(S,'ibclr')=0 then ibclr(ud)
else if lstrcmpi(S,'ibloc')=0 then ibloc(ud)
else DdeCallback:=DDE_FNotProcessed;
end;
end;
XTYP_Poke: begin
DdeCallback:=DDE_FNotProcessed; {Pessimistisch}
ud:=GetUD(Conv); {Deskriptor holen}
if ud>0 then begin
ItemNum:=GetDataNumber(hsz2,fmt);
case ItemNum of
0: begin {hier: Binärdaten?}
by:=DecodeDataType(hsz2);
if by>0 then DdeCallback:=Dde2Gpib(ud,by,Data,fmt);
end;
1: DdeCallback:=Dde2Gpib(ud,0,Data,fmt);
2: if Dde2Real(Z,Data,fmt) then begin {ibtmo}
ibtmo(ud,sec2NI_Wait(Z));
if ibsta and ERR =0 then DdeCallback:=DDE_FAck; {OK}
end;
3: if Dde2Real(Z,Data,fmt) then begin {ibeot}
ec:=0; if Z<>0 then ec:=1;
ibeot(ud,ec);
if ibsta and ERR =0 then DdeCallback:=DDE_FAck; {OK}
end;
end{case};
end;
end;
end;
end;
procedure DDEInit;
var
W: Word;
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 W:=0 to DdeLastSystem do SysHsz[W]:=CreateStringHandle(DdeSystemS[W]);
for W:=1 to DdeNumData do DataHsz[W]:=CreateStringHandle(DataS[W]);
DdeConnections:=0;
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:=DdeNumData downto 0 do
FreeStringHandle(DataHsz[i]);
for I:=DdeLastSystem downto 0 do
FreeStringHandle(SysHsz[i]);
FreeStringHandle(ServiceHsz);
DdeUninitialize(Inst);
end;
{fensterlose .EXE!?}
{$IFDEF HaveWindow}
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 traydata.cbSize<>0 then begin
lstrcpy(traydata.szTip,PChar(lParam));
traydata.uFlags:=NIF_Tip; {nur Text ändern}
if not Shell_NotifyIcon(NIM_Modify,traydata)
then Shell_NotifyIcon(NIM_Add,traydata);
end;
calldef:=true;
end;
WM_SysCommand: case wParam and $FFF0 of
$1F0: MBox0(Wnd,100{about},MB_IconAsterisk);
$1E0: begin
traydata.cbSize:=sizeof(traydata);
traydata.hwnd:=Wnd;
traydata.uID:=110;
traydata.uFlags:=NIF_Icon or NIF_Tip or NIF_Message;
traydata.uCallbackMessage:=WM_User;
traydata.hIcon:=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);
MBox0(Wnd,100{about},MB_IconAsterisk);
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: MBox0(Wnd,100{about},MB_IconAsterisk);
end;
WM_Close: begin
if (DdeConnections>0)
and (MBox1(Wnd,109{WarnClose},MB_IconQuestion or MB_YesNo,
PChar(DdeConnections))<>IDYes)
then exit;
if traydata.cbSize<>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);
{$ELSE}
var
Msg:TMsg;
begin
if HPrevInst<>0 then exit;
{$ENDIF}
WUtils.StdMBoxTitle:=AppTitle;
CF_XlTable:=RegisterClipboardFormat('XlTable');
DdeInit;
while GetMessage(Msg,0,0,0) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
DdeDone;
end.
| Detected encoding: OEM (CP437) | 1
|
|
|