|
本帖最后由 774115495 于 2022-7-9 16:47 编辑
网上Delphi 开发Excel Xll 资料很少,本代码也是从网上获取而得,删除了一些不必要的代码,优化了相关代码,可以支持Excel2000-2021 32位版本,
64位源码不免费提供,有兴趣的可以叫我QQ。
本源码使用Excel4V函数,仅支持30的参数。
Excel12V函数支持255个参数。
源代码可以详见附件下载。
以下部分代码显示
- {$A+,B-,C+,D+,E-,F-,G+,H-,I+,J+,K-,L+,M-,N+,O-
- ,P+,Q+,R-,S-,T-,U-,V+,W+,X+,Y-,Z1}
- library MyExcelXll_For_Win32;
- uses
- SysUtils,
- windows;
- // XLREF structure
- type
- xlref = packed record
- rwFirst: smallint;
- rwLast: smallint;
- colFirst: byte;
- colLast: byte;
- end;
- // Returns a range of selection
- XlRangeRecord = packed record
- Count: word; // should always be $1
- Sref: xlref;
- end;
- xlmref = packed record
- count: word;
- RefTbl: array[0..1000] of XlRef;
- end;
- lpxloper = ^XLOPER;
- lpxloperArray = ^XLArray;
- lpxlmref = ^xlmref;
- DLLversion: shortstring = 'ExcelLib v1.00';
- AddInCategory = 'ExcelLib_32';
- const
- zlpxloper = lpxloper(nil);
- type
- retarray = array[0..1000] of xloper;
- pretarray = ^retarray;
- var // Global data
- res: xloper;
- EResult: Integer;
- sink: integer;
- UDF_Id: Integer;
- LastErrorStr: ShortString;
- FuncName: string[64];
- pxModuleText, pxProcedure, pxTypetext, pxFunctiontext, pxArgumentText, pxMacroType, pxCategory, pxShortcutText: txloper;
- HaveRegistered: boolean;
- procedure setval(var v: xloper; numval: double);
- begin
- fillchar(v, sizeof(v), 0);
- v.xltype := 1;
- v.val.num := numval;
- end;
- procedure SetFunctionName(S: ShortString);
- begin
- FuncName := S;
- end;
- procedure Error(S: ShortString);
- begin
- if LastErrorStr <> S then
- LastErrorStr := FuncName + ':' + S;
- end;
- function GetSheetName: ShortString;
- var
- xres, xsheetname: xloper;
- ResStr: ShortString;
- begin
- ResStr := '';
- Eresult := Excel4V(xlfCaller, @xres, 0, [nil]);
- asm
- pop sink; // sink: integer;
- end; // Never Remove
- if Eresult = 16 then
- ResStr := 'No Caller ID'
- else
- begin
- eresult := Excel4V(xlsheetnm, @xsheetname, 1, [@xres]);
- asm
- pop sink;
- end; // Never Remove
- if eresult = 0 then
- begin
- ResStr := xsheetname.val.str^;
- end
- end;
- Eresult := Excel4V(xlfree, nil, 1, [@xres]);
- asm
- pop sink;
- end; // Never Remove
- Eresult := Excel4V(xlfree, nil, 1, [@xsheetname]);
- asm
- pop sink;
- end; // Never Remove
- Result := ResStr;
- end;
- // Returns full path & name of DLL
- function GetName: ShortString;
- begin
- EResult := Excel4V(xlGetName, @res, 1, [nil]);
- asm
- pop sink;
- end; // Never Remove
- Result := res.val.str^;
- EResult := Excel4V(xlfree, nil, 1, [@res]);
- asm
- pop sink;
- end; // Never Remove
- end;
- //Generates one value of the standard Gaussian density function }
- function UDF_Add(DoubleX, DoubleY: Double): Double; stdcall;
- begin
- Result := DoubleX + DoubleY;
- end;
- function Register_UDF: integer;
- var
- s: Shortstring;
- begin
- Res.xltype := xltypeerr;
- Res.val.err := xlerrvalue;
- s := GetName;
- pxModuleText.SetStr(s);
- pxProcedure.SetStr('UDF_Add');
- pxTypeText.SetStr('BBB'); // Double, Double
- pxFunctionText.setStr('UDF_Add');
- pxArgumentText.SetStr('DoubleX, DoubleY');
- pxMacrotype.SetNum(1);
- pxCategory.SetStr(AddInCategory);
- EResult := Excel4V(xlfregister, @res, 8, [pxModuletext.thelpxloper, pxProcedure.thelpxloper, pxTypeText.thelpxloper, pxFunctionText.thelpxloper, pxArgumentText.thelpxloper, pxMacroType.thelpxloper, pxCategory.thelpxloper, zlpxloper]);
- asm
- pop sink;
- end; // Never Remove
- Result := trunc(res.val.num);
- end;
- procedure Register_All;
- begin
- if HaveRegistered then
- exit;
- HaveRegistered := true;
- pxModuleText := txloper.Create;
- pxProcedure := txloper.Create;
- pxTypetext := txloper.Create;
- pxFunctiontext := txloper.Create;
- pxArgumentText := txloper.Create;
- pxMacroType := txloper.Create;
- pxCategory := txloper.Create;
- pxShortCutText := txloper.Create;
- UDF_Id := Register_UDF;
- pxShortCutText.Free;
- pxCategory.free;
- pxMacroType.free;
- pxArgumentText.free;
- pxFunctiontext.free;
- pxTypetext.free;
- pxProcedure.free;
- pxModuleText.free;
- end;
- // Removes all Registered Functions
- procedure UnRegister_All;
- var
- Module: txloper;
- procedure DeRegister(Id: Integer);
- begin
- Module.SetNum(Id);
- EResult := Excel4V(xlfunregister, @res, 1, [Module.thelpxloper]);
- asm
- pop sink;
- end; // Never Remove
- end;
- begin
- Module := txloper.Create;
- DeRegister(UDF_Id);
- Module.Free;
- end;
- function xlAutoClose: integer; stdcall;
- begin
- Unregister_All;
- result := 1;
- end;
- function xlAutoOpen: integer; stdcall;
- begin
- Register_All;
- result := 1;
- end;
- function xlAddInManagerInfo(xl: lpxloper): lpxloper; stdcall;
- var
- xint, xintval: xloper;
- begin
- xint.xltype := xltypeint; // Always used to specify type of input
- xint.val.w := xltypeInt; // Conversion type is set here
- EResult := Excel4V(xlcoerce, @xintval, 2, [xl, @xint]);
- asm
- pop sink;
- end; // Never Remove
- if (xintval.val.w = 1) then
- begin
- res.xltype := xltypestr;
- res.val.str := @DLLversion;
- end
- else
- begin
- res.xltype := xltypeerr;
- res.val.err := 15;
- end;
- result := @res;
- end;
- function xlAutoRegister(pXName: lpxloper): lpxloper; stdcall;
- begin
- Result := @res;
- end;
- function xlAutoRemove: integer; stdcall;
- begin
- // MessageBox(GetActiveWindow, 'MyXll卸载成功', '提示', MB_ICONINFORMATION or MB_OK);
- // Tidy Up code here
- result := 1;
- end;
- function xlAutoAdd: integer; stdcall;
- begin
- Register_All;
- // MessageBox(GetActiveWindow, 'MyXll安装成功', '提示', MB_ICONINFORMATION or MB_OK);
- result := 1;
- end;
- procedure xlAutoFree(ramptr: lpxloper); stdcall;
- begin
- Freemem(ramptr);
- end;
- constructor txloper.create;
- begin
- inherited Create;
- fillchar(factualStr, sizeof(fActualStr), 0);
- fillchar(fxloper, sizeof(fxloper), 0);
- end;
- destructor txloper.Destroy;
- begin
- inherited Destroy;
- end;
- constructor txloper.Create_Str(NewStr: ShortString);
- begin
- inherited Create;
- fillchar(fxloper, sizeof(fxloper), 0);
- fillchar(factualstr, sizeof(factualstr), 0);
- SetStr(NewStr);
- end;
- procedure txloper.SetStr(NewStr: ShortString);
- begin
- fillchar(factualstr, sizeof(factualstr), 0);
- factualstr := NewStr;
- fxloper.xltype := xlTypeStr;
- fxloper.val.Str := addr(fActualStr);
- end;
- procedure txloper.SetErr;
- begin
- fxloper.xltype := xltypEerr;
- fxloper.val.err := xlerrvalue;
- end;
- procedure txloper.SetNum(NewNumber: Integer);
- begin
- fxloper.xltype := xltypeNum;
- fxloper.val.num := NewNumber;
- end;
- procedure txloper.SetInt(NewNumber: Integer);
- begin
- fxloper.xltype := xltypeInt;
- fxloper.val.num := NewNumber;
- end;
- function txloper.Getlpxloper: lpxloper;
- begin
- result := addr(fxloper);
- end;
- exports
- // Excel Recognition functions
- xlAutoFree,
- xlAutoAdd,
- xlAutoOpen,
- xlAutoClose,
- xlAutoRemove,
- xlAutoRegister,
- xlAddInManagerInfo,
- // Exported Invisible Functions
- UDF_Add;
- begin
- HaveRegistered := false;
- end.
复制代码
|
|