main.~pas

OCX 注册 对某个文件夹下的所有dll。ocx文件进行注册

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, jpeg, Buttons, StdCtrls;

type
  TMainForm = class(TForm)
    Bevel1: TBevel;
    infopainter: TPaintBox;
    imgprogress: TImage;
    imgfinish: TImage;
    help: TLabel;
    Bevel2: TBevel;
    Label4: TLabel;
    exit: TSpeedButton;
    install: TSpeedButton;
    Panel1: TPanel;
    Label1: TLabel;
    Label3: TLabel;
    Image1: TImage;
    working: TTimer;
    Label2: TLabel;
    procedure FormShow(Sender: TObject);
    procedure infopainterPaint(Sender: TObject);
    procedure exitClick(Sender: TObject);
    procedure installClick(Sender: TObject);
    procedure workingTimer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

procedure LogWrite(msg: wideString);
//function  RegisterOleFile(strOleFileName: string; OleAction : Byte): BOOLEAN;

implementation

uses MSXML2_TLB, ShellAPI, Registry;

var
  ComsInfoList: TStringList;
  Start, Last, BlockWidth: integer;
  Installok: Boolean;
  CaptionString: string;

{$R *.dfm}

procedure TMainForm.FormShow(Sender: TObject);
var
  LocalDir, LocalXmlPath: WideString;
  vDoc: DOMDocument30;
  vDocNode: IXMLDOMNode;
  vDocNodeList: IXMLDOMNodeList;
  vDocNodeText: string;
  vDocLoad: Boolean;
  i: Integer;
  runText, runCommand, runFolder, runArgs: string;
begin

  Start := 0;
  Last := 0;
  Blockwidth := 12;
  Installok := false;

  ComsInfoList := TStringList.Create;

  LocalDir := ExtractFileDir(Application.Exename);
  LocalXmlPath := LocalDir + '\配置文档\product.xml';
  CaptionString := 'GS OCX组件注册';
  vDoc := CoDOMDocument30.Create();
  vDoc.async := False;

  try
    vDocLoad := vDoc.load(LocalXmlPath);

    if (not vDocLoad) then
    begin
      ShowMessage('加载配置文件: ' + LocalXmlPath + ' 出错');
    end;

    if vDoc.parseError.errorCode <> 0 then
    begin
      ShowMessage(vDoc.parseError.reason);
    end
    else
    begin
      vDocNode := vDoc.selectSingleNode('data/product/text');
      vDocNodeText := vDocNode.text;
    end;

    if Trim(vDocNodeText) <> '' then
    begin
      CaptionString := vDocNodeText;
    end;
  finally
    MainForm.Caption := CaptionString ;
  end;

  //install.Caption := '开始安装';
  //exit.Caption := '退出';
  Label2.Caption := '请点击“开始”按钮进行组件注册。';
  LocalXmlPath := LocalDir + '\配置组件\runas.xml';
  vDoc.async := False;

  try
    vDocLoad := vDoc.load(LocalXmlPath);

    if (not vDocLoad) then
    begin
      ShowMessage('没有找到文件runas.xml！请点退出按钮退出程序。');
      install.Enabled := false;
    end;

    if vDoc.parseError.errorCode <> 0 then
    begin
      ShowMessage(vDoc.parseError.reason);
    end
    else
    begin
      vDocNodeList := vDoc.selectNodes('coms/com');
      if vDocNodeList.length < 1 then
      begin
         ShowMessage('没有找到文件runas.xml！请点退出按钮退出程序。');
         install.Enabled := false;
      end;

      runText := ''; runCommand := ''; runFolder := ''; runArgs := '';
      for i := 0 to vDocNodeList.length - 1 do
      begin
        //coms/com/text 组件描述
        runText := vDocNodeList.item[i].selectSingleNode('text').text;
        ComsInfoList.Add(runText);

        //coms/com/text 组件描述
        runCommand := vDocNodeList.item[i].selectSingleNode('cmd').text;
        ComsInfoList.Add(runCommand);

        //coms/com/name \组件安装 中对应的组件名称
        runFolder := vDocNodeList.item[i].selectSingleNode('folder').text;
        ComsInfoList.Add(runFolder);

        //coms/com/args \组件安装 中对应的组件安装时的参数
        runArgs := vDocNodeList.item[i].selectSingleNode('args').text;
        ComsInfoList.Add(runArgs);

        //组件安装状态
        ComsInfoList.Add('I');
      end;
    end;
  finally

  end;
end;

