wordapi.pas

Delphi写的Microsoft Word模板程序,可以在Word中加入选单。用法：将编译好的testwll.dll改名为test.wll

{$N+}
UNIT WordAPI;

{ Winword 6/95 API interface.
win 16: as copied from Martin Austermeier's capilib.pas
win 32: change types, calling mechanism for wdCommandDispatch
 }

INTERFACE
USES
  Worddecs, sysutils;


CONST
  T_NONE   = 0;
  T_SHORT  = 1;
  T_LONG   = 2;
  T_DOUBLE = 3;
  T_STRING = 4;

CONST
  MAX_ARGS = 34; 

{$IFDEF WIN32}
TYPE
  TFType = SmallInt;
{$ELSE}
TYPE
  TFType = integer;
{$ENDIF}

TYPE
  TArrayDef = RECORD
    cArrayDimensions : Integer;
    arrayDimensions : Array[0..0] OF Byte;
  END;
  PArrayDef = ^TArrayDef;

  AFlag = (T0, T1, T2, T3, DataIsArray, DlgSetData, DlgGetData, bufferTooSmall);
  TFlags = SET OF AFlag;

  PDoubleArray = Pointer;
  PStringArray = ^PChar;

  TOperator = RECORD  
    dat : RECORD CASE Integer OF
      0 : (vShort : Integer);
      1 : (vLong : LongInt);
      2 : (vDouble : Double);
      3 : (vString : PChar);
      4 : (Arr : PArrayDef;
           ptr : RECORD CASE Boolean OF
             FALSE : (DoubleArray : PDoubleArray);
             TRUE : (StringArray : PStringArray);
           END;
          );
    END;

    bufferSize : word;
    ft : RECORD CASE Boolean OF
      FALSE : (flags : TFlags);
      TRUE : (typ : TFType);   
    END;
    fldID : word;
  END;
  POperator = ^TOperator;


TYPE
  { Input and output constants for dialog commands }
  EnumIOMode = (DLG_GET_DATA, DLG_SET_DATA);
  TIOMode = SET OF EnumIOMode;

TYPE  { DlgOption }
  ADlgOption = (CMD_DEFAULTS, { GetCurValues }
                CMD_DIALOG,  {display dialog}
                CMD_ACTION,
                CMD_DLG_ACTION);

TYPE
  TControlBlock = RECORD
    cmdID : Integer;       { *new: command ID }
    retBuf : Pointer;      { *new* for automatic function return }
    retBufSize : word;     { *new* for automatic function return }
    isFunction : Boolean;  { *new: is it a WordBasic FUNCTION? }
    dlgIOMode : TIOMode;   { *new }
    dlgOpts : ADlgOption;  { *new }
    argsCount : Integer;   { cArgs (=index in args array) }
    returnOp : TOperator;  { wdopReturn }
    args : Array[0..MAX_ARGS-1] OF TOperator; { wdoprArgs[MaxArgs] }
  END;
  PControlBlock = ^TControlBlock;

TYPE
  TWordCommand = OBJECT
    wcb : TControlBlock;
    CONSTRUCTOR Create(commandID : Integer; retType : TFType;
                     retBuf : PChar; retBufSize : word);
    { commandID: see worddecs.PAS;
      retType : type of function return;
      retBuf : (only if retType <> T_NONE) pointer to a buffer where
                RETURNed values are to be stored (max Len=retBufSize) }
    DESTRUCTOR Done;
    PROCEDURE AddShortParam(shortVal : Integer);
    PROCEDURE AddLongParam(longVal : Integer);
    PROCEDURE AddDoubleParam(doubleVal : Double);
    PROCEDURE AddStringParam(strP : PChar);
    FUNCTION Execute : Integer;
          { call wdCommandDispatch; returns 0 if OK, else wdError.xx }
  PRIVATE
    PROCEDURE _GetResult(buffer : Pointer; bufSize : word);
          { copies function result into buffer^, if available }
  END;


  TWordDlgCommand = OBJECT(TWordCommand)
    CONSTRUCTOR Create(commandID:Integer; retType:TFType; retBuf:PChar;
                     retBufSize:word; dialogOption:ADlgOption; fMode:TIOMode);
    PROCEDURE AddShortDlgField(fieldId: word; shortVal: Integer);
    PROCEDURE AddLongDlgField(fieldId: word; longVal: LongInt);
    PROCEDURE AddDoubleDlgField(fieldId: word; doubleVal: Double);
    PROCEDURE AddStringDlgField(fieldId: word; strP: PChar; bufSize: word);
  PRIVATE
    PROCEDURE _SetDlgField(fieldId : word; fType : TFType);
  END;

