Delphi 开发Excel Xll

774115495 · 发表于 2022-7-9 16:40

本帖最后由 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.

复制代码

		自动登录	找回密码
密码			免费注册

[原创] Delphi 开发Excel Xll