procedure TMainForm.infopainterPaint(Sender: TObject);
var
  i: integer;
  canvas: TCanvas;
  rect, rect2: TRect;
  status: AnsiString;
begin
  canvas := infopainter.Canvas;
  rect.Left := 0;
  rect.Top := 0;
  rect.Right := infopainter.Width;
  rect.Bottom := infopainter.Height;

  canvas.DrawFocusRect(rect);

	for i := Start to Last-1 do
  begin
    rect2.Left := 20+16*(i-0);
    rect2.Top := infopainter.Height - 30;
    rect2.Right := rect2.Left + Blockwidth;
    rect2.Bottom := infopainter.Height - 30 + Blockwidth;

    canvas.Brush.Color := clGreen;
    canvas.FillRect(rect2);
  end;

  i := 0;
  while i < ComsInfoList.Count do
  begin
    canvas.TextOut(20, 8+4*i, ComsInfoList.Strings[i]);
    //i+3如果为：
    //	I：初始状态，不需要重画（init）
    //  P：安装中（progress）
    //  S：安装成功（success）
    //	F：安装失败（failure）

    status := UpperCase(ComsInfoList.Strings[i+4]);
    if(status = 'I') then
    begin
      i := i + 5;
      continue;
    end;
    if(status = 'P') then
    begin
      canvas.TextOut(20, 8+4*i, ComsInfoList.Strings[i] + ' ( 请稍候... ) ');
      canvas.Draw(3, 8+4*i, imgprogress.Picture.Graphic);
    end;
    if(status = 'S') then
    begin
      canvas.Draw(4, 8+4*i, imgfinish.Picture.Graphic);
    end;
    if(status = 'F') then
    begin
      i := i + 5;
      continue;  
    end;

    i := i + 5;
  end;
end;

procedure TMainForm.exitClick(Sender: TObject);
begin
  Close();
end;

procedure TMainForm.installClick(Sender: TObject);
var
  i: integer;
  msg: AnsiString;
  runText, runCommand, runFolder, runArgs, runName: AnsiString;
  fpath:   String;
  fs:   TsearchRec;
  LocalDir : WideString;
  runMsg : string;
  ret : Cardinal;
const
  Flag = ' ';
begin
  //Flag := ' ';
  LocalDir := GetCurrentDir() + '\配置组件';
  install.Enabled := false;
  exit.Enabled := false;
  i := 0;

  while i < ComsInfoList.Count do
  begin

    runText := ComsInfoList.Strings[i+0];
    runCommand := ComsInfoList.Strings[i+1];
    runFolder := ComsInfoList.Strings[i+2];
    runArgs := ComsInfoList.Strings[i+3];

    fpath:=LocalDir + runFolder+'\*.*';

    ComsInfoList.Strings[i+4] := 'P';
    Infopainter.Invalidate();
    Application.ProcessMessages();

    if FindFirst(fpath, faAnyFile, fs) = 0 then
    begin
      repeat

      if ((fs.Attr and faDirectory) = 0) then
      begin
        runName := strupper(pchar(fs.Name));

        runMsg := runCommand + Flag + LocalDir + runFolder + runName + Flag + runArgs + Flag;
        try
          ret := winexec(PChar(runMsg), SW_NORMAL);
          if ret > 31 then
            msg := ' 成功 '
          else
            msg := ' 失败 ';

        except
        on E: Exception do
          LogWrite(runMsg+Flag+' 失败！ ' + E.Message );
        end;

        LogWrite(runMsg+Flag+ msg );
      end;
      
      until FindNext(fs)<>0;
    end;
    Findclose(fs);

    ComsInfoList.Strings[i+4] := 'S';
    infopainter.Invalidate();
    Application.ProcessMessages();

    i := i + 5;
  end;

  exit.Enabled := true;
  installok := true;
	//exit.Caption := '继续';
  install.Visible := false;
end;

procedure TMainForm.workingTimer(Sender: TObject);
begin
  Last := Last + 1;
  if(Last >= infopainter.Width/16) then
  begin
    Start := Start + 1;
    Last := Last - 1;
    if(Start = Last) then
    begin
      Start := 0;
      Last := 0;
    end;
  end;
end;

procedure  LogWrite(msg:widestring);
  var
      TextFile:Text;
      filename:string;
  begin
      filename := 'c:\ocx.ini';
      try
          Assignfile(textfile, filename);
          try
              Append(textFile);
          except
              Rewrite(textFile);
          end;
          writeln(textFile, DateTimeToStr(Now)+ ' : ' + msg);
          CloseFile(textfile);
      except
          Exit;
      end;
  end;
end.

end;