(*  TWordArrayCommand = OBJECT(TWordCommand)
    { AddStringArray; AddDoubleArray NOT IMPLEMENTED! }
  END;
*)

(* miscellaineous useful commands *)
FUNCTION wbRegister(docID:Integer; functionName,description:ShortString):word;
Function wbAddToolbar(context:integer; tbname:shortstring):word;
Function wbAddButton(context:integer; tbname:shortstring; position:integer;
                      Macro,Face:shortstring):word;
Function wbAddMenu(context:integer; MName:shortstring; Position, Menutype:integer):word;
Function wbAddMenuItem(context:integer; MName, MCommand, MText:shortstring;
                        position, MType:integer):word;
Function wbAddKey(context,KeyCode:integer; KCommand:shortstring):word;
FUNCTION ExecuteCommand(VAR wcb : TWordCommand) : Boolean;

IMPLEMENTATION
USES
  WinTypes, WinProcs;

(****************************************************************************
                       utility functions
 ****************************************************************************)
PROCEDURE ErrorBox(caption : PChar; err : Integer);
VAR
  s : Array[0..50] OF Char;
BEGIN
  Strpcopy(s, errordesc(err));
  MessageBox(0, s, caption, MB_OK);
END;


FUNCTION ExecuteCommand(VAR wcb : TWordCommand) : Boolean;
{ call Word API; display error message }
VAR
  i : Integer;
  st : Array[0..5] OF Char;
BEGIN
  i := wcb.Execute;         { Execute the command }

  IF (i <> 0) THEN BEGIN
    Str(wcb.wcb.cmdId, st);  { use cmdID as error box caption }
    ErrorBox(st, i);
  END;
  ExecuteCommand := (i = 0);
END;

(*************************************************************************
                             TWordCommand
 *************************************************************************)

CONSTRUCTOR TWordCommand.Create(commandID : Integer;
                               retType : TFType;
                               retBuf : PChar;
                               retBufSize : word);
BEGIN
  FillChar(wcb, SizeOf(wcb), 0);

  wcb.cmdID := commandID;
  wcb.returnOp.ft.typ := retType;
  wcb.retBuf := retBuf;
  wcb.retBufSize := retBufSize;

  IF (retType = T_STRING) THEN WITH wcb.returnOp DO
   BEGIN
    dat.vString := retBuf;
    bufferSize := retBufSize;
   END;
END;

DESTRUCTOR TWordCommand.Done;
BEGIN
   { remove VMT! }
END;

PROCEDURE TWordCommand.AddShortParam(shortVal : Integer);
BEGIN
  WITH wcb.args[wcb.argsCount] DO
   BEGIN
    dat.vShort := shortVal;
    ft.typ := T_SHORT;
   END;
  Inc(wcb.argsCount);
END;

PROCEDURE TWordCommand.AddLongParam(longVal : Integer);
BEGIN
  WITH wcb.args[wcb.argsCount] DO
   BEGIN
    dat.vLong := longVal;
    ft.typ := T_LONG;
   END;
  Inc(wcb.argsCount);
END;

PROCEDURE TWordCommand.AddDoubleParam(doubleVal : Double);
BEGIN
  WITH wcb.args[wcb.argsCount] DO
   BEGIN
    dat.vDouble := doubleVal;
    ft.typ := T_DOUBLE;
   END;
  Inc(wcb.argsCount);
END;

PROCEDURE TWordCommand.AddStringParam(strP : PChar);
BEGIN
  WITH wcb.args[wcb.argsCount] DO
   BEGIN
    dat.vString := strP;
    ft.typ := T_STRING;
   END;
  Inc(wcb.argsCount);
END;

PROCEDURE TWordCommand._GetResult(buffer : Pointer; bufSize : word);
BEGIN
  IF (wcb.returnOp.ft.typ = T_NONE)  { no function result }
      OR (wcb.returnOp.ft.typ = T_STRING) { unnecessary with T_STRING }
      OR (buffer = NIL)  { no return buffer provided }
    THEN Exit;
  Move (wcb.returnOp.dat, buffer^, bufSize);  { copy result to buffer }
END;

{$IFDEF WIN32}
type tworddispatcher = FUNCTION (commandId, dlgOptions, cArgs : Integer;
              operators : POperator; ret : POperator) : Integer;   stdcall;

FUNCTION WdCommandDispatch(commandId, dlgOptions, cArgs : Integer;
                           operators : POperator; ret : POperator) : Integer;
var proc:tworddispatcher;
begin
{ word must already be loaded if dll is being called}
 @proc := nil;
 @proc := GetProcAddress(GetModuleHandle(nil), 'wdCommandDispatch');
 if @proc = nil then result := errWLLNoWordFound else
 result := proc(commandId, dlgOptions, cArgs, operators, ret);
end;
{$ELSE}
FUNCTION WdCommandDispatch(commandId, dlgOptions, cArgs : Integer;
                           operators : POperator; ret : POperator) : Integer;
FAR; EXTERNAL 'WINWORD';
{$ENDIF}

FUNCTION TWordCommand.Execute : Integer;
VAR
  retP : POperator;
  ret : Integer;
BEGIN
  WITH wcb DO
   BEGIN
    IF (returnOp.ft.typ <> T_NONE) THEN retP := @returnOp ELSE retP := NIL;
    ret := WdCommandDispatch(cmdId, Integer(dlgOpts), argsCount, @args, retP);
    IF (ret = 0) THEN _GetResult(retBuf, retBufSize) else errorbox('debug',ret);
    result := ret;
   END;
END;

(*************************************************************************
                           TWordDlgCommand
 *************************************************************************)
CONSTRUCTOR TWordDlgCommand.Create(commandID : Integer;
                 retType : TFType;
                 retBuf : PChar;
                 retBufSize : word;
                 dialogOption : ADlgOption;
                 fMode : TIOMode);
BEGIN
  INHERITED Create(commandID, retType, retBuf, retBufSize);
  wcb.dlgOpts := dialogOption;
  wcb.dlgIOMode := fMode;
END;

PROCEDURE TWordDlgCommand._SetDlgField(fieldId : word; fType : TFType);
BEGIN
  WITH wcb.args[wcb.argsCount] DO
   BEGIN
    ft.typ := fType;
    fldId := fieldId;
    IF (DLG_GET_DATA IN wcb.dlgIOMode) THEN Include(ft.flags, DlgGetData);
    IF (DLG_SET_DATA IN wcb.dlgIOMode) THEN Include(ft.flags, DlgSetData);
   END;
END;

PROCEDURE TWordDlgCommand.AddShortDlgField(fieldId : word; shortVal : Integer);
BEGIN
  wcb.args[wcb.argsCount].dat.vShort := shortVal;
  _SetDlgField(fieldId, T_SHORT);
  Inc(wcb.argsCount);
END;

PROCEDURE TWordDlgCommand.AddLongDlgField(fieldId : word; longVal : LongInt);
BEGIN
  wcb.args[wcb.argsCount].dat.vLong := longVal;
  _SetDlgField(fieldId, T_LONG);
  Inc(wcb.argsCount);
END;

PROCEDURE TWordDlgCommand.AddDoubleDlgField(fieldId : word; doubleVal : Double);
BEGIN
  wcb.args[wcb.argsCount].dat.vDouble := doubleVal;
  _SetDlgField(fieldId, T_DOUBLE);
  Inc(wcb.argsCount);
END;

PROCEDURE TWordDlgCommand.AddStringDlgField(fieldId : word; strP : PChar; bufSize : word);
BEGIN
  wcb.args[wcb.argsCount].dat.vString := strP;
  _SetDlgField(fieldId, T_STRING);
  wcb.args[wcb.argsCount].bufferSize := bufSize;
  Inc(wcb.argsCount);
END;

(*************************************************************************
                        Useful Setup Functions
 *************************************************************************)
FUNCTION wbRegister;
VAR wcb:TWordCommand;
    p1,p2:Array [0..50] of char;
BEGIN
  wcb.Create(wdAddCommand, T_none, NIL, 0);             { was t_short }
  wcb.AddShortParam(docID);
  strpcopy(p1,functionName);
  wcb.AddStringParam(p1);
  IF description<>'' THEN
   begin
    strpcopy(p2,description);
    wcb.AddStringParam(p2);
   end;
  Result := wcb.Execute;
  wcb.done;
END;

Function wbAddToolbar;
var wcb:TWordDlgCommand;
    p1:array [0..50] of char;
Begin
  wcb.create(wdNewToolbar, T_Short, NIL, 0, CMD_Action, [DLG_Set_Data]);
  strpcopy(p1,tbname);
  wcb.AddStringDlgField(FidName, p1, strlen(p1));
  wcb.AddShortDlgField(fidcontext, context);
  Result := wcb.execute;
  wcb.done;
end;

Function wbAddButton;
var wcb:TWordCommand;
    p1,p2,p3:array [0..50] of char;
begin
  wcb.Create(wdAddButton, T_Short, nil, 0);
  strpcopy(p1,tbname);
  wcb.AddStringParam(p1);
  wcb.addShortParam(position);
  wcb.addshortparam(1);
  strpcopy(p2,Macro);
  wcb.AddStringParam(p2);
  strpcopy(p3,Face);
  wcb.AddStringParam(p3);
  wcb.AddShortParam(Context);
  result := wcb.execute;
  wcb.done;
end;

Function wbAddMenu;
var wcb:TWordDlgCommand;
    p1:array [0..50] of char;
begin
  wcb.create(wdToolsCustomizeMenuBar, T_Short, nil,
                                0, CMD_Action, [DLG_Set_Data]);
  strpcopy(p1,MName);
  wcb.AddStringDlgField(fidMenuText, p1,strlen(p1));
  wcb.AddShortDlgField(fidPosition, Position);
  wcb.AddShortDlgField(fidAdd, 1);
  wcb.AddShortDlgField(fidMenuType, MenuType);
  wcb.addShortdlgField(fidContext, Context);
  result := wcb.execute;
  wcb.done;
end;

Function wbAddMenuItem;
var wcb:TWordDlgCommand;
    p1,p2,p3:array [0..50] of char;
begin
  wcb.create(wdToolsCustomizeMenus, T_Short, nil, 0, CMD_Action, [DLG_Set_Data]);
  wcb.AddShortDlgField(fidContext, Context);
  strpcopy(p1,MName);
  wcb.AddStringDlgField(fidMenu,p1,strlen(p1));
  strpcopy(p2,MCommand);
  wcb.AddStringDlgField(fidName,p2,strlen(p2));
  strpcopy(p3,MText);
  wcb.AddStringDlgField(fidMenuText,p3,strlen(p3));
  wcb.addshortdlgField(fidPosition,position);
  wcb.addshortdlgField(fidMenuType,MType);
  wcb.addshortdlgField(fidCategory,1);
  wcb.addshortdlgField(fidAdd,1);
  result := wcb.execute;
  wcb.done;
end;

Function wbAddKey;
var wcb:TWordDlgCommand;
    p1:array [0..50] of char;
begin
  wcb.create(wdToolsCustomizeKeyBoard, T_Short, nil, 0, CMD_Action, [DLG_Set_Data]);
  wcb.AddShortDlgField(fidKeyCode, KeyCode);
  wcb.addshortdlgField(fidCategory,1);
  strpcopy(p1,KCommand);
  wcb.AddStringDlgField(fidName,p1,strlen(p1));
  wcb.addshortdlgField(fidAdd,1);
  wcb.addshortdlgField(fidContext,Context);
  result := wcb.execute;
  wcb.done;
end;

end.