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 fr alle DDE-DLLs,...}
{Lesezugriff fr alle via GetInst-Funktion}
type
EClip=(Text,Unicode,XlTable,MatTable);
const
ClipNames: array[EClip] of PChar=(
'Text', {normaler ASCII-Text}
'UnicodeText', {16-bit-Zeichen fr's Japanisch}
'XlTable', {Clipboard-Format-Name fr FastDDE}
'MatTable'); {fr Double-Matrizen und -Arrays}
var {die Ergebnisse von RegisterClipboardFormat,...}
ClipForms: array[EClip] of UInt; {fr CheckClipFormat zur Umsetzung}
verbose: Integer;
{Schlafmtzen, 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 fr 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 hufigste Fehler wird sonst auf die Dauer lstig}
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 fr %ites Arg nicht erlaubt!"}
break;
end;
if (permitNumeric and (1 shl i) =0)
and mxIsNumeric(prhs[i]) then begin
strcode:=8; {"Numerisch fr %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
(fr 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 Rckkehr
Verarbeitet sowohl Zahlen als auch (neu) Konstanten-Strings
Bei Angabe des Parameters ocp wird auf Zwei-Element-Array getestet,
fr DDEREQ und DDEADV, und so der Rckgabe-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 Textrckgabe, sonst binr}
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)); {"ungltiges CF"}
wsprintf1(szBuf,szTemp,PChar(cf));
mexErrMsgTxt(szBuf);
CheckClipFormat:=Text; {Compiler ruhigstellen}
end;
procedure PutErr(strcode:UInt); stdcall;
{einfache Fehlermeldung fr 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 fr 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; {Lnge eines DOUBLE in Zeichen, volle Przision}
function Alloc_Datalen(format:EClip; x,y:LongInt; var datalen: UInt):PChar;
stdcall;
{Berechnet die bentigte Menge an Speicherplatz fr die angegebenen
Dimensionen und fordert ihn an. Nur fr max. zweidimensionales!
Liefert nie NIL; bricht ggf. mit mexErrMsgTxt() ab.
Speicher ist mit Nullen gefllt}
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 fr 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-Lnge!}
end;
XlTable: begin
if (x>=65536) or (y>=65536) then PutErr(11);{zu groe Matrixausdehnung}
datablocks:=(datalen+$7FFF) div $8000; {also 32-KB-Blcke}
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);
{(anfnglichen) Weiraum bergehen}
begin
while s^ in [#9,#13,' '] do inc(s);
end;
procedure str_find_lt(var s:PChar; dp:PDouble);
{Listentrenner suchen, dabei nachfolgenden Weiraum (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 wre 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;
{Zhlt 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 bentigt.
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 zunchst auf 2}
end;
end;
end;
if x<xx then x:=xx; {wenn letzte Zeile magebend}
end;
procedure PrepareXlTable(var dp:PDouble; x,y: LongInt); stdcall;
{Fllt 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 erhhen}
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 Blocklnge
in Doubles; hoffentlich ist die Blocklnge 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 umstndlich wegen des Strzens 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 nchsten Zwischenheader}
until yges<0;
Inc(PChar(Result),x);
end;
procedure str_to_numbers(s:PChar; x,y:LongInt; dp:PDouble;
skipxl:Bool); stdcall;
{wandelt durchgezhlten 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 fllen}
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 untersttzt}
Result:=mxCreateCharArray(2,@mn);
dp:=mxGetPr(Result);
while mn[1]>0 do begin
dp^:=LongInt(sp^); {mit Daten fllen}
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);
{rckt indata vor und liest x und y ein}
var
wp: PWord;
begin
wp:=Pointer(indata); Inc(indata); {gleich um 8 vorrcken}
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, mssen sie Double sein}
end;
function DdeDataToArray(hindata:HDdeData; format:EClip; outchar: Bool):
PArray; stdcall;
{gemeinsame Routine fr 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; {fr verkettete Liste}
conv: HConv; {diese 3 Parameter...}
item: Hsz; {...identifizieren...}
cf: UInt; {...den richtigen Link}
format: EClip; {fr uns zum Daten konvertieren}
outchar: Bool; {numerischer oder String-Output?}
arrayname: array[0..mxMAXNAM-1] of Char; {keine Unicodes mglich}
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 Lschen gebraucht, darf NIL sein.
Bei Rckgabe von FALSE ist cur^ unverndert}
var
ap: PAdvInfo; {"krzerer" 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;
{Lscht die Daten aus der einfach verketteten Liste;
der Aufruf mit allen drei Parametern =0 lscht alles.
Die zugehrigen String-Handles werden freigegeben.
Falls "multithreadend", msste 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 aushngen}
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 ermglicht 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 einhngen}
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-Rckruf ist eher DDE-Server-typisch; hier filtert er nur
AdvData (fr Aktualisierung) und Disconnect (fr obige MsgBox)}
begin
DdeCallback:=0; {blicher Rckgabewert}
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 Rckgabewert}
end;
end;
end;
procedure MyExit; cdecl;
{Aufrum-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 wre es richtig, hierfr mxUInt32_Class zu bemhen,
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.
| Vorgefundene Kodierung: UTF-8 | 0
|