program ddegp32;
{$D Universelle GPIB-zu-DDE-Schnittstelle h#s 07/01}
{hier: für Agilent HPIB.DLL 32bit}
{$F-,A+,G+,K+,W-}
{$I-,Q-,R-,S-}
{$V+,B-,X+,T+,P+}
{$N+}
{$R ddegp32}
{$IMAGEBASE $400000}
{$HINTS ON}
uses Windows,Messages,DdeMl,ShellApi, Hpib32,Parser32,WUtils32;
const
PROFILE='GPIB.INI';
DEVICE_ADDRESS='hpib7,%d';
var
iberr:ErrHP;
ibsta:Integer;
ibcnt:LongInt;
AutoEOT: array[0..15] of Boolean;
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
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'));
{************* 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 CF_MatTable',
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: Integer; {Format für Binärdaten}
CF_MatTable: Integer;
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;
const
XLCHUNKSIZE=$1FFF; {Anzahl DOUBLEs am Stück = 64K-8}
function MakeXlBuffer(k:LongInt):PExcelHeader;
{Erzeugt einen Puffer fürs Excel-Clipboardformat, gefüllt mit dem Header,
Freigabe mit GlobalFreePtr(Rückgabewert), füllt alle Zwischenheader aus}
var
zh: Integer; {Anzahl der Zwischen-Header, immer 2 pro 32k?}
gh: PExcelG; {Zwischen-Header-Zeiger}
begin
Result:=nil;
if k>65535 then exit; {kann nicht mehr als diese Zahl DOUBLEs!}
zh:=(k+XLCHUNKSIZE-1) div XLCHUNKSIZE;
Result:=GlobalAllocPtr(GMEM_Fixed,
sizeof(TExcelA)+k*sizeof(Double)+zh*sizeof(TExcelG));
if Result=nil then exit;
with Result^ do begin
a.g.gType:=tdtTable;
a.g.gSize:=4;
a.Rows:=1;
a.Cols:=k;
gh:=@b; {erster Zwischen-Header}
while zh<>0 do begin
gh.gType:=tdtFloat;
gh.gSize:=min(k,XLCHUNKSIZE)*sizeof(Double);
Inc(PChar(gh),sizeof(TExcelG)+XLCHUNKSIZE*sizeof(Double));
Dec(k,XLCHUNKSIZE);
Dec(zh);
end;
end;
end;
type
PMatHeader0=^TMatHeader0;
TMatHeader0=record
t,d: LongInt; {Typ(=6=DOUBLE),Dimensionen(=0)}
end;
PMatHeader2=^TMatHeader2;
TMatHeader2=record
t,d,y,x: LongInt; {Typ(=6=DOUBLE),Dimensionen(=2),Zeilen(=1),Spalten}
end;
function MakeMatBuffer(k:LongInt):PMatHeader2;
begin
Result:=GlobalAllocPtr(GMEM_Fixed,k*8+sizeof(TMatHeader2));
with Result^ do begin
t:=6; {Typ DOUBLE}
d:=2; {2 Dimensionen}
y:=1; {Zeilen}
x:=k; {Spalten (ggf. zum nachträglichen Patch)}
end;
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:LongInt);
{FAR-Daten an HUGE-DDE-Puffer anhängen}
{DDE scheint einen schweren Bug mit DdeAddData zu haben!?
Blöcke >64K werden nicht korrekt verarbeitet!}
var
chunk: LongInt;
begin
while ds>0 do begin
chunk:=min(ds,$FF00); {Windows hat Probleme mit glatten Werten}
hd.h:=DdeAddData(hd.h,dp,chunk,hd.l);
if hd.h=0 then begin
MBox1(0,102,PChar(DdeGetLastError(Inst)));
end;
Inc(hd.l,chunk);
Inc(dp,chunk);
Dec(ds,chunk);
end;
end;
function GpibReadUntilEnd(ud:Integer):PChar;
{Liest GPIB-Daten bis zum Ende-Zeichen und füllt damit einen
dynamisch wachsenden Puffer, der mit GlobalFreePtr freizugeben ist.
ibcnt enthält danach die Anzahl gelesener Bytes, ibsta den Status}
label
except1;
const
ALLOCSIZE=$10000;
{iread hat einen Bug und verschluckt Bytes bei langen Transfers;
desukara muss der Puffer möglichst groß sein}
var
p: PChar;
l: LongInt;
begin
Result:=GlobalAllocPtr(GMEM_Fixed,ALLOCSIZE);
if Result=nil then exit;
ibcnt:=0;
repeat
iberr:=iread(ud,Result+ibcnt,ALLOCSIZE,ibsta,l);
if iberr<>NOERROR then goto except1;
Inc(ibcnt,l); {Länge dazurechnen}
if ibsta and I_TERM_END <>0 then exit; {alles OK}
p:=GlobalReAllocPtr(Result,ibcnt+ALLOCSIZE,GMEM_Fixed);
if p<>nil then Result:=p; {zur nächsten Runde}
until p=nil; {abbrechen, wenn ReAlloc schief ging}
except1:
GlobalFreePtr(Result);
Result:=nil;
end;
procedure Kleinkram; assembler; {um nicht jedesmal darübersteppen zu müssen}
{PE: BL=DataType, ESI=Adresse, PA: ESI=vorgerückte Adresse, EAX=Zahl}
asm
cld
xor eax,eax ;{Null-Bits zur Vorgabe}
test bl,ARG_U08
jnz @@b
test bl,ARG_U16
jnz @@w
lodsd
test bl,ARG_bigend
jz @@z
xchg ah,al ;{auf einem 486+ hätten wir BSWAP sicher}
rol eax,16
xchg ah,al
jmp @@z
@@b: lodsb
test bl,ARG_vzb
jz @@z
cbw
jmp @@z1
@@w: lodsw
test bl,ARG_bigend
jz @@w1
xchg ah,al
@@w1: test bl,ARG_vzb
jz @@z
@@z1: cwde
@@z: {nun in EAX die Zahl}
end;
function Gpib2Dde(ud:Integer;dt:Byte;SH:HSz;cf:Integer):HDdeData; stdcall;
{holt Daten vom GPIB-Gerät, interpretiert sie ggf. binär je nach dt
und macht daraus ASCII- oder Binärdaten je nach cf}
label
except1,except2;
var
readbuf,writebuf,writestart,ArgStr: PChar;
writebd: PDouble absolute writebuf;
z1,z2,e: Integer;
buf: TS15; {Mini-Puffer}
k: LongInt;
L: LongInt;
chunk_cnt: Integer; {Zähler für DOUBLEs im Excel-Format-Stückel}
outdata: THugeDdeData;
begin
Result:=0;
outdata.h:=DdeCreateDataHandle(Inst,nil,256,0,SH,cf,0);
if outdata.h=0 then exit; {ENoMem}
outdata.l:=0;
readbuf:=GpibReadUntilEnd(ud);
if readbuf=nil then goto except2; {ENoMem oder GPIB-Fehler}
ArgStr:=readbuf;
if dt<>0 then begin
while (ibcnt>0) and (ArgStr^<>'#') do begin
Inc(ArgStr); Dec(ibcnt); {ein "#" muß auftreten}
end;
if ibcnt<2 then goto except1; {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);
move(ArgStr^,buf,z1); buf[z1]:=#0;
Val(buf,k,e); {für die numerische Konvertierung}
Inc(ArgStr,z1); Dec(ibcnt,z1);
if e<>0 then goto except1; {ungültige Folgeziffern}
if k mod (dt and $0F) <>0 then goto except1; {Anzahl "krumm"}
k:=k div (dt and $0F); {Anzahl der (binären) Zahlen}
z2:=ibcnt div (dt and $0F); {Anzahl der Daten}
if k>z2 then goto except1; {Fehler: Zu wenig Daten!}
if cf=CF_XlTable then begin
writestart:=PChar(MakeXlBuffer(k));
writebuf:=writestart+sizeof(TExcelHeader);
end else if cf=CF_MatTable then begin
writestart:=PChar(MakeMatBuffer(k));
writebuf:=writestart+sizeof(TMatHeader2);
end else begin
writestart:=GlobalAllocPtr(GMEM_Fixed,ibcnt*5);
writebuf:=writestart; {max. 5 Bytes pro Byte: "-128 "}
end;
if writestart=nil then goto except1; {ENOMEM oder zu großes K für XlBuffer}
chunk_cnt:=XLCHUNKSIZE;
while k>0 do begin
asm
push esi ;{Register-Variablen sichern}
push ebx
mov bl,[dt]
mov esi,[ArgStr]
call Kleinkram ;{Daten holen und zum LongInt formen}
mov [ArgStr],esi
mov [L],eax
pop ebx
pop esi
end;
if cf=CF_XlTable then begin
writebd^:=L; {in DOUBLE konvertieren und abspeichern}
Inc(writebd);
Dec(chunk_cnt);
if chunk_cnt=0 then begin
Inc(writebuf,4); {Einen Zwischen-Header überspringen}
chunk_cnt:=XLCHUNKSIZE;
end;
end else if cf=CF_MatTable then begin
writebd^:=L; {in DOUBLE konvertieren und abspeichern}
Inc(writebd);
end else begin
Str(L,TS31(Pointer(writebuf)^));
if k>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(k);
end; {k Daten umgewandelt}
hddeput(outdata,writestart,writebuf-writestart);
GlobalFreePtr(writestart);
end else begin {dt=0: GPIB liefert Text}
{6 Fälle gibt es, nur dt=0 und cf=CF_Text ohne Konvertierung}
if cf=CF_XlTable then begin
writestart:=PChar(MakeXlBuffer($3FF0)); {knapp 64K vorab}
writebuf:=writestart+sizeof(TExcelHeader);
ArgStr[ibcnt]:=#0; {zum Parsen terminieren}
while ArgStr^<>#0 do begin
Val(NextItem(ArgStr,DELIM_Whitespace),writebd^,e);
if e=0 then begin {nur numerisches einlesen lassen}
Inc(writebd);
end;
end;
with PExcelHeader(WriteStart)^ do begin
b.gSize:=WriteBuf-WriteStart-12; {wirkliche Datenmenge eintragen}
a.Cols:=(WriteBuf-WriteStart-12) div 8;
end;
hddeput(outdata,writestart,writebuf-writestart);
GlobalFreePtr(writestart);
end else if cf=CF_MatTable then begin
writestart:=PChar(MakeMatBuffer($4000));
writebuf:=writestart;
ArgStr[ibcnt]:=#0; {zum Parsen terminieren}
while ArgStr^<>#0 do begin
Val(NextItem(ArgStr,DELIM_Whitespace),writebd^,e);
if e=0 then Inc(writebd);
end;
PMatHeader2(writestart)^.x:=
(writebuf-writestart-sizeof(TMatHeader2)) div 8;
hddeput(outdata,writestart,writebuf-writestart);
GlobalFreePtr(writestart);
end else begin
hddeput(outdata,readbuf,ibcnt);
end;
end;
GlobalFreePtr(readbuf);
if cf=CF_Text then hddeput(outdata,'',1)
{im Fall von Text eine abschließende Null dazu}
{ else begin
asm int 3 end;
DdeAccessData(outdata.h,LPDWORD(@L));
end};
Result:=outdata.h;
exit;
except1:
GlobalFreePtr(readbuf);
except2:
DdeFreeDataHandle(outdata.h);
end;
function Real2Dde(z:TReal;SH:HSz;cf:Integer):HDdeData;
{wandelt eine einzelne Zahl ins DDE-Format (Excel oder String) um}
var
S: TS31;
pd: PChar;
begin
if cf=CF_XlTable then begin
pd:=PChar(MakeXlBuffer(1));
PDouble(pd+sizeof(TExcelHeader))^:=z;
Result:=DdeCreateDataHandle(Inst,pd,
sizeof(TExcelHeader)+sizeof(Double),0,SH,cf,0);
GlobalFreePtr(pd);
end else if cf=CF_MatTable then begin
pd:=PChar(MakeMatBuffer(1));
PDouble(pd+sizeof(TMatHeader2))^:=z;
Result:=DdeCreateDataHandle(Inst,pd,
sizeof(TMatHeader2)+sizeof(Double),0,SH,cf,0);
GlobalFreePtr(pd);
end else begin
Str(z,S);
Result:=DdeCreateDataHandle(Inst,@s,lstrlen(s)+1,0,SH,cf,0);
end;
end;
function Long2Dde(l:LongInt;SH:HSz;cf:Integer):HDdeData;
{wandelt eine einzelne Zahl ins DDE-Format (Excel oder String) um}
var
S: TS31;
begin
if cf<>CF_Text then Result:=Real2Dde(l,SH,cf)
else begin
Str(l,S);
Result:=DdeCreateDataHandle(Inst,@s,lstrlen(s)+1,0,SH,cf,0);
end;
end;
{hier: als Ersatz für TMemoryStream (es ginge auch ein MMF?)}
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:LongInt):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);
Inc(hd.p,hd.l); {Zeiger neu setzen}
end;
CopyMemory(hd.p,inputs,inputl);
Inc(hd.p,inputl);
hd.l:=l;
hput:=true;
end;
function hget(var hd:THugeData; outputs:PChar; outputl:LongInt):LongInt;
{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);
Inc(hd.p);
Dec(hd.l);
end;
begin
if outputl<>0 then begin
if outputl>hd.l then outputl:=hd.l;
if outputs<>nil then CopyMemory(outputs,hd.p,outputl);
Inc(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: asm
mov eax,[L]
xchg ah,al
mov [L],eax
end;
ARG_U32: asm
mov eax,[L]
xchg ah,al
rol eax,16
xchg ah,al
mov [L],eax
end;
end;
Result:=hput(hd,PChar(@L),dt and $F);
end;
function Dde2Gpib(ud:Integer;dt:Byte;data:HDdeData;cf:Integer):HDdeData; stdcall;
{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}
label except1;
var
indata,outdata:THugeData;
mh0: TMatHeader0;
eha: TExcelA absolute mh0;
ehg: TExcelG absolute mh0;
Z: Double;
L: LongInt;
cw: Integer;
ss: TS31;
begin
Dde2Gpib:=DDE_FNotProcessed;
L:=0; {Gesamtzahl DOUBLEs}
indata.p:=DdeAccessData(data,PInteger(@indata.l));
if ((cf<>CF_Text) or (dt<>0))
and (hinitw(outdata,indata.l)=false) {ungefähr gleiche Länge}
then goto except1;
if cf=CF_XlTable 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,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 except1;
end else begin
Str(Z,ss);
if indata.l>0 then lstrcat(ss,' ');
if not hput(outdata,ss,lstrlen(ss)) then goto except1;
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 if cf=CF_MatTable then begin
if hget(indata,PChar(@mh0),sizeof(mh0))<>sizeof(mh0) then goto except1;
if mh0.t<>6 then goto except1;
cw:=1;
while mh0.d<>0 do begin {alle Dimensionen lesen und multiplizieren}
if hget(indata,PChar(@L),sizeof(L))<>sizeof(L) then goto except1;
cw:=cw*L;
Dec(mh0.d);
end;
while cw>0 do begin
if hget(indata,PChar(@Z),8)<>8 then goto except1;
if dt<>0 then begin
if not PutLong(outdata,Round(Z),dt) then goto except1;
end else begin
Str(Z,ss);
if cw>1 then lstrcat(ss,' ');
if not hput(outdata,ss,lstrlen(ss)) then goto except1;
end;
Dec(cw);
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 except1;
end;
end else begin {Text nur bis zur terminierenden Null}
iberr:=iwrite(ud,indata.p,lstrlen(indata.p),true,ibcnt);
end;
end;
if (cf<>CF_Text) or (dt<>0) then begin
GlobalUnlock(outdata.h);
outdata.p:=GlobalLock(outdata.h); {Zeiger zurückstellen}
iberr:=iwrite(ud,outdata.p,outdata.l,true,ibcnt);
hdonew(outdata);
end;
DdeUnaccessData(data);
if iberr=NOERROR then Dde2Gpib:=DDE_FAck; {OK}
exit;
except1:
DdeUnaccessData(data);
end;
function Dde2Real(var Z:TReal;data:HDdeData;cf:Integer):Boolean;
{holt Daten aus <data>, interpretiert sie ggf. binär je nach cf
und macht daraus Z}
label finally1;
type
POneReal=^TOneReal;
TOneReal=record
eh: TExcelHeader;
zz: Double;
end;
POneScalar=^TOneScalar;
TOneScalar=record
case integer of
1: (mh2: TMatHeader2; z2:Double); {mit Dimensionen=2}
2: (mh0: TMatHeader0; z0:Double); {Dimensionen=0}
end;
var
indata: PChar;
begin
Dde2Real:=false;
indata:=DdeAccessData(data,nil);
if cf=CF_XlTable then with POneReal(indata)^ do begin
if eh.a.g.gType<>tdtTable then goto finally1;
if eh.a.g.gSize<>4 then goto finally1;
if eh.a.rows=0 then goto finally1;
if eh.a.cols=0 then goto finally1;
if eh.b.gType<>tdtFloat then goto finally1;
if eh.b.gSize<8 then goto finally1;
Z:=zz;
Result:=true;
end else if cf=CF_MatTable then with POneScalar(indata)^ do begin
if mh0.t<>6 then goto finally1;
case mh0.d of
0: Z:=z0;
2: Z:=z2;
else goto finally1;
end;
Result:=true;
end else begin {CF_Text}
Result:=S2Real(indata,Z);
end;
finally1:
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 GetDataNumber(Hsz2: Hsz; cf:Integer):Integer;
var
I:Integer;
begin
if (cf=CF_Text) or (cf=CF_XlTable) or (cf=CF_MatTable) 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; cf:Integer):Integer;
var
I: Integer;
begin
GetSystemNumber:=0; {Kein Datum!}
if cf<>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 ibfind(udname:PChar):Integer;
var
tmo,eos:Integer;
s: TS31;
begin
Result:=GetPrivateProfileInt(udname,'Pad',-1,PROFILE);
if Result=-1 then exit;
wvsprintf(s,'hpib7,%d',Result);
Result:=iopen(s);
if Result=-1 then exit;
tmo:=GetPrivateProfileInt(udname,'Tmo',2,PROFILE);
itimeout(Result,tmo*1000);
GetPrivateProfileString(udname,'REos','No',s,sizeof(s),PROFILE);
if lstrcmpi(s,'Yes')=0
then eos:=GetPrivateProfileInt(udname,'Eos',0,PROFILE)
else eos:=-1;
itermchr(Result,eos);
if Cardinal(Result)<=HIGH(AutoEOT) then begin
GetPrivateProfileString(udname,'Eot','No',s,sizeof(s),PROFILE);
AutoEot[Result]:=lstrcmpi(s,'Yes')=0;
end;
end;
function ibdev(bdidx,pad,sad,tmo:Integer;eot:Boolean;eos:Integer):Integer;
var
s: TS31;
begin
Result:=-1;
if bdidx<>0 then exit;
wvsprintf(s,'hpib7,%d',pad);
Result:=iopen(s);
if Result=-1 then exit;
itimeout(Result,tmo*1000);
itermchr(Result,eos);
if Cardinal(Result)<=HIGH(AutoEOT) then begin
AutoEot[Result]:=eot;
end;
end;
function DdeCallback(CallType,Fmt:Integer; Conv:hConv; HSz1,HSz2:HSz;
Data:hDdeData; Data1,Data2: Integer): hDdeData; stdcall;
const
ConnectingUD:Integer=0; {zum Hinüberretten nach XTYP_Connect_Confirm}
var
ItemNum: Integer;
Z: TReal;
S: TS31;
sp: PChar;
ud,ec: Integer;
bdidx,pad,sad,tmo,eos:Integer;
eot: Boolean;
by: Byte;
begin
DdeCallback:=0;
case CallType of
XTYP_Connect: begin
if DdeCmpStringHandles(Hsz1,SysHsz[0])=0 then begin {1. "system"}
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,ESCAP_DblQuote or DELIM_Whitespace),bdidx,ec);
Val(NextItem(sp,ESCAP_DblQuote or DELIM_Whitespace),pad,ec);
if ec<>0 then exit; {Fehler!}
Val(NextItem(sp,ESCAP_DblQuote or DELIM_Whitespace),sad,ec);
Val(NextItem(sp,ESCAP_DblQuote or DELIM_Whitespace),Z,ec);
if ec=0 then tmo:=Round(Z*1000) else tmo:=3000; {Default: 3 Sekunden}
Val(NextItem(sp,ESCAP_DblQuote or DELIM_Whitespace),eos,ec);
eot:=(ec<>0) or (eos<>0); {Default: EOT ein}
Val(NextItem(sp,ESCAP_DblQuote or 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);
ChangeDdeDisplay;
end;
XTYP_Disconnect: begin
ud:=GetUD(Conv); {Deskriptor holen}
if ud>0 then iclose(ud);
Dec(DdeConnections);
ChangeDdeDisplay;
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}
iberr:=igettimeout(ud,LongInt(TMO));
DdeCallback:=Real2Dde(TMO/1000,hsz2,fmt);
end;
3: if Cardinal(ud)<=HIGH(AutoEOT) then begin {ibask EOT}
DdeCallback:=Long2Dde(Integer(AutoEot[ud]),hsz2,fmt);
end;
4: DdeCallback:=Long2Dde(Integer(iberr),hsz2,fmt);
5: DdeCallback:=Long2Dde(ibsta,hsz2,fmt);
6: DdeCallback:=Long2Dde(ibcnt,hsz2,fmt);
7: begin
{ibrsp(ud,ec); - weiß nicht was tu tun ist!}
DdeCallback:=Long2Dde(ec,hsz2,fmt);
end;
8: begin
DdeCallback:=DdeCreateDataHandle(Inst,
PChar('1.0, h#s 06/01, 32bit Agilent/HP'),
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) weiß nicht}
else if lstrcmpi(S,'ibclr')=0 then iclear(ud)
else if lstrcmpi(S,'ibloc')=0 then ilocal(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}
itimeout(ud,Round(Z*1000));
if iberr=NOERROR then DdeCallback:=DDE_FAck; {OK}
end;
3: if Dde2Real(Z,Data,fmt) then begin {ibeot}
if Cardinal(ud)<=HIGH(AutoEOT) then begin
AutoEOT[ud]:=Z<>0;
DdeCallback:=DDE_FAck; {OK}
end;
end;
end{case};
end;
end;
end;
end;
procedure DDEInit;
var
W: Integer;
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($400000,106,DdeHelpString,256);
Inc(W,LoadString($400000,107,DdeHelpString+W,256));
LoadString($400000,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]);
OemToAnsi(DdeStrings[3],DdeStrings[3]);
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;
var
traydata: TNotifyIconData;
function MainWndProc(Wnd:HWnd; Msg,wParam,lParam:LongInt):LongInt; stdcall;
var
P: TPoint;
m,sysm: HMenu;
calldef: Boolean;
si: TStartupInfo;
s: TS31 absolute si;
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($400000,101,s,sizeof(s)); {Über...}
InsertMenu(sysm,0,MF_ByPosition or MF_String,$1F0,s);
LoadString($400000,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($400000,110,s,sizeof(s)); {In den Tray!}
InsertMenu(sysm,2,MF_ByPosition or MF_String,$1E0,s);
GetStartupInfo(si);
if si.wShowWindow in [SW_Minimize,SW_ShowMinimized,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}
Shell_NotifyIcon(NIM_Modify,@traydata);
end;
calldef:=true;
end;
WM_SysCommand: case wParam and $FFF0 of
$1F0: MBox1(Wnd,100{about},nil);
$1E0: begin
traydata.cbSize:=sizeof(traydata);
traydata.wnd:=Wnd;
traydata.uID:=110;
traydata.uFlags:=NIF_Icon or NIF_Tip or NIF_Message;
traydata.uCallbackMessage:=WM_User;
traydata.hIcon:=GetClassLong(Wnd,GCL_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_User+1: begin {Tray-Icon neu zeichnen, z.B. nach Explorer-Absturz}
traydata.uFlags:=NIF_Icon or NIF_Tip or NIF_Message;
if not Shell_NotifyIcon(NIM_Modify,@traydata)
then Shell_NotifyIcon(NIM_Add,@traydata);
end;
WM_QueryOpen: ; {nur Icon}
WM_User: case lParam of
WM_LButtonDown: begin
ShowWindow(Wnd,SW_ShowMinimized);
MBox1(Wnd,100{about},nil);
ShowWindow(Wnd,SW_Hide);
end;
WM_RButtonDown: begin
m:=LoadMenu($400000,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 Word(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 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: $400000;
hIcon: 0;
hCursor: 0;
hbrBackground: COLOR_Window;
lpszMenuName: nil;
lpszClassName: AppName);
var
Msg:TMsg;
begin
wc.hIcon:=FindWindow(AppName,nil);
if wc.hIcon<>0 then begin
if IsWindowVisible(wc.hIcon)
then SetActiveWindow(wc.hIcon)
else PostMessage(wc.hIcon,WM_User+1,0,0); {z.B. nach Explorer-Absturz}
exit;
end;
wc.hIcon:=LoadIcon($400000,MakeIntResource(100));
wc.hCursor:=LoadCursor(0,IDC_Arrow);
RegisterClass(wc);
MainWnd:=CreateWindowEx(0,AppName,AppTitle,
WS_OverlappedWindow,
0,0,0,0,
0,0,$400000,nil);
ShowWindow(MainWnd,SW_ShowMinimized); {wird von Windows total verschluckt!}
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
|
|
|