hedform.pas

使用动态HTML的例子需要安装MS DHTML控制SDK(199KB)

unit hedform;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, OleCtrls, DHTMLEDLib_TLB, ComCtrls, Menus, ExtCtrls, ActiveX,
  mshtml_tlb, IEConst;

type
  TGetInputArg = procedure(Sender : TObject; var pVarIn : OleVariant; var FuncResult : boolean) of object;
  TClearInputArg = procedure(Sender : TObject; var pVarIn : OleVariant) of object;
  TDHEDForm = class(TForm)
    DHTMLEdit1: TDHTMLEdit;
    ToolBar: TPanel;
    NewBtn: TSpeedButton;
    StatusBar1: TStatusBar;
    OpenBtn: TSpeedButton;
    SaveBtn: TSpeedButton;
    BoldBtn: TSpeedButton;
    ItalicBtn: TSpeedButton;
    UnderlineBtn: TSpeedButton;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    New1: TMenuItem;
    Open1: TMenuItem;
    Save1: TMenuItem;
    SaveAs1: TMenuItem;
    N2: TMenuItem;
    Print1: TMenuItem;
    PrintSetup1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    CutBtn: TSpeedButton;
    CopyBtn: TSpeedButton;
    PasteBtn: TSpeedButton;
    TEFindBtn: TSpeedButton;
    TEFontNameBox: TComboBox;
    TEFontSizeBox: TComboBox;
    TEStylesBox: TComboBox;
    procedure DHTMLEdit1DocumentComplete(Sender: TObject);
    procedure DHTMLEdit1DisplayChanged(Sender: TObject);
    procedure BoldBtnClick(Sender: TObject);
    procedure OpenBtnClick(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure ItalicBtnClick(Sender: TObject);
    procedure UnderlineBtnClick(Sender: TObject);
    procedure CutBtnClick(Sender: TObject);
    procedure CopyBtnClick(Sender: TObject);
    procedure PasteBtnClick(Sender: TObject);
    procedure TEFindBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure TEFontNameBoxChange(Sender: TObject);
    procedure TEFontSizeBoxChange(Sender: TObject);
    procedure TEStylesBoxChange(Sender: TObject);
  private
    DocComplete : boolean;
    CommandTarget : IOleCommandTarget;
    DOMInterface : IHtmlDocument2;
    TEIgnoreChange : boolean;
    { Private declarations }
    function GetCommandStatus(ucmdID : Cardinal; bTriEditCmdGroup : boolean) : DWORD;
    function TridentCommand(Cmd : Cardinal; hasInputArg : boolean; promptUser : boolean;
                                 editModeOnly : boolean; bTriEditCommandGroup : boolean;
                                 getInputArg : TGetInputArg; clearInputArg : TClearInputArg) : HRESULT;
    procedure GetTridentCommandState(cmdID : Cardinal; bTrieditCommandGroup : boolean; 
               var bEnabled, bChecked : boolean);
    function HrExecCommand(ucmdID : cardinal; const pVarIn : OleVariant; 
                              var pVarOut : OleVariant; bPromptUser : boolean; 
                              bTriEditCmdGroup : boolean) : HResult;
    procedure GetAvailableStyles;                          
    
    procedure ExecCommand(cmdID, cmdExecOpt, pVar: OleVariant);
    function QueryStatus(cmdID: OleVariant): OleVariant;
    
                      
  public
    { Public declarations }
  end;

var
  DHEDForm: TDHEDForm;

implementation

{$R *.DFM}

var
   NilVariant : OleVariant absolute 0;  
   
procedure TDHEDForm.ExecCommand;
begin
   if (DocComplete) then
      if ((QueryStatus(CmdID) and DECMDF_ENABLED) = DECMDF_ENABLED) then
         DHTMLEdit1.ExecCommand(cmdID, cmdExecOpt, pVar);
end;

function TDHEDForm.QueryStatus(cmdID: OleVariant): OleVariant;
begin
   Result := DHTMLEdit1.QueryStatus(cmdID);
end;


procedure TDHEDForm.DHTMLEdit1DocumentComplete(Sender: TObject);
begin
     DocComplete := True;
     DOMInterface := DHTMLEdit1.Document as IHtmlDocument2;
     CommandTarget := DOMInterface as IOleCommandTarget;
end;

procedure TDHEDForm.DHTMLEdit1DisplayChanged(Sender: TObject);
var
   FontNameStatus : DWORD;
   FontSizeStatus : DWORD;
   StyleNameStatus : DWORD;
   vo : OleVariant;
begin
     if (not DocComplete) then
        exit;
     BoldBtn.Down := ((QueryStatus(DECMD_BOLD) and DECMDF_LATCHED) = DECMDF_LATCHED);
     ItalicBtn.Down := ((QueryStatus(DECMD_ITALIC) and DECMDF_LATCHED) = DECMDF_LATCHED);
     UnderlineBtn.Down := ((QueryStatus(DECMD_UNDERLINE) and DECMDF_LATCHED) = DECMDF_LATCHED);

     CutBtn.Enabled := ((QueryStatus(DECMD_CUT) and DECMDF_ENABLED) = DECMDF_ENABLED);
     CopyBtn.Enabled := ((QueryStatus(DECMD_COPY) and DECMDF_ENABLED) = DECMDF_ENABLED);
     PasteBtn.Enabled := ((QueryStatus(DECMD_PASTE) and DECMDF_ENABLED) = DECMDF_ENABLED);
         
     FontNameStatus := GetCommandStatus(IDM_FONTNAME, False);
     FontSizeStatus := GetCommandStatus(IDM_FONTSIZE, False);
     if ((FontNameStatus and OleCmdf_Enabled) <> 0) then begin
           HrExecCommand(IDM_FONTNAME, NilVariant, vo, false, false);
        if (VarType(vo) = VarOleStr) then
           TEFontNameBox.ItemIndex := TEFontNameBox.Items.IndexOf(Vo);
     end;
     VarClear(vo);
     if ((FontSizeStatus and OleCmdf_Enabled) <> 0) then begin
        HrExecCommand(IDM_FONTSIZE, NilVariant, vo, false, false);
        if (VarType(vo) = VarInteger) then
           TEFontSizeBox.ItemIndex := TEFontSizeBox.Items.IndexOf(vo);
     end;
     
     if (TEStylesBox.Items.Count = 0) then begin
        TEIgnoreChange := true;
        GetAvailableStyles;
        // TEStylesBox.Items.Assign(AvailableStyles);
        TEIgnoreChange := false;
     end;

     varClear(vo);
     StyleNameStatus := GetCommandStatus(IDM_BLOCKFMT, False);
     if ((StyleNameStatus and OleCmdf_Enabled) <> 0) then begin
        TVariantArg(vo).vt := vt_bstr;
        TVariantArg(vo).bStrVal := nil;
        HrExecCommand(IDM_BLOCKFMT, NilVariant, vo, false, false);
        if (VarType(vo) = VarOleStr) then
           TEStylesBox.ItemIndex := TEStylesBox.Items.IndexOf(vo);
     end;
     
end; 

procedure TDHEDForm.GetAvailableStyles;
var
   varRange : OleVariant;
   b : TBStr;
   a : PSafeArray;
   l, h, i : longint;
   hr : HRESULT;
begin
   TVariantArg(VarRange).VT := VT_ARRAY; // VarArray or VarOleStr;
   TVariantArg(VarRange).ppArray := nil;
   hr := HrExecCommand(IDM_GETBLOCKFMTS, NilVariant, VarRange, false, false);
   // OleCheck(hr);
   if (hr = 0) then begin
      l := VarArrayLowBound(VarRange, 1);
      h := VarArrayHighBound(VarRange, 1);
      a := TVariantArg(VarRange).pArray;
      for i := l to h do begin
         SafeArrayGetElement(a, i, b);
         TEStylesBox.Items.Add(OleStrToString(b));
      end;
   end;
end;

procedure TDHEDForm.BoldBtnClick(Sender: TObject);
var
   pCmd : OleVariant;
   pValue : OleVariant;
begin
     pCMD := DECMD_BOLD;
     pValue := not (BoldBtn.Down);
     DHTMLEdit1.ExecCommand(pCmd, OLECMDEXECOPT_DONTPROMPTUSER, pValue);
end;

procedure TDHEDForm.OpenBtnClick(Sender: TObject);
var
 pVIn : OleVariant;
 Prompt : OleVariant;
begin
  pVIn := '';
  Prompt := True;
  DHtmlEdit1.LoadDocument(pVIn, Prompt);
  DocComplete := False;
end;

procedure TDHEDForm.SaveBtnClick(Sender: TObject);
var
  vo, vb : OleVariant;
begin
  vo := DHTMLEdit1.CurrentDocumentPath;
  if (vo <> '') then begin
     vb := false;
  end else begin
     vo := '';
     vb := true;
  end;                                          
  DHTMLEdit1.SaveDocument(vo, vb);
end;

procedure TDHEDForm.SpeedButton1Click(Sender: TObject);
begin
     // ExecCommand(DECMD_BOLD, OLECMDEXECOPT_DONTPROMPTUSER, Null);
     TridentCommand(IDM_BOLD, false, false, true, false, Nil, Nil);
end;

procedure TDHEDForm.ItalicBtnClick(Sender: TObject);
begin
     ExecCommand(DECMD_Italic, OLECMDEXECOPT_DONTPROMPTUSER, Null);
end;

procedure TDHEDForm.UnderlineBtnClick(Sender: TObject);
begin
     ExecCommand(DECMD_Underline, OLECMDEXECOPT_DONTPROMPTUSER, Null);
end;

procedure TDHEDForm.CutBtnClick(Sender: TObject);
begin
   TridentCommand(IDM_CUT, false, false, false, false, nil, nil);
end;

procedure TDHEDForm.CopyBtnClick(Sender: TObject);
begin
   // TridentCommand(IDM_COPY, false, false, false, false, nil, nil);
     ExecCommand(DECMD_COPY, OLECMDEXECOPT_DODEFAULT, Null);
end;

procedure TDHEDForm.PasteBtnClick(Sender: TObject);
begin
     ExecCommand(DECMD_PASTE, OLECMDEXECOPT_DODEFAULT, Null);
end;

function TDHEDForm.GetCommandStatus(ucmdID : Cardinal; bTriEditCmdGroup : boolean) : DWORD;
var
   FMsoCmd : TOleCmd;
begin
   result := 0;
   if (Not Assigned(CommandTarget)) then
      Exit;
   FMsoCmd.CmdID := ucmdID;
   FMsoCmd.cmdf := 0;
   if (bTriEditCmdGroup) then begin
      CommandTarget.QueryStatus(@GUID_TriEditCommandGroup, 1, @FMsoCmd, nil);
   end else begin
      CommandTarget.QueryStatus(@CMDSETID_Forms3, 1, @FMsoCmd, nil);
   end;
   result := FMsoCmd.cmdf;
end;


procedure TDHEDForm.GetTridentCommandState;
var
   dwStatus : DWORD;
begin
   dwStatus := GetCommandStatus(cmdID, bTriEditCommandGroup);
   bEnabled := ((dwStatus and OLECMDF_ENABLED) <> 0);
   bChecked := ((dwStatus and OLECMDF_LATCHED) <> 0);
end;

function TDHEDForm.TridentCommand(Cmd : Cardinal; hasInputArg : boolean; promptUser : boolean;
         editModeOnly : boolean; bTriEditCommandGroup : boolean;
         getInputArg : TGetInputArg; clearInputArg : TClearInputArg) : HRESULT;
var
   pVarIn : OleVariant;       
   bContinue : boolean;
begin
    result := S_OK;
    if (hasInputArg) then begin
       getInputArg(Self, pVarIn, bContinue);
       if (not bContinue) then
          exit;
       result := HrExecCommand(Cmd, pVarIn, nilVariant, promptUser, bTriEditCommandGroup)
    end else begin
       result := HrExecCommand(Cmd, nilVariant, nilVariant, promptUser, bTriEditCommandGroup);
    end;
    if (HasInputArg and Assigned(ClearInputArg)) then
       ClearInputArg(Self, pVarIn);
end;
         
function TDHEDForm.HrExecCommand;
var
   dwCmdOpt : DWORD;
begin
   result := S_OK;
   if (Not Assigned(CommandTarget)) then
      Exit;
   if (bPromptUser) then
      dwCmdOpt := MSOCMDEXECOPT_PROMPTUSER
   else
      dwCmdOpt := MSOCMDEXECOPT_DONTPROMPTUSER;

   if (bTriEditCmdGroup) then begin
      result := CommandTarget.Exec(@GUID_TriEditCommandGroup, 
							ucmdID,
							dwCmdOpt,
							pVarIn,
							pVarOut);
   end else begin
      result := CommandTarget.Exec(@CMDSETID_Forms3,
							ucmdID,
							dwCmdOpt,
							pVarIn,
							pVarOut);
   end;
end;

procedure TDHEDForm.TEFindBtnClick(Sender: TObject);
begin
     TridentCommand(IDM_FIND, false, true, false, false, nil, nil);
end;

procedure TDHEDForm.FormShow(Sender: TObject);
begin
  TEIgnoreChange := true;
  TEFontNameBox.Items.Assign(Screen.Fonts);
  TEIgnoreChange := false;
end;

procedure TDHEDForm.TEFontNameBoxChange(Sender: TObject);
var
   vi, vo : OleVariant;
begin
  if (TEIgnoreChange) then
     exit;
  vi := TEFontNameBox.Text;
  HrExecCommand(IDM_FONTNAME, vi, vo, false, false);
end;

procedure TDHEDForm.TEFontSizeBoxChange(Sender: TObject);
var
   vi, vo : OleVariant;
begin
  if (TEIgnoreChange) then
     exit;
  vi := TEFontSizeBox.ItemIndex + 1;
  HrExecCommand(IDM_FONTSIZE, vi, vo, false, false);
end;

procedure TDHEDForm.TEStylesBoxChange(Sender: TObject);
var
   vi, vo : OleVariant;
begin
  if (TEIgnoreChange) then
     exit;
  vi := TEStylesBox.Text;
  HrExecCommand(IDM_BLOCKFMT, vi, vo, false, false);
end;

end.