ufrmtools.~pas

pas脚本编译,编译写好的脚本,运用了fastscript控件

unit UFrmTools;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, AdvMenus, AdvMemo, StdCtrls, AdvmPS, ExtCtrls, RzPanel,
  RzSplit, fs_ipascal, fs_iformsrtti, fs_igraphicsrtti, fs_iclassesrtti,
  fs_iinterpreter,fs_itools, fs_synmemo, fs_idialogsrtti, fs_iextctrlsrtti,
  fs_idbrtti, fs_idbctrlsrtti, fs_ibdertti, fs_iadortti, fs_tree,
  fs_iibxrtti, fs_ichartrtti, fs_ibasic, fs_ijs, fs_icpp, RzLaunch,UTest,
  WinSkinData,UFrmAbout,adodb, ImgList, DB, DBTables;

type
  TFrmEdt = class(TForm)
    advmCon: TAdvMemo;
    advmnmn: TAdvMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    Exit1: TMenuItem;
    Script1: TMenuItem;
    Compile1: TMenuItem;
    Stop1: TMenuItem;
    advpsclmstylr1: TAdvPascalMemoStyler;
    Status: TMemo;
    Splitter1: TSplitter;
    dlgOpen: TOpenDialog;
    fsScript1: TfsScript;
    frClassesRTTI1: TfsClassesRTTI;
    frGraphicsRTTI1: TfsGraphicsRTTI;
    frFormsRTTI1: TfsFormsRTTI;
    fsPascal1: TfsPascal;
    dlgSave: TSaveDialog;
    fsdrt1: TfsADORTTI;
    fsbdrt1: TfsBDERTTI;
    fsdbctrlsrt1: TfsDBCtrlsRTTI;
    fsdbrt1: TfsDBRTTI;
    fsxtctrlsrt1: TfsExtCtrlsRTTI;
    fsdlgsrt1: TfsDialogsRTTI;
    Splitter2: TSplitter;
    fstr1: TfsTree;
    fscp1: TfsCPP;
    fsjscrpt1: TfsJScript;
    fsbsc1: TfsBasic;
    fschrtrt1: TfsChartRTTI;
    fsbxrt1: TfsIBXRTTI;
    About1: TMenuItem;
    rzlnchr: TRzLauncher;
    skndt1: TSkinData;
    About2: TMenuItem;
    New1: TMenuItem;
    procedure FormShow(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure Compile1Click(Sender: TObject);
    procedure fsScript1RunLine(Sender: TfsScript; const UnitName,
      SourcePos: String);
    procedure FormCreate(Sender: TObject);
    procedure advmConKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure About2Click(Sender: TObject);
    procedure New1Click(Sender: TObject);
    procedure advmConFileDrop(Sender: TObject; FileName: String;
      var DefaultHandler: Boolean);
    procedure advmConChange(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private declarations }
    function msgbox(str: String;mType:Cardinal):integer;
    function CallMethod(Instance: TObject; ClassType: TClass;const MethodName: String; var Params: Variant): Variant;
  public
    FRunning: Boolean;
    FStopped:Boolean;
    { Public declarations }
  end;
   function StrRight(Str: string; Len: Integer): string;


var
  FrmEdt: TFrmEdt;
  EdtName:string;
  NdSave:Boolean;




implementation

{$R *.dfm}
function TFrmEdt.msgbox(str: String;mType:Cardinal):integer;
begin

  result:=Application.MessageBox(PChar(str),'提示',mType);//  MB_OK+MB_ICONINFORMATION
end;
procedure TFrmEdt.FormShow(Sender: TObject);
begin
  //Status.Lines.Clear;
  //ShowMessage(EdtName);
  advmCon.Lines.Clear;
  advmCon.Lines.Add('Begin');
  advmCon.Lines.Add('');
  advmCon.Lines.Add('End.');
  advmCon.CurY:=1;
  advmCon.CurX:=0;
  if EdtName<>'' then
  begin
     advmCon.Lines.LoadFromFile(EdtName);
     Caption :='脚本编译工具 '+EdtName;
  end;
  NdSave:=False;
end;

function TFrmEdt.CallMethod(Instance: TObject; ClassType: TClass;
  const MethodName: String; var Params: Variant): Variant;
begin
  { dispatch the method call }
if MethodName = 'MSGBOX' then
    result:=msgbox(Params[0],Params[1])
else if MethodName = 'EXTRACTFILEPATH' then //ExtractFilePath
    Result :=EXTRACTFILEPATH(Params[0])
end;
procedure TFrmEdt.N3Click(Sender: TObject);
begin
  if EdtName ='' then
  begin
  dlgsave.FileName :='';
  dlgSave.Filter :='Script files (*.Script)|*.Script';
  dlgsave.FilterIndex :=1;
  dlgsave.Execute;
  if dlgsave.FileName ='' then exit;
  if StrRight(dlgsave.FileName, 7)<>'.Script' then   dlgsave.FileName:=dlgsave.FileName+'.Script';
  EdtName :=dlgsave.FileName;
  end
  else
  begin
   dlgsave.FileName:= EdtName;
  end;
  advmCon.Lines.SaveToFile(dlgsave.FileName);
  Caption :='脚本编译工具 '+dlgsave.FileName;
  NdSave:=false;

end;

procedure TFrmEdt.N2Click(Sender: TObject);
begin
    dlgOpen.FileName :='';
    dlgOpen.Execute;
    if dlgOpen.FileName ='' then exit;
    EdtName:=dlgOpen.FileName;
    advmCon.Lines.LoadFromFile(dlgOpen.FileName);
    Caption :='脚本编译工具 '+dlgOpen.FileName;
end;

function StrRight(Str: string; Len: Integer): string;
begin
  if Len >= Length(Str) then
    Result := Str
  else
    Result := Copy(Str, Length(Str) - Len + 1, Len);
end;

procedure TFrmEdt.N4Click(Sender: TObject);
begin
dlgsave.FileName :='';
dlgSave.Filter :='Script files (*.Script)|*.Script';
//dlgsave.FilterIndex :=1;
dlgsave.Execute;
if dlgsave.FileName ='' then exit;
if StrRight(dlgsave.FileName, 7)<>'.Script' then   dlgsave.FileName:=dlgsave.FileName+'.Script';
advmCon.Lines.SaveToFile(dlgsave.FileName);
EdtName:=dlgsave.FileName;
Caption :='脚本编译工具 '+dlgsave.FileName;
NdSave:=False;
end;

procedure TFrmEdt.Exit1Click(Sender: TObject);
begin
Close;
application.Terminate;
end;

procedure TFrmEdt.Compile1Click(Sender: TObject);
var
  t: UInt;
  p: TPoint;
begin
  Status.Lines.Clear;
  Status.Lines.Add ('正在编译.....');

  if FRunning then
  begin
    if Sender = Compile1 then
    fsScript1.OnRunLine := nil;
    FStopped := False;
    Exit;
  end;

  fsScript1.Clear;
  fsScript1.Lines := advmCon.Lines;
  fsScript1.SyntaxType :='PascalScript';
  fsScript1.Parent := fsGlobalUnit;
  fsScript1.AddMethod('function msgbox(str: String;mType:Cardinal):integer',CallMethod);
  fsScript1.AddMethod('function ExtractFilePath(const FileName: string): string',CallMethod);
//  fsScript1.AddClass()

  if not fsScript1.Compile then
  begin
    advmCon.SetFocus;
    p := fsPosToPoint(fsScript1.ErrorPos);
    //advmCon.SetPos(p.X, p.Y);
    advmCon.ActiveLine :=p.Y-1;
    if fsScript1.ErrorUnit = '' then
      Status.Lines.Add (fsScript1.ErrorMsg) else
      Status.Lines.Add (fsScript1.ErrorUnit + ': ' + fsScript1.ErrorMsg);
    Exit;
  end
  else
  Status.Lines.Add ( '编译成功, 执行成功');

  Application.ProcessMessages;
  t := GetTickCount;

  if Sender = Compile1 then
    fsScript1.OnRunLine := nil else
    fsScript1.OnRunLine := fsScript1RunLine;

  FRunning := True;
  try
    fsScript1.Execute;
  finally
    FRunning := False;
    Status.Lines.Add ( 'Exception in the program');
  end;
 Status.Lines.Add ( 'Executed in ' + IntToStr(GetTickCount - t) + ' ms');
end;

procedure TFrmEdt.fsScript1RunLine(Sender: TfsScript; const UnitName,
  SourcePos: String);
var
  p: TPoint;
begin
  { enable main window to allow debugging of modal forms }
  EnableWindow(Handle, True);
  SetFocus;
  p := fsPosToPoint(SourcePos);
  FStopped := True;
  while FStopped do
    Application.ProcessMessages;
end;

procedure TFrmEdt.FormCreate(Sender: TObject);
begin

fsGlobalUnit.AddForm(FrmEdt);
fsGlobalUnit.AddObject('application',Application);
end;

procedure TFrmEdt.advmConKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
if (Shift=[ssCtrl]) and (Key=$5A) then //'Z'的KEY=$5A
advmCon.Undo;

end;
{
//关联文件
procedure RegisterFileType(cMyExt,cMyFileType,cMyDescription,ExeName:string;
                          IcoIndex:integer;
                          DoUpdate:boolean=false);
var
  Reg: TRegistry;
begin
  Reg:=TRegistry.Create;
  try
    Reg.RootKey:=HKEY_CLASSES_ROOT;
    Reg.OpenKey(cMyExt, True);
    //写入自定义文件后缀
    Reg.WriteString('', cMyFileType);
    Reg.CloseKey;
    //写入自定义的文件类型
    //格式为：HKEY_CLASSES_ROOT\cMyExt\(Default) = 'cMyFileType'

    //下面为该文件类型创建关联
    Reg.OpenKey(cMyFileType, True);
    Reg.WriteString('', cMyDescription);
    //写入文件类型的描述信息
    Reg.CloseKey;

    // 下面为自定义文件类型选择图标
    // 加入键格式为 HKEY_CLASSES_ROOT\cMyFileType\DefaultIcon
    //  \(Default) = 'Application Dir\Project1.exe,0'
    Reg.OpenKey(cMyFileType + '\DefaultIcon', True);
    Reg.WriteString('', ExeName + ',' + IntToStr(IcoIndex));
    Reg.CloseKey;

    // 下面注册在资源管理器中打开文件的程序
    Reg.OpenKey(cMyFileType + '\Shell\Open', True);
    Reg.WriteString('', '&Open');
    Reg.CloseKey;

    //  格式：HKEY_CLASSES_ROOT\Project1.FileType\Shell\Open\Command
    //  (Default) = '"Application Dir\Project1.exe" "%1"'
    Reg.OpenKey(cMyFileType + '\Shell\Open\Command', True);
    Reg.WriteString('', '"' + ExeName + '" "%1"');
    Reg.CloseKey;

    //最后，让资源管理器实现我们加入的文件类型，只需调用SHChangeNotify即可
    if DoUpdate then SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
  finally
    Reg.Free;
  end;
end;
}
procedure TFrmEdt.About2Click(Sender: TObject);
var
  f:tFrmAbout;
begin
  f:=TFrmAbout.Create(nil);
  f.PName:='pas脚本编辑工具';
  f.PVer :='Ver 1.0.0';
  f.ServiceOnLine :='QQ 512132183';
  f.PUnit :='接口产品使用单位';
  f.Tel :='025-83583282  15951889901';
  f.Email:='[e-mail]';
  f.ShowModal;
  f.Free;

end;

procedure TFrmEdt.New1Click(Sender: TObject);
begin
advmCon.Lines.Clear;
advmCon.Lines.Add('Begin');
advmCon.Lines.Add('');
advmCon.Lines.Add('End.');
advmCon.CurY:=1;
advmCon.CurX:=0;
EdtName :='';
Caption :='脚本编译工具 ';
NdSave:=False;
end;

procedure TFrmEdt.advmConFileDrop(Sender: TObject; FileName: String;
  var DefaultHandler: Boolean);
begin
EdtName :=FileName;
Caption :='脚本编译工具 '+FileName;
end;

procedure TFrmEdt.advmConChange(Sender: TObject);
begin
 NdSave:=true;
end;

procedure TFrmEdt.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if not NdSave then exit; 
if MessageBox(Handle,'是否保存当前文件?','提示',mb_yesno+MB_ICONQUESTION)=idyes then
begin
     N3Click(Sender);
end;
end;

end.