library ddeinit;
uses PasMex32,Parser32,Windows,DDEML;
{jede dieser DLLs auf andere Basisadressen relozieren}
{$IMAGEBASE $10000000}
{$HINTS ON}
{$R ddeinit} {englisch und deutsch, DCC32 kann das nicht getrennt}
{$Z4}
const
idInst: LongInt=0; {globale Variable für alle DDE-DLLs,...}
{Lesezugriff für alle via GetInst-Funktion}
type
EClip=(Text,Unicode,XlTable,MatTable);
const
ClipNames: array[EClip] of PChar=(
'Text', {normaler ASCII-Text}
'UnicodeText', {16-bit-Zeichen für's Japanisch}
'XlTable', {Clipboard-Format-Name für FastDDE}
'MatTable'); {für Double-Matrizen und -Arrays}
var {die Ergebnisse von RegisterClipboardFormat,...}
ClipForms: array[EClip] of UInt; {für CheckClipFormat zur Umsetzung}
verbose: Integer;
{Schlafmützen, die die Delphi-Standardbibliothek geschrieben haben:}
function wsprintf1(ret,template,a1: PChar):LongInt;
cdecl; external 'user32.dll' name 'wsprintfA';
function wsprintf2(ret,template,a1,a2: PChar):LongInt;
cdecl; external 'user32.dll' name 'wsprintfA';
function MyRegisterClipboardFormat(FormatName:PChar):UInt; stdcall;
{wie die Windows-Funktion, jedoch mit Verarbeitung von "Text" und
"UnicodeText" als vordefinierte Codes}
begin
if lstrcmpi(FormatName,ClipNames[Text])=0
then Result:=CF_Text
else if lstrcmpi(FormatName,ClipNames[Unicode])=0
then Result:=CF_UnicodeText
else Result:=RegisterClipboardFormat(FormatName);
end;
function GetInst:DWord; stdcall;
{ID-Spender für die anderen Funktionen}
begin
GetInst:=idInst;
end;
procedure HandleDdeError(DdeError:UInt); stdcall;
{Bei DDE-Fehler Warnmeldung (kein Skript-Abbruch!);
DdeError darf auch 0 sein; dann wird DdeGetLastError herangezogen}
var
strcode: UInt;
sz1,sz2: array[0..255] of Char;
szBuf: array[0..1023] of Char;
begin
if DdeError=0 then begin
if verbose=0 then exit; {nie meckern}
DdeError:=DdeGetLastError(idInst);
if DdeError=0 then exit; {nichts zu meckern!}
if (DdeError=DMLERR_NotProcessed)
and (verbose<2) then exit;
{der häufigste Fehler wird sonst auf die Dauer lästig}
end;
strcode:=DdeError;
if (strcode<DMLErr_First) or (strcode>DMLErr_Last)
then strcode:=$4012; {"unbek. Fehler"}
LoadString(HInstance,strcode,sz1,sizeof(sz1));
LoadString(HInstance,1,sz2,sizeof(sz2)); {"code %d, text %s"}
wsprintf2(szBuf,sz2,PChar(DdeError),sz1);
mexWarnMsgTxt(szBuf);
end;
function TestInputArgs(nrhs:LongInt; const prhs: TMatArr;
minIn,maxIn:LongInt; permitString,permitNumeric: DWord):Boolean; stdcall;
{Testet Rechte-Hand-Parameter auf Anzahl (Minimum und Maximum)
und auf Typ via zweier Bitmasken (so sind auch zwei Typen erlaubt)
Liefert immer TRUE, weil bei Fehler Skript-Abbruch}
var
strcode: UInt;
i: LongInt;
szBuffer,sz1: array[0..255] of Char;
begin
if (nrhs<minIn) or (nrhs>maxIn) then begin
strcode:=4; {"must be one arg"}
if minIn<>1 then strcode:=5; {"must be %d args"}
if minIn<>maxIn then strcode:=6; {"must be %d to %d args"}
LoadString(HInstance,strcode,sz1,sizeof(sz1));
wsprintf2(szBuffer,sz1,PChar(minIn),PChar(maxIn));
mexErrMsgTxt(szBuffer);
end;
strcode:=0;
for i:=0 to nrhs-1 do begin
if (permitString and (1 shl i) =0)
and mxIsChar(prhs[i]) then begin
strcode:=7; {"String für %ites Arg nicht erlaubt!"}
break;
end;
if (permitNumeric and (1 shl i) =0)
and mxIsNumeric(prhs[i]) then begin
strcode:=8; {"Numerisch für %ites Arg nicht erlaubt!"}
break;
end;
if not (mxGetClassID(prhs[i]) in [mxChar_Class,mxDouble_Class]) then begin
strcode:=9; {"Nur `traditionelle` Typen bitte!"}
break;
end;
end;
if strcode<>0 then begin
LoadString(HInstance,strcode,sz1,sizeof(sz1));
wsprintf1(szBuffer,sz1,PChar(i+1));
mexErrMsgTxt(szBuffer);
end;
TestInputArgs:=true;
end;
function ArrayToStringHandle(a:PArray):Hsz; stdcall;
{Umwandlung Matlab-String-Matrix in DDE-String-Handle}
var
psz: PChar;
begin
psz:=mxArrayToString(a);
ArrayToStringHandle:=DdeCreateStringHandle(idInst,psz,CP_WinAnsi);
mxFree(psz);
end;
type
PHSZ=^HSZ;
function ArrayToStringHandles(a:PArray;szp:PHSZ;szplen:Integer):Integer;
stdcall; {Umwandlung Matlab-String-Matrix in DDE-String-Handle-Array
(für DDEADV und DDEUNADV)}
var
psz,s2,s3: PChar;
begin
psz:=mxArrayToString(a); s2:=psz; Result:=0;
while szplen>0 do begin
s3:=NextItem(s2,ESCAP_DblQuote or DELIM_NilWhenNone or DELIM_WhiteSpace);
if s3=nil then break; {Ende mit Allende}
szp^:=DdeCreateStringHandle(idInst,s3,CP_WinAnsi);
Inc(szp);
Inc(Result);
Dec(szplen);
end;
mxFree(psz);
end;
function FreeStringHandle(sz:HSZ):Boolean; stdcall;
{ein oder mehrere String-Handles freigeben und Referenzen nullsetzen}
begin
Result:=DdeFreeStringHandle(idInst,sz);
end;
function CheckClipFormat(a:PArray; var cf: UInt; ocp:PBool):EClip; stdcall;
{Testet auf CF_Text(=1) oder CF_XlTable oder CF_MatTable
und liefert 1, 2 oder 3; bei Fehler keine Rückkehr
Verarbeitet sowohl Zahlen als auch (neu) Konstanten-Strings
Bei Angabe des Parameters ocp wird auf Zwei-Element-Array getestet,
für DDEREQ und DDEADV, und so der Rückgabe-Typ ermittelt}
var
indp: PDouble;
szTemp,szBuf: array[0..255] of Char;
begin
if mxIsChar(a) then begin
mxGetString(a,szTemp,sizeof(szTemp)); {String sollte kurz sein}
cf:=MyRegisterClipboardFormat(szTemp);
end else begin
cf:=Round(mxGetScalar(a));
end;
for Result:=LOW(EClip) to HIGH(EClip) do if cf=ClipForms[Result] then begin
if ocp<>nil then begin
if mxIsChar(a)
then ocp^:=(Result<=Unicode) {bei Text Textrückgabe, sonst binär}
else if (mxGetM(a)=1) and (mxGetN(a)>=2) then begin
indp:=mxGetPr(a);
Inc(indp);
ocp^:=(indp^=1);
end else ocp^:=false;
end;
exit;
end;
LoadString(HInstance,10,szTemp,sizeof(szTemp)); {"ungültiges CF"}
wsprintf1(szBuf,szTemp,PChar(cf));
mexErrMsgTxt(szBuf);
CheckClipFormat:=Text; {Compiler ruhigstellen}
end;
procedure PutErr(strcode:UInt); stdcall;
{einfache Fehlermeldung für die anderen DLLs}
var
s: array[0..255] of Char;
begin
LoadString(HInstance,strcode,s,sizeof(s));
mexErrMsgTxt(s);
end;
procedure PutWarn(strcode:UInt); stdcall;
{einfache Warnung für die anderen DLLs}
var
s: array[0..255] of Char;
begin
LoadString(HInstance,strcode,s,sizeof(s));
mexWarnMsgTxt(s);
end;
{***** ehemals in DDEPOKE *****}
{Weil nicht klar ist, ob DDEPOKE vor oder nach DDEREQ aufgerufen wird,
muss alles gemeinsam benutzte nun nach DDEINIT, was DEFINITIV zuerst
aufgerufen wird. Andernfalls kann Matlab die DLL nicht laden, weil
der Querbezug nicht gefunden wird.}
const
NumberLength=26; {Länge eines DOUBLE in Zeichen, volle Präzision}
function Alloc_Datalen(format:EClip; x,y:LongInt; var datalen: UInt):PChar;
stdcall;
{Berechnet die benötigte Menge an Speicherplatz für die angegebenen
Dimensionen und fordert ihn an. Nur für max. zweidimensionales!
Liefert nie NIL; bricht ggf. mit mexErrMsgTxt() ab.
Speicher ist mit Nullen gefüllt}
var
DataBlocks:LongInt;
begin
datalen:=x*y*sizeof(Double); {meistens - irgendwie}
case format of
Text: begin
datalen:=x*y*(NumberLength+1)+y+1; {Anzahl Zeichen, 0D0A für Zeilen}
if y=1 then Dec(datalen,2); {einzeilige ohne 0D0A am Ende!}
end;
Unicode: begin
datalen:=(x*y+1)*sizeof(WChar); {hier Ausnahme: String-Länge!}
end;
XlTable: begin
if (x>=65536) or (y>=65536) then PutErr(11);{zu große Matrixausdehnung}
datablocks:=(datalen+$7FFF) div $8000; {also 32-KB-Blöcke}
Inc(datalen,8+datablocks*4);
end;
MatTable: Inc(datalen,4*sizeof(LongInt));
end;
Result:=PChar(LocalAlloc(LMEM_Fixed or LMEM_ZeroInit,datalen));
if Result=nil then PutErr(12); {Speicherbelegungsfehler}
end;
procedure str_skip_ws(var s:PChar);
{(anfänglichen) Weißraum übergehen}
begin
while s^ in [#9,#13,' '] do inc(s);
end;
procedure str_find_lt(var s:PChar; dp:PDouble);
{Listentrenner suchen, dabei nachfolgenden Weißraum (auch 0Dh) übergehen;
liefert die Zahl (die im ersten Durchlauf verworfen wird)}
var
ec: LongInt;
memsp: PChar;
memchr: Char;
begin
str_skip_ws(s);
if dp<>nil then begin {will die Zahl haben!}
Val(s,dp^,ec);
if ec>1 then begin {bei EC=1 sollte Null herauskommen...}
{das wäre ein leeres Feld zwischen Kommata oder Semikola bzw. eine Leerzeile}
memsp:=s+ec-1;
memchr:=memsp^;
memsp^:=#0;
Val(s,dp^,ec);
memsp^:=memchr;
end;
end;
while not (s^ in [#0..' ',',',';']) do inc(s); {Zahl und Rest übergehen}
str_skip_ws(s); {bis zu ',',';'(Spaltentrenner),#10(Zeilentrenner)}
end;
procedure str_count_numbers(s:PChar; var x,y:LongInt); stdcall;
{Zählt Zeilen (y) und Spalten (x) der Text-Matrix ab, nimmt dabei
das Maximum, falls einige Zeilen nicht voll sind. Trennt Spalten
an Leerzeichen, Tabs und am Windows-Listentrenner? (Systemsteuerung).
Leerzeilen werden ignoriert. Wird auch von DDEREQ benötigt.
X wird mindestens 1, aber Y kann Null werden!}
var
xx: LongInt;
begin
x:=1; y:=1; xx:=0;
str_skip_ws(s);
while s^<>#0 do begin
while s^ in [#10,';'] do begin
Inc(s);
str_skip_ws(s); {Leerzeilen ignorieren}
if s^=#0 then begin
Dec(y); {wenn nur leere Zeilen, dann y=0!}
exit;
end;
end;
str_find_lt(s,nil);
Inc(xx); {Zahl (scheinbar) konvertiert}
case s^ of
',': Inc(s); {Komma wie Leerzeichen übergehen}
#10,';': begin
if x<xx then x:=xx; {x als Maximum setzen}
xx:=0;
Inc(y); {also zunächst auf 2}
end;
end;
end;
if x<xx then x:=xx; {wenn letzte Zeile maßgebend}
end;
procedure PrepareXlTable(var dp:PDouble; x,y: LongInt); stdcall;
{Füllt den bereits ausgenullten Speicher mit dem Header und den
Zwischen-Headern, setzt dp hinter den Haupt-Header}
var
lp: PLongInt; {ein PWord ist zwar logischer, aber uneffektiv}
begin
lp:=Pointer(dp); Inc(dp); {gleich um 8 erhöhen}
lp^:=$00040010; Inc(lp);
lp^:=MakeLong(y,x); Inc(lp);
x:=x*y; {Rollentausch, x=Doubles-gesamt, y=Doubles-Block}
while x>0 do begin {alle Zwischen-Header verteilen}
y:=x; if y>$1000 then y:=$1000;
Dec(x,y);
lp^:=y*sizeof(Double) shl 16 +1;
Inc(PChar(lp),4+y*sizeof(Double));
end;
end;
function SkipXlFloatHeader(var dp:PDouble):LongInt; stdcall;
{überspringt genau einen Zwischen-Header und liefert die Blocklänge
in Doubles; hoffentlich ist die Blocklänge durch 8 teilbar}
begin
if PWord(dp)^<>1 then PutErr(14); {Konsistenzfehler}
Inc(PWord(dp));
Result:=PWord(dp)^ div sizeof(Double);
Inc(PWord(dp));
end;
function aa(dp:PDouble; x,y,yges:LongInt; makexl:Bool):PDouble;
{berechne Array-Adresse (so umständlich wegen des Stürzens notwendig)}
begin
yges:=x*yges+y; {das soundsovielte Double}
x:=yges*sizeof(Double); {der Adress-Offset}
Result:=dp;
if makexl then repeat
Inc(x,4); {einen Header überspringen}
y:=SkipXlFloatHeader(dp);
Dec(yges,y); {diesen Block "erledigen"}
Inc(dp,y); {und zum nächsten Zwischenheader}
until yges<0;
Inc(PChar(Result),x);
end;
procedure str_to_numbers(s:PChar; x,y:LongInt; dp:PDouble;
skipxl:Bool); stdcall;
{wandelt durchgezählten Text in Doubles um}
var
xx,yy: LongInt;
dp2: PDouble;
begin
str_skip_ws(s);
for yy:=0 to y-1 do begin
if s^=#0 then break;
while s^ in [#10,';'] do begin
Inc(s);
str_skip_ws(s); {Leerzeilen ignorieren}
if s^=#0 then exit; {eigentlich Fehler, oder?}
end;
for xx:=0 to x-1 do begin
dp2:=aa(dp,xx,yy,y,skipxl);
if s^ in [#0,#10,';'] then begin
dp2^:=0.0 {Zeilenrest mit Nullen füllen}
end else begin
str_find_lt(s,dp2);
if s^=',' then Inc(s);
end;
end;
end;
end;
procedure str_from_numbers(s:PChar; x,y:LongInt; dp:PDouble;
skipxl:Bool); stdcall;
{wandelt Doubles in Text um}
type
PStrBuffer=^TStrBuffer;
TStrBuffer=array[0..NumberLength] of Char;
var
xx,yy: LongInt;
begin
for yy:=0 to y-1 do begin
for xx:=0 to x-1 do begin
if xx<>0 then begin
s^:=' ';
Inc(s);
end;
Str(aa(dp,xx,yy,y,skipxl)^:NumberLength,PStrBuffer(s)^);
s:=s+lstrlen(s);
end;
if y<>1 then begin {hier: Einzelzeile ohne Newline!}
lstrcpy(s,#13#10);
Inc(s,2);
end;
end;
end;
{***** ehemals in DDEPOKE ***** END *****}
procedure mxGetStringW(a:PArray; sp:PWChar; buflen:LongInt); stdcall;
{Unicodes aus Matlab-Array herausziehen, buflen in BYTES}
var
n: LongInt; {Anzahl der Zeichen}
dp: PDouble;
begin
buflen:=buflen div 2;
n:=mxGetN(a); if n>buflen-1 then n:=buflen-1; {begrenzen}
dp:=mxGetPr(a);
while n>0 do begin
if (dp^<0) or (dp^>65535) then sp^:=WChar(65535)
else sp^:=WChar(Round(dp^));
Inc(dp);
Inc(sp);
end;
end;
function mxCreateStringW(sp:PWChar):PArray; stdcall;
{Unicodes in neues Matlab-Array einsetzen}
var
mn: array[0..1] of LongInt;
dp: PDouble;
begin
mn[0]:=1;
mn[1]:=lstrlenW(sp); {wird ja auch von Win9x unterstützt}
Result:=mxCreateCharArray(2,@mn);
dp:=mxGetPr(Result);
while mn[1]>0 do begin
dp^:=LongInt(sp^); {mit Daten füllen}
Inc(dp);
Inc(sp);
end;
end;
{***** ehemals in DDEREQ *****}
procedure CopyXlFloat(indata,dp: PDouble; x,y:LongInt);
{XlTable-Doubles in durchgehende Doubles umwandeln}
begin
x:=x*y; {Rollentausch: x=gesamt, y=Block}
while x>0 do begin
y:=SkipXlFloatHeader(indata);
CopyMemory(dp,indata,y*sizeof(Double));
Inc(dp,y); Inc(indata,y); Dec(x,y);
end;
end;
procedure ReadXlTableHeader(var indata:PDouble; var x,y: LongInt);
{rückt indata vor und liest x und y ein}
var
wp: PWord;
begin
wp:=Pointer(indata); Inc(indata); {gleich um 8 vorrücken}
if PLongInt(wp)^<>$00040010 then PutErr(14); {inkonsistent}
Inc(wp,2);
y:=wp^; Inc(wp);
x:=wp^; Inc(wp);
if (x<>0) and (y<>0) and (wp^<>1) then PutErr(14);
{falls überhaupt Daten vorhanden sind, müssen sie Double sein}
end;
function DdeDataToArray(hindata:HDdeData; format:EClip; outchar: Bool):
PArray; stdcall;
{gemeinsame Routine für DDEREQ und XTYP_AdvData-Callback,
wandelt DDE-Daten aus Handle in Matlab-Array um}
var
insp: PChar;
inlp: PLongInt absolute insp;
indp: PDouble absolute insp;
datalen: UInt;
outdata: PChar; {data kann, muss aber kein String sein!}
x,y: LongInt; {Matrix-Ausdehnung}
begin
Result:=nil;
insp:=DdeAccessData(hindata,nil);
if outchar then begin
case format of
Text: Result:=mxCreateString(insp);
Unicode: Result:=mxCreateStringW(PWChar(insp));
XlTable: begin
ReadXlTableHeader(indp,x,y);
outdata:=Alloc_Datalen(Text,x,y,datalen);
str_from_numbers(outdata,x,y,indp,true);
Result:=mxCreateString(outdata);
LocalFree(Integer(outdata));
PutWarn(18); {Schwachsinn-Meldung}
end;
MatTable: begin
if inlp^<>6 then PutErr(14); Inc(inlp); {muss DOUBLE sein}
x:=inlp^; Inc(inlp);
if x>2 then PutErr(13); {max. zweidimensional}
y:=1;
if x>=1 then begin
y:=inlp^; Inc(inlp);
end;
if x=2 then begin
x:=inlp^; Inc(inlp);
end else x:=1; {etwas nulldimensionales ist 1x1-Matrix = Skalar}
outdata:=Alloc_Datalen(Text,x,y,datalen);
str_from_numbers(outdata,x,y,indp,false);
Result:=mxCreateString(outdata);
LocalFree(Integer(outdata));
PutWarn(18); {Schwachsinn-Meldung}
end;
end;
end else begin
case format of
Text: begin
str_count_numbers(insp,x,y);
Result:=mxCreateDoubleMatrix(y,x,mxReal);
str_to_numbers(insp,x,y,mxGetPr(Result),false); {alles umwandeln!}
end;
Unicode: PutErr(17); {Kann nicht / will nicht}
XlTable: begin
ReadXlTableHeader(indp,x,y);
Result:=mxCreateDoubleMatrix(y,x,mxReal);
CopyXlFloat(indp,mxGetPr(Result),x,y);
end;
MatTable: begin
if inlp^<>6 then PutErr(14); Inc(inlp); {muss DOUBLE sein}
x:=inlp^; Inc(inlp);
Result:=mxCreateNumericArray(x,inlp,mxDouble_Class,mxReal);
Inc(inlp,x);
y:=mxGetNumberOfElements(Result); {sollte Dimensionsprodukt sein}
CopyMemory(mxGetPr(Result),indp,y*sizeof(Double));
end;
end;
end;
DdeUnaccessData(hindata);
end;
{***** ehemals in DDEREQ ***** END *****}
{***** ehemals in DDEADV *****}
type
PPAdvInfo=^PAdvInfo;
PAdvInfo=^TAdvInfo;
TAdvInfo=record {Advise-Information}
next: PAdvInfo; {für verkettete Liste}
conv: HConv; {diese 3 Parameter...}
item: Hsz; {...identifizieren...}
cf: UInt; {...den richtigen Link}
format: EClip; {für uns zum Daten konvertieren}
outchar: Bool; {numerischer oder String-Output?}
arrayname: array[0..mxMAXNAM-1] of Char; {keine Unicodes möglich}
evalstring: array[0..0] of Char; {dynamisch, keine Unicodes}
end;
const
AdvList: PAdvInfo=nil; {Zeiger auf verkettete Liste}
function FindNextInfo(cur,prev:PPAdvInfo; conv:HConv; item:Hsz; cf:UInt)
:Boolean;
{"cur^" zeigt auf vorhergehenden Knoten, weder cur noch cur^ darf NIL sein;
"prev" wird ja bekanntlich zum Löschen gebraucht, darf NIL sein.
Bei Rückgabe von FALSE ist cur^ unverändert}
var
ap: PAdvInfo; {"kürzerer" Zugang}
begin
Result:=false;
ap:=cur^;
repeat
if prev<>nil then prev^:=ap;
ap:=ap^.next;
if ap=nil then break;
if ((conv=0) or (ap^.conv=conv))
and ((item=0) or (ap^.item=item))
and ((cf=0) or (ap^.cf=cf))
then begin
cur^:=ap;
Result:=true;
exit;
end;
until false;
end;
procedure DdeAdvise(conv:HConv; szItem:Hsz; uFmt:UInt; data:hDdeData);
{CALLBACK, gefiltert aus der DDE-Callback-Routine}
var
ap: PAdvInfo;
a: PArray;
begin
ap:=@AdvList;
while FindNextInfo(@ap,nil,conv,szItem,uFmt) do begin
if data<>0 then begin {HotLink}
a:=DdeDataToArray(data,ap^.format,ap^.outchar);
mxSetName(a,ap^.arrayname);
if mexPutArray(a,'caller')<>mxOK then PutWarn(19); {Kann nicht updaten}
mxDestroyArray(a);
end;
if (ap^.evalstring[0]<>#0)
and (mexEvalString(ap^.evalstring)<>mxOK)
then PutWarn(18); {Fehler bei Callback-String}
end;
end;
procedure advDeleteInfo(conv:HConv; item:Hsz; cf:UInt); stdcall;
{Löscht die Daten aus der einfach verketteten Liste;
der Aufruf mit allen drei Parametern =0 löscht alles.
Die zugehörigen String-Handles werden freigegeben.
Falls "multithreadend", müsste das Zeug in einen kritischen Abschnitt}
var
ap,avp: PAdvInfo;
begin
ap:=@AdvList;
while FindNextInfo(@ap,@avp,conv,item,cf) do begin
FreeStringHandle(ap^.item);
avp^.next:=ap^.next; {ap aus Liste aushängen}
LocalFree(Integer(ap)); {ap freigeben}
ap:=avp; {weitermachen vom vorhergehenden aus}
end;
end;
procedure advNewInfo(conv:HConv; item:Hsz; cf:UInt; format:EClip; outchar:Bool;
arrayname,evalstring: PChar); stdcall;
{Neuanlage eines Listenelements; evtl. vorher vorhandenes entfernen.
Parameter-Reihenfolge und stdcall ermöglicht Speicher-Kopie}
var
ap: PAdvInfo;
el: UInt;
begin
advDeleteInfo(conv,item,cf);
el:=0; if evalstring<>nil then el:=lstrlen(evalstring);
ap:=PAdvInfo(LocalAlloc(LMEM_Fixed or LMEM_ZeroInit,sizeof(TAdvInfo)+el));
if ap=nil then PutErr(12); {Speicher-Panik!}
ap^.next:=AdvList;
AdvList:=ap; {einfach vorn einhängen}
CopyMemory(@(ap^.conv),@conv,4*5); {der langweilige Krempel}
if arrayname<>nil then lstrcpyn(ap^.arrayname,arrayname,mxMAXNAM);
if evalstring<>nil then lstrcpy(ap^.evalstring,evalstring);
end;
{***** ehemals in DDEADV ***** END *****}
procedure DisconnectMsgBox(Conv:HConv);
{Wenn ein DDE-Server bei aktiver Verbindung verreckt, hiermit anzeigen}
var
ci: TConvInfo;
szSvcPartner, szTopic, sz1: array[0..255] of Char;
szBuffer: array[0..1023] of Char;
begin
ci.cb:=sizeof(TConvInfo);
DdeQueryConvInfo(Conv,QID_Sync,@ci);
DdeQueryString(idInst,ci.hszSvcPartner,szSvcPartner,sizeof(szSvcPartner),
CP_WinAnsi);
DdeQueryString(idInst,ci.hszTopic,szTopic,sizeof(szTopic),CP_WinAnsi);
LoadString(HInstance,2,sz1,sizeof(sz1)); {"...Server %s Toppic %s"}
wsprintf2(szBuffer,sz1,szSvcPartner,szTopic);
LoadString(HInstance,3,sz1,sizeof(sz1)); {"MATLAB DDE Toolbox"}
MessageBox(0,szBuffer,sz1,MB_ApplModal or MB_IconInformation or MB_OK);
end;
function DdeCallback(uType,uFmt:UInt; Conv:hConv;
hsz1,hsz2:Hsz; data: hDdeData; dwData1,dwData2: DWord):HDdeData; stdcall;
{dieser Windows-Rückruf ist eher DDE-Server-typisch; hier filtert er nur
AdvData (für Aktualisierung) und Disconnect (für obige MsgBox)}
begin
DdeCallback:=0; {üblicher Rückgabewert}
case uType of
XTYP_Disconnect: begin
if conv<>0 then advDeleteInfo(Conv,0,0);
DisconnectMsgBox(Conv);
end;
XTYP_AdvData: begin
DdeAdvise(Conv,hsz2,uFmt,data);
DdeCallback:=DDE_fAck; {hier Rückgabewert}
end;
end;
end;
procedure MyExit; cdecl;
{Aufräum-Aktion beim Beenden von Matlab bzw. bei "clear mex|all|ddeinit"}
begin
if (idInst<>0) and DdeUninitialize(idInst) then begin
idInst:=0;
advDeleteInfo(0,0,0); {alle Advises komplett abputzen}
end;
end;
function RegisterDDECallback:Boolean;
const
CBF_Skips=CBF_Skip_Connect_Confirms
or CBF_Skip_Registrations or CBF_Skip_Unregistrations;
var
InitResult: UInt;
i: EClip;
begin
RegisterDdeCallback:=true;
if idInst=0 then begin {beim 1. Aufruf von DDEINIT}
for i:=LOW(EClip) to HIGH(EClip)
do ClipForms[i]:=MyRegisterClipboardFormat(ClipNames[i]);
InitResult:=DdeInitialize(idInst,DDECallback,
APPCLASS_Standard or APPCMD_ClientOnly or CBF_Skips,0);
if InitResult=DMLERR_No_Error then begin
mexAtExit(@MyExit);
end else begin
HandleDdeError(InitResult);
RegisterDdeCallback:=false;
end;
end;
end;
procedure mexFunction(nlhs:LongInt; var plhs:TMatArr;
nrhs:LongInt; const prhs:TMatArr); stdcall;
var
hszService,hszTopic:Hsz;
conv:HConv;
begin
if nlhs=0 then PutErr(16); {will Ausgabe-Variable!}
TestInputArgs(nrhs,prhs,2,2,3,0);
if RegisterDDECallback then begin
hszService:=ArrayToStringHandle(prhs[0]);
hszTopic:=ArrayToStringHandle(prhs[1]);
conv:=DdeConnect(idInst,hszService,hszTopic,nil);
FreeStringHandle(hszService); {Windows sollte Nullen...}
FreeStringHandle(hszTopic); {schlucken ohne zu brechen}
if conv=0 then HandleDdeError(0);
plhs[0]:=mxCreateDoubleMatrix(1,1,mxReal);
mxGetPr(plhs[0])^:=conv;
{Zwar wäre es richtig, hierfür mxUInt32_Class zu bemühen,
damit keiner auf die Idee kommt, mit der Kanalnummer zu rechnen,
aber dann hat man Schwierigkeiten, wenn man diese Variable irgendwo hin
(z.B. in ein Array) steckt.}
end;
end;
exports
mexFunction,
GetInst index 11,
HandleDdeError index 12,
TestInputArgs index 13,
ArrayToStringHandle index 14,
CheckClipFormat index 15,
PutErr index 16,
PutWarn index 17,
MyRegisterClipboardFormat index 18,
ArrayToStringHandles index 19,
FreeStringHandle index 20,
Alloc_Datalen index 21,
str_count_numbers index 22,
str_to_numbers index 23,
str_from_numbers index 24,
PrepareXlTable index 25,
SkipXlFloatHeader index 26,
DdeDataToArray index 27,
mxGetStringW index 31,
mxCreateStringW index 32,
advNewInfo index 41,
advDeleteInfo index 42;
begin {"Geheimer" Schalter}
DisableThreadLibraryCalls(HInstance);
verbose:=GetPrivateProfileInt('DDE','verbose',1,'MATLAB.INI');
end.
| Detected encoding: OEM (CP437) | 1
|
|
|