uExcel文件

uExcel文件如下:


//             Excel控制类，封装大多数对Excel的操作
//
//             CopyRight(C) Lodgue Written by Lodgue
//                         20/12/2001


unit uExcel;

interface

uses
  Registry,OleServer,Excel97,Dialogs,ComObj,Sysutils,windows,Graphics,
  uShareFunc,Math,clipbrd,classes;

resourcestring
  rcCreateExcelFailed='不能启动Excel程序,请确认是否安装了Excel';
  rcExcelProgIDPath='Excel.Application/CurVer';
  rcCloseExcelFailed='不能关闭，您可能正在编辑文件或者Excel服务程序已经关闭';
  rcNoFoundSheetName='%s表页不存在';
const
  MARKED=';'; //有效数据区的分割符
type
  TDataAreas=array of string;
  TXLColor=integer;
  TLine=record
    LStyle:cardinal;
    Weight:cardinal;
    Color:TColor;
  end;
  TExcel=class(TObject)
  private
    fExcel:variant;
    fVisible:boolean;
    fExcelFile:string;
    fActiveSheet:string;
    //fUsedRangeRect:TRect;//表示UsedRange的范围用整形表示
    procedure DeleteResume();
    procedure ClearClipBoard();
    function  fD5ColorToXlColor(Color:TColor):TXLColor;   // the color value of Delphi 5 convert to Excel Color
    procedure fDrawRectangle(var Range:variant;Line:TLine); //only draw the edge of the selected range
    procedure fDrawRectInside(var Range:variant;Line:TLine);//draw All the lines
    procedure fDrawLeft(var Range:variant;line:TLine);
    procedure fDrawTop(var Range:variant;Line:TLine);
    procedure fDrawBottom(var Range:variant;Line:TLine);
    procedure fDrawTopBottom(var Range:variant;Line:TLine);
    procedure fDrawRight(var Range:variant;Line:TLine);
    procedure fDrawRightLeft(var Range:variant;Line:TLine);
    procedure fDrawLine(var Range:variant;LineDirectory:integer;Line:TLine);
    procedure fSetFontColor(var Range:variant;Color:TColor);
    procedure fSetFontName(var Range:variant;FontName:string);
    procedure fSetFontStyle(var Range:variant;FontStyles:TFontStyles);//fsStrikeOut is invalid.
    procedure fSetFontSize(var Range:variant;Size:integer);
    //procedure fSetActiveSheet();
  protected
    procedure SetVisible(Value:boolean);
    procedure SetActiveSheet(Value:string);
    function GetActiveSheet():string;
  public
    constructor Create();virtual;
    destructor Destroy();override;

    //启动Excel
    function CreateExcel():boolean;

    //在表的末尾添加一个表页（SheetName）
    procedure AddNewSheetToLast(SheetName:string);
    procedure AddNewSheetToFirst(SheetName:string);

    //关闭Excel
    procedure QuitExcel();

    //打开Excel文件.如果FileName='',打开fExcelFile,否则打开FileName.
    function OpenExcelFile(FileName:string='';IsRefresh:boolean=False):boolean;

   //激活一个名为WinName的子窗口
    procedure ActiveWindow(WinName:string);

    //清除指定页使用过的区域。SavedFormat=False清除数据和格式
    //SavedFormat=True经清除数据,SheetName='',使用ActiveSheet作为表单
    procedure ClearUserRange(SheetName:string='';SavedFormat:boolean=False);

    //清除指定表单（SheetName）、区域的数据SheetName='',使用ActiveSheet作为表单
    procedure ClearDataArea(DataAreas:string;SheetName:string='');

    //将指定的页内的所有内容复制到另一页中(在同一个WorkBook中)
    procedure CopyUserRangeToAnotherSheet(AnotherSName:string;SpecifySheetName:string='');overload;

    //将指定的页内的所有内容复制到另一页中(在不同WorkBook中)
    procedure CopyUserRangeToAnotherSheet(AnotherSheetName,AnotherBook:string;SpecifySheetName:string;SpecifyBook:string='');overload;

    //将指定的页内的指定区域内的数据复制到另一页中(在同一个WorkBook中)
    //SpecifySheetName=''是指复制当前页
    procedure CopyDataAreaToAnotherSheet(AnotherSName,FromDataArea:string;SpecifySheetName:string='');overload;

    //将指定的页内的指定区域内的数据复制到另一页中(在不同WorkBook中)
    procedure CopyDataAreaToAnotherSheet(AnotherSName,AnotherBook,FromDataArea,SpecifySheetName:string;SpecifyBook:string='');overload;

    //复制一个连续的区域到剪辑板中,如果SheetName=''使用ActiveSheet;
    procedure CopyDataAreaToClipBoard(DataArea:string;SheetName:string='');

    //复制UsedRange区域到剪辑板中,如果SheetName=''使用ActiveSheet;
    procedure CopyUsedRangeToClipBoard(SheetName:string='');

    //建立一个Excel文件
    procedure CreateNewBook(ExcelFileName:string;SheetCount:integer=1);

    //将WinName存为ExcelFileName;如果WinName=''保存ActiveWorkBook
    //如果ExcelFileName='';则覆盖打开的文件的内容
    procedure SaveBook(ExcelFileName:string='';WinName:string='');

    //将WinName的WorkBook关闭;如果WinName=''关闭ActiveWorkBook
    procedure CloseBook(WinName:string='');overload;
    procedure CloseBook(Index:integer);overload;

    procedure CloseActiveBook();
    //检查是否存在指定名字的表页
    function  IsSheetNameExist(SheetName:string):boolean;

    //关闭所有WorkBook
    procedure CloseBooks();

    //修改表单名称
    procedure RenSheetName(OldName,NewName:string);overload;
    procedure RenSheetName(Index:integer;NewName:string);overload;

    //给单元格赋值
    procedure SetCellValue(CellName:string;CellValue: variant);

   //获取单元格的值
    function  GetCellValue(CellName:string):Variant;

    //刷新Excel界面
    procedure Refresh();

    //only draw the edge of the selected range
    procedure DrawRectangle(RangeStr:string;Line:TLine);

    //draw All the lines
    procedure DrawRectInside(RangeStr:string;Line:TLine);
    procedure DrawLeft(RangeStr:string;line:TLine);
    procedure DrawTop(RangeStr:string;Line:TLine);
    procedure DrawBottom(RangeStr:string;Line:TLine);
    procedure DrawTopBottom(RangeStr:string;Line:TLine);
    procedure DrawRight(RangeStr:string;Line:TLine);
    procedure DrawRightLeft(RangeStr:string;Line:TLine);

    //设置显示字体
    procedure SetFont(RangeStr:string;Font:TFont);

    //设置字体排列位置
    procedure SetFontPos(RangeStr:string;hAlign:Cardinal=xlLeft;vAlign:Cardinal=xlCenter);

    //设置列宽
    procedure SetWidth(ColName:string;Width:integer=10);overload;
    procedure SetWidth(ColNum:integer;Width:integer=10);overload;

    //设置行高
    procedure SetHeight(RowNum:integer;Height:integer=15);overload;
    procedure SetHeight(RowNum:string;Height:integer=15);overload;

    //合并指定连续单元格区域
    procedure MergeRange(RangeStr:string;hAlign:cardinal=xlCenter;vAlign:Cardinal=xlCenter);

    //获取使用过的区域RangeStr格式
    function  GetUserRangeStr():string;

    //获取使用过的区域RangeRect格式
    //Rect.Left=开始列,Rect.Right=最后列
    //Rect.Top=开始行,Rect.Bottom=最后行
    function  GetUserRangeRect():TRect;
    procedure SelectSheet(SheetName:string);overload;
    procedure SelectSheet(SheetIndex:integer);overload;
    function  GetSheetIndex(Name:string):integer;
    function  GetSheetName(Index:integer):string;
    procedure GetSheets(var SheetList:TStrings);
  published
    property Visible:boolean read fVisible write SetVisible default False;
    property ExcelFile:string read fExcelFile write fExcelFile;
    property ActiveSheet:string read GetActiveSheet write SetActiveSheet;

  end;

//将DataAreaStr分析为几个有效数据区，然号从DataAreas中返回
procedure AnalyzeDataAreas(var DataAreas:TDataAreas;DataAreaStr:string);

//获取启动Excel的ProgID号
function GetExcelProgID():string;

//列号转化成整形（无限制）
function Col2Num(ColName:string):integer;
//整形转化成列号（1..256）
function Num2Col(ColNum:integer):string;

//=============================================================================
//DataArea是指一个有效数据区域,PrevHalf=True取前段分析,否则取后段分析
//获取列名，prevHalf指是从前半部还是后半部（半部）
function   GetColName(DataArea:string;PrevHalf:boolean):string;
//获取行号，prevHalf指是从前半部还是后半部（半部）
function   GetRowNum(DataArea:string;PrevHalf:boolean):integer;
//获取行号、列名，prevHalf指是从前半部还是后半部（半部）
procedure  GetColRow(DataArea:string;PrevHalf:boolean;var Col:string;var Row:integer);overload;
//获取行号、列名（一个连续的区间内）
procedure  GetColRow(DataArea:string;var sCol,eCol:string;var sRow,eRow:integer);overload;
function   GetColRow(DataArea:string):TRect;overload;
//==============================================================================
//获取一个连续的有效数据的半部分。 prevHalf指是从前半部还是后半部
function  GetHalfDataArea(DataArea:string;PrevHalf:boolean):string;
//从半部区间中获取列名
function  GetColNameByHalfDataArea(HalfDataArea:string):string;
//从半部区间中获取行号
function  GetRowNumByHalfDataArea(HalfDataArea:string):integer;

//由行列号合成一个CellName
function ComposeCellName(Col:string;Row:integer):string;overload;
function ComposeCellName(Col:integer;Row:string):string;overload;
function ComposeCellName(Col:string;Row:string):string;overload;
function ComposeCellName(Col:integer;Row:integer):string;overload;

//==============================================================================
//一个有效数据区内的行数
function  GetRows(DataArea:string):integer;
//所有有效数据区内的行数
function  GetRowsByDataAeas(DataAreas:string):integer;
//一个有效数据区内的
function  GetCols(DataArea:string):integer;
//所有有效数据区内的列数
function  GetColsByDataAreas(DataAreas:string):integer;

//分析一个有效的数据区是否合法
function  IsRequiedDataArea(DataArea:string):boolean;

//分析整个有效的数据区是否合法
function  IsRequiedDataAreas(DataAreas:TDataAreas):boolean;

implementation

procedure AnalyzeDataAreas(var DataAreas:TDataAreas;DataAreaStr:string);
var
  MarkedPos,i,MarkCount:integer;
  CurStr:string;
begin
  MarkCount:=0;
  MarkedPos:=Pos(MARKED,DataAreaStr);
  if MarkedPos=0 then begin
    SetLength(DataAreas,1);
    DataAreas[0]:=DataAreaStr;
  end else begin
    MarkedPos:=0;
    for i:=1 to Length(DataAreaStr) do begin
      CurStr:=Copy(DataAreaStr,i,1);
      if CurStr=MARKED then begin
        Inc(MarkCount);
        SetLength(DataAreas,MarkCount);
        DataAreas[MarkCount-1]:=Copy(DataAreaStr,MarkedPos+1,i-MarkedPos-1);
        MarkedPos:=i;
      end;
    end;
    Inc(MarkCount);
    SetLength(DataAreas,MarkCount);
    DataAreas[MarkCount-1]:=Copy(DataAreaStr,MarkedPos+1,Length(DataAreaStr));
  end;
end;

//2000 execel.application.9
//97 excel.application.8
//其他版本不知是否可以这样访问
function GetExcelProgID():string;
var
  Reg:TRegistry;
begin
  Result:='';
  Reg:=TRegistry.Create();
  try
    Reg.RootKey:=HKEY_CLASSES_ROOT;
    if Reg.OpenKey(rcExcelProgIDPath,False) then begin
      Result:=Reg.ReadString('');
    end;
  finally
    Reg.Free;
  end;
end;

function  GetHalfDataArea(DataArea:string;PrevHalf:boolean):string;
var
  ColonPos:integer;
begin
  ColonPos:=Pos(':',DataArea);
  if PrevHalf then Result:=Copy(DataArea,1,ColonPos-1)
  else  Result:=Copy(DataArea,ColonPos+1,Length(DataArea)) ;
end;

function  GetColNameByHalfDataArea(HalfDataArea:string):string;
var
  i:integer;
begin
  Result:='';
  HalfDataArea:=AnsiUpperCase(HalfDataArea);
  for i:=1 to Length(HalfDataArea) do begin
    if HalfDataArea[i] in ['A'..'Z'] then
      Result:=Result+HalfDataArea[i]
    else Break;
  end;
end;
function  GetRowNumByHalfDataArea(HalfDataArea:string):integer;
var
  i:integer;
  NumStr:string;
begin
  Result:=0;
  for i:=1 to Length(HalfDataArea) do begin
    if HalfDataArea[i] in ['0'..'9'] then begin
      NumStr:=Copy(HalfDataArea,i,Length(HalfDataArea));
      Result:=StrToInt(NumStr);
      Break;
    end;
  end;
end;

function ComposeCellName(Col:string;Row:integer):string;overload;
begin
  Result:=Col+IntToStr(Row);
end;

function ComposeCellName(Col:integer;Row:string):string;overload;
begin
  Result:=Num2Col(Col)+Row;
end;

function ComposeCellName(Col:string;Row:string):string;overload;
begin
  Result:=Col+Row;
end;

function ComposeCellName(Col:integer;Row:integer):string;overload;
begin
  Result:=Num2Col(Col)+IntToStr(Row);
end;

function  GetRows(DataArea:string):integer;
var
  sRow,eRow:integer;
  sCol,eCol:string;
begin
   GetColRow(DataArea,sCol,eCol,sRow,eRow);
   Result:=eRow-sRow+1;
end;

function  GetRowsByDataAeas(DataAreas:string):integer;
var
  TempDataAreas:TDataAreas;
  i:integer;
begin
  Result:=0;
  AnalyzeDataAreas(TempDataAreas,DataAreas); //以';'分离出有效数据区.
  for i:=0 to Length(TempDataAreas)-1 do begin
    Result:=Result+GetRows(TempDataAreas[i]);
  end;
end;
function  GetCols(DataArea:string):integer;//一个有效数据区内的
var
  sRow,eRow:integer;
  sCol,eCol:string;
begin
   GetColRow(DataArea,sCol,eCol,sRow,eRow);
   Result:=Col2Num(eCol)-Col2Num(sCol)+1;
end;

function  GetColsByDataAreas(DataAreas:string):integer; //所有有效数据区内的列数
var
  TempDataAreas:TDataAreas;
  i:integer;
begin
  Result:=0;
  AnalyzeDataAreas(TempDataAreas,DataAreas); //以';'分离出有效数据区.
  for i:=0 to Length(TempDataAreas)-1 do begin
    Result:=Result+GetCols(TempDataAreas[i]);
  end;
end;

function  GetColName(DataArea:string;PrevHalf:boolean):string;
var
  HalfDataArea:string;
begin
  HalfDataArea:=GetHalfDataArea(DataArea,PrevHalf);
  Result:=GetColNameByHalfDataArea(HalfDataArea);
end;

function GetRowNum(DataArea:string;PrevHalf:boolean):integer;
var
  HalfDataArea:string;
begin
  HalfDataArea:=GetHalfDataArea(DataArea,PrevHalf);
  Result:=GetRowNumByHalfDataArea(HalfDataArea);
end;
procedure  GetColRow(DataArea:string;PrevHalf:boolean;var Col:string;var Row:integer);
var
  HalfDataArea:string;
begin
  HalfDataArea:=GetHalfDataArea(DataArea,PrevHalf);
  Row:=GetRowNumByHalfDataArea(HalfDataArea);
  Col:=GetColNameByHalfDataArea(HalfDataArea);
end;

procedure  GetColRow(DataArea:string;var sCol,eCol:string;var sRow,eRow:integer);overload;
var
  HalfDataArea:string;
begin
  HalfDataArea:=GetHalfDataArea(DataArea,True);
  sRow:=GetRowNumByHalfDataArea(HalfDataArea);
  sCol:=GetColNameByHalfDataArea(HalfDataArea);

  HalfDataArea:=GetHalfDataArea(DataArea,False);
  eRow:=GetRowNumByHalfDataArea(HalfDataArea);
  eCol:=GetColNameByHalfDataArea(HalfDataArea);
end;
function   GetColRow(DataArea:string):TRect;overload;
var
  eCol,sCol:string;
  eRow,sRow,eColNum,sColNum:integer;
begin
  GetColRow(DataArea,sCol,eCol,sRow,eRow);
  eColNum:=Col2Num(eCol);
  sColNum:=Col2Num(sCol);
  Result.Left:=sColNum;
  Result.Right:=eColNum;
  Result.Top:=sRow;
  Result.Bottom:=eRow;
end;
function  IsRequiedDataArea(DataArea:string):boolean;
var
  MarkPos:integer;
  PreHalf,LastHalf:string;
  function IsLegalRow(PreHalf,LastHalf:string):boolean;
  var
    PreRow,LastRow:integer;
  begin
    PreRow:=GetRowNumByHalfDataArea(PreHalf);
    LastRow:=GetRowNumByHalfDataArea(LastHalf);
    Result:=(PreRow<=LastRow);
  end;
  function IsLegalCol(PreHalf,LastHalf:string):boolean;
  var
   PreCol,LastCol:integer;
  begin
    PreCol:=Col2Num(PreHalf);
    LastCol:=Col2Num(LastHalf);
    Result:=(PreCol<=LastCol);
  end;
  function IsIncludeColon(AllStr:string;var MarkPos:integer):boolean;
  begin
    MarkPos:=Pos(':',DataArea);
    Result:=(MarkPos<>0);
  end;
  function CheckHalf(HalfStr:string):boolean;
  var
    StartNum:boolean;
    i:integer;
    fStr:string;
  begin
    StartNum:=False;
    if HalfStr='' then begin
      Result:=False;//如果为空为假
      Exit;
    end;
    fStr:=AnsiUpperCase(HalfStr[1]);
    //如果第一个字符大于“I“，即K,j等,并且第二个不为数字那么数据则为非法的数据区
    if (Ord(fStr[1])>Ord('I')) then begin
      if (HalfStr[2] in ['0'..'9']) then Result:=True
      else Result:=False;
    end else Result:=True;
   // Result:= (Ord(fStr[1])<=Ord('I')) and (HalfStr[2] in ['0'..'9']);
    if not Result then Exit;
    if fStr='I' then begin//如果第一个字符等为“I”并且第二各字符大于'V'，那么数据则为非法的数据区
      fStr:=AnsiUpperCase(HalfStr[2]);
      Result:=Ord(fStr[1])<=Ord('V');
      if not Result then Exit;
    end;
    for i:=1 to Length(HalfStr) do begin
      if i=3 then begin
        if  not (HalfStr[i] in ['0'..'9']) then begin
          Result:=False;
          Break;
        end;
      end;
      if i=1 then begin//如果首个是数字为假
        Result:= not(HalfStr[i] in ['0'..'9']);
        if (not Result) then Break;
      end;
      if HalfStr[i] in ['A'..'Z','a'..'z','0'..'9'] then begin
        //如果还没有开始数字字符，则判断是否开始了数字．如果开始
        //如果开始了数字则不判断了．
        if not StartNum then StartNum:=(HalfStr[i] in ['0'..'9']);
        if StartNum then begin
          Result:= not(HalfStr[i] in ['A'..'Z','a'..'z']);
          if not Result then Break;
        end;
      end else begin//如果出现了不是上述字符的为假
        Result:=False;
        Break;
      end;
    end;
    if not StartNum then Result:=False;
  end;
begin
  Result:=IsIncludeColon(DataArea,MarkPos);
  if Result then begin  //如果存在':'进一步分析
    PreHalf:=Copy(DataArea,1,MarkPos-1);
    LastHalf:=Copy(DataArea,MarkPos+1,Length(DataArea));
    //分析一半是否合法
    Result:=CheckHalf(PreHalf);
    if Result then begin
      Result:=CheckHalf(LastHalf);
    end;
    //分析一半是否合法整体是否合法
    if Result then begin
      Result:=IsLegalRow(PreHalf,LastHalf); //判断启始行是否大于结尾行，如果是则为非法
      if Result then Result:=IsLegalCol(PreHalf,LastHalf);//判断启始列是否大于结尾列，如果是则为非法
    end;
  end;
end;

function  IsRequiedDataAreas(DataAreas:TDataAreas):boolean;
var
  i,AreaCount:integer;
  DataArea:string;
begin
  Result:=False ;
  AreaCount:= Length(DataAreas);
  for i:=0 to AreaCount-1 do begin
    DataArea:=DataAreas[i];
    Result:=IsRequiedDataArea(DataArea);
    if  not Result then Break;
  end;
end;

function Col2Num(ColName:string):integer;
var
  Len,i:Integer;
  BaseData:integer;
begin
  Result:=0;
  BaseData:=Ord('A')-1;
  ColName:=UpperCase(ColName);
  Len:=Length(ColName);
  for i:=1 to Len do begin
    Result:=Result+(Ord(ColName[i])-BaseData)*Trunc(Power(26,(Len-i)));
  end;
end;
{function  Num2Col(ColNum:integer):string;
var
  DivData:integer;
  ModData:integer;
  BaseChar:integer;
begin
  Result:='';
  BaseChar:=Ord('@')-1;
  while True do begin
    DivData:=ColNum div 26;
    ModData:=ColNum mod 26;
    ColNum:=DivData;
    Result:= Chr(BaseChar+ModData)+Result;
    if ColNum=0 then begin
     // if Result[Length(Result)]='@' then Result[Length(Result)]:='Z';
      Break;
    end;
  end;
end;}
{function  Num2Col(ColNum:integer):string;
var
  DivData,ModData,BaseChar:integer;
  Len:integer;
begin
  Result:='';
  BaseChar:=Ord('A')-1;
  while True do begin
    DivData:=ColNum div 26;
    ModData:=ColNum mod 26;
    ColNum:=DivData;
    Result:= Chr(BaseChar+ModData)+Result;
    //Result:=intTostr(ModData)+Result;
    if ColNum=0 then begin

      Len:=Length(Result);
      if Result[Len]='@' then begin
        Result[Len]:='Z';
        if Len=2 then begin
          if Result[1]='A' then begin
            Result[1]:=Result[2];
            SetLength(Result,1);
          end else begin
            Result[Len-1]:= Chr(Ord(Result[Len-1])-1);
          end;
        end else begin
          Result[Len-1]:= Chr(Ord(Result[Len-1])-1);
        end;
      end;
      Break;
    end;
  end;
end;}
function  Num2Col(ColNum:integer):string;
begin
  Result:='';
  if (ColNum<1)  or (ColNum>256) then raise Exception.Create('列编号在1..256之间('+IntToStr(ColNum)+')');
  if ColNum<=26 then Result:= Chr(ColNum+Ord('A')-1)
  else begin
    if (ColNum mod 26)=0 then begin
      Result:= Chr((ColNum div 26)+Ord('A')-2);
      Result:=Result+ Chr(25+Ord('A'))
    end else begin
      Result:= Chr((ColNum div 26)+Ord('A')-1);
      Result:=Result+ Chr((ColNum mod 26)+Ord('A')-1);
    end;
  end;
end;

{ TExcel }

procedure TExcel.ActiveWindow(WinName: string);
begin
  fExcel.Windows[WinName].Activate;
 // fSetActiveSheet;
end;

procedure TExcel.AddNewSheetToFirst(SheetName: string);
var
  LastName:string;
begin
  LastName:=SheetName;
  AddNewSheetToLast(LastName);
  fExcel.Sheets.Item[LastName].Move(fExcel.Sheets.Item[1]);
  //fSetActiveSheet;
end;

function  TExcel.IsSheetNameExist(SheetName:string):boolean;
var
  i:integer;
  ExistName:string;
begin
  Result:=False;
  for i:=1 to fExcel.Sheets.Count do begin
    ExistName:=fExcel.Sheets.item[i].Name;
    Result:=SameText(ExistName,SheetName);
    if Result then Break;
  end;
end;



procedure TExcel.AddNewSheetToLast(SheetName: string);
var
  NewSheet:variant;
  Count:integer;
begin
  Count:=fExcel.Sheets.Count;
  fExcel.Sheets.Item[Count].Select;
  NewSheet:=fExcel.Sheets.Add;
  NewSheet.Name:=SheetName;
  fExcel.Sheets.Item[fExcel.Sheets.Count].Move(NewSheet);
  //fSetActiveSheet;
end;

procedure TExcel.ClearClipBoard;
var
  cb:TClipboard;
begin
  cb:=TClipBoard.Create;
  cb.Clear;
  cb.Free;
end;

procedure TExcel.ClearDataArea(DataAreas:string; SheetName:string='');
var
  DataArea:string;
  TempDataAreas:TDataAreas;
  i:integer;
begin
  AnalyzeDataAreas(TempDataAreas,DataAreas);
  for i:=0 to Length(TempDataAreas)-1 do begin
    DataArea:=TempDataAreas[i];
    if SheetName<>'' then begin
      fExcel.Sheets.Item[SheetName].Select;
    end;
    fExcel.ActiveSheet.Range[DataArea].Select;
    fExcel.Selection.ClearContents;
  end;
  //fSetActiveSheet;
end;


procedure TExcel.ClearUserRange(SheetName: string=''; SavedFormat: boolean=False);
begin
  if SheetName<>'' then begin
    fExcel.Sheets.Item[SheetName].Select;
  end;
  fExcel.ActiveSheet.UsedRange.Select;
  if SavedFormat then
    fExcel.Selection.ClearContents
  else
    fExcel.ActiveSheet.UsedRange.Delete(xlToLeft);
  //fSetActiveSheet;
end;


procedure TExcel.CloseBook(WinName: string='');
begin
  if WinName<>'' then begin
    ActiveWindow(WinName);
  end;
  CloseActiveBook();
end;
procedure TExcel.CloseBook(Index:integer);
begin
  fExcel.WorkBooks[Index].Activate;
  CloseActiveBook();
end;
procedure TExcel.CloseBooks;
var
  BookCount,i:integer;
begin
  BookCount:=0;
  try
    BookCount:=fExcel.WorkBooks.Count;
    if BookCount=0 then Exit;
  except
    RaiseError(rcCloseExcelFailed);
  end;
  ClearClipBoard();
  for i:=1 to BookCount do begin
    fExcel.WorkBooks[i].Saved:=True;
  end;
  fExcel.WorkBooks.Close;
end;

procedure TExcel.CloseActiveBook;
begin
  fExcel.ActiveWorkBook.Saved:=True;
  ClearClipBoard();
  fExcel.ActiveWorkBook.Close;
end;
procedure TExcel.CopyDataAreaToAnotherSheet(AnotherSName,FromDataArea:string;SpecifySheetName:string='');
var
  ToDataArea:string;
  DataAreas:TDataAreas;
  i:integer;
begin
  AnalyzeDataAreas(DataAreas,FromDataArea);
  for i:=0 to Length(DataAreas)-1 do begin
    FromDataArea:=DataAreas[i];
    if SpecifySheetName<>'' then begin
       fExcel.Sheets.Item[SpecifySheetName].Select;
    end;
    fExcel.ActiveSheet.Range[FromDataArea].Select;
    fExcel.Selection.Copy;
    fExcel.ActiveSheet.Range['A1'].Select;

    ToDataArea:=GetHalfDataArea(FromDataArea,True);

    fExcel.Sheets.Item[AnotherSName].Select;
    fExcel.ActiveSheet.Range[ToDataArea].Select;
    fExcel.ActiveSheet.Paste;
    fExcel.ActiveSheet.Range['A1'].Select;
  end;
end;

procedure TExcel.CopyUserRangeToAnotherSheet(AnotherSName, SpecifySheetName: string);
begin
  if SpecifySheetName<>'' then begin
    fExcel.Sheets.Item[SpecifySheetName].Select;
  end;
  fExcel.ActiveSheet.Cells.Select;
  fExcel.ActiveSheet.Cells.Copy;
  fExcel.ActiveSheet.Range['A1'].Select;

  fExcel.Sheets.Item[AnotherSName].Select;
  ClearUserRange();
  fExcel.ActiveSheet.Cells.Select;
  fExcel.ActiveSheet.Paste;
  fExcel.ActiveSheet.Range['A1'].Select;
end;

constructor TExcel.Create;
begin
  fVisible:=False;
end;

function TExcel.CreateExcel():boolean;
begin
  if not VarIsEmpty(fExcel) then begin
    fExcel.Visible:=fVisible;
    Result:=True;
    Exit;
  end;
  try
    fExcel:=CreateOleObject(GetExcelProgID());
  except
    RaiseError(rcCreateExcelFailed);
  end;
  Result:=not VarIsEmpty(fExcel);
  if Result then fExcel.Visible:=fVisible;
end;

procedure TExcel.CreateNewBook(ExcelFileName:string;SheetCount:integer=1);
var
  OldBooksCount:integer;
begin
  OldBooksCount:=fExcel.SheetsInNewWorkbook;
  fExcel.SheetsInNewWorkbook:=SheetCount;
  fExcel.WorkBooks.Add;
  fExcel.SheetsInNewWorkbook:=OldBooksCount;
  SaveBook(ExcelFileName);
end;


procedure TExcel.DeleteResume;
var
  ResumeFile,ExcelPath:string;
begin
  ExcelPath:=fExcel.DefaultFilePath;
  if ExcelPath[Length(ExcelPath)]<>'/' then
    ExcelPath:=ExcelPath+'/';
  ResumeFile:=ExcelPath+'resume.xlw';
  if FileExists(ResumeFile) then begin
    DeleteFile(Pchar(ResumeFile));
  end;
end;

destructor TExcel.Destroy;
begin
  inherited;
  QuitExcel();
end;

function TExcel.OpenExcelFile(FileName: string='';IsRefresh:boolean=False): boolean;
begin
  if FileName<>'' then fExcelFile:=FileName;
  Result:= FileExists(fExcelFile);
  if Result then begin//如果文件存在
    try
      fExcel.WorkBooks.Open(fExcelFile);
    except
      Result:=False;
    end;
  end;
  if Result then begin
    if IsRefresh then begin
      Refresh();
    end;
  end;
end;

procedure TExcel.QuitExcel;
begin
  if not VarIsEmpty(fExcel) then begin
    CloseBooks();
    fExcel.Quit;
  end;
end;

procedure TExcel.SaveBook(ExcelFileName:string='';WinName:string='');
begin
  if WinName<>'' then begin
    ActiveWindow(WinName);
  end;
  DeleteResume();
  if ExcelFileName='' then begin
    fExcel.Save;
  end else begin
    fExcel.ActiveWorkbook.SaveAs(ExcelFileName,xlNormal,'','',False,False);
  end;
end;

procedure TExcel.SetVisible(Value: boolean);
begin
  fVisible:=Value;
  fExcel.Visible:=fVisible;
end;

procedure TExcel.RenSheetName(OldName, NewName: string);
begin
  fExcel.Sheets.item[OldName].Name:=NewName;
end;

procedure TExcel.RenSheetName(Index: integer; NewName: string);
begin
  fExcel.Sheets.item[Index].Name:=NewName;
end;

function TExcel.fD5ColorToXlColor(Color: TColor): TXLColor;
begin
  case  Color of
    clBlack:Result:=1;
    clMaroon:Result:=53;
    clGreen:Result:=10;
    clOlive:Result:=46;
    clNavy:Result:=11;
    clPurple:Result:=13;
    clTeal:Result:=14;
    clGray:Result:=16;
    clRed:Result:=3;
    clLime:Result:=4;
    clYellow:Result:=6;
    clBlue:Result:=5;
    clFuchsia:Result:=7;
    clAqua:Result:=8;
    clWhite:Result:=2;
    clBackground:Result:=14;
    clInfoBk:Result:=44;
  else
    Result:=1;
  end;
end;

procedure TExcel.fDrawBottom(var Range: variant; Line: TLine);
begin
  fDrawLine(Range,xlEdgeBottom,Line);
end;

procedure TExcel.fDrawLeft(var Range: variant; line: TLine);
begin
  fDrawLine(Range,xlEdgeLeft,Line);
end;

procedure TExcel.fDrawLine(var Range: variant; LineDirectory: integer;
  Line: TLine);
var
  xlColor:TXLColor;
begin
  xlColor:=fD5ColorToXLColor(Line.Color);
  Range.Borders[LineDirectory].LineStyle:=Line.LStyle;
  Range.Borders[LineDirectory].Weight:=Line.Weight;
  Range.Borders[LineDirectory].ColorIndex:=xlColor;
end;

procedure TExcel.fDrawRectangle(var Range: variant; Line: TLine);
begin
  fDrawLine(Range,xlEdgeLeft,Line);
  fDrawLine(Range,xlEdgeTop,Line);
  fDrawLine(Range,xlEdgeBottom,Line);
  fDrawLine(Range,xlEdgeRight,Line);
end;

procedure TExcel.fDrawRectInside(var Range: variant; Line: TLine);
begin
  fDrawRectangle(Range,Line);
  fDrawLine(Range,xlInsideVertical,Line);
  fDrawLine(Range,xlInsideHorizontal,Line);
end;

procedure TExcel.fDrawRight(var Range: variant; Line: TLine);
begin
  fDrawLine(Range,xlEdgeRight,Line);
end;

procedure TExcel.fDrawRightLeft(var Range: variant; Line: TLine);
begin
  fDrawLine(Range,xlEdgeLeft,Line);
  fDrawLine(Range,xlEdgeRight,Line);
end;

procedure TExcel.fDrawTop(var Range: variant; Line: TLine);
begin
  fDrawLine(Range,xlEdgeTop,Line);
end;

procedure TExcel.fDrawTopBottom(var Range: variant; Line: TLine);
begin
  fDrawLine(Range,xlEdgeTop,Line);
  fDrawLine(Range,xlEdgeBottom,Line);
end;

procedure TExcel.DrawBottom(RangeStr: string; Line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawBottom(Range,Line);
end;

procedure TExcel.DrawLeft(RangeStr: string; line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawLeft(Range,Line);
end;

procedure TExcel.DrawRectangle(RangeStr: string; Line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawRectangle(Range,Line);
end;

procedure TExcel.DrawRectInside(RangeStr: string; Line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawRectInside(Range,Line);
end;

procedure TExcel.DrawRight(RangeStr: string; Line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawRight(Range,Line);
end;

procedure TExcel.DrawRightLeft(RangeStr: string; Line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawRightLeft(Range,Line);
end;

procedure TExcel.DrawTop(RangeStr: string; Line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawTop(Range,Line);
end;

procedure TExcel.DrawTopBottom(RangeStr: string; Line: TLine);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fDrawTopBottom(Range,Line);
end;

procedure TExcel.fSetFontColor(var Range: variant; Color: TColor);
var
  xlColor:TXlColor;
begin
  xlColor:=fD5ColorToXlColor(Color);
  Range.Font.ColorIndex:=xlColor;
end;

procedure TExcel.fSetFontName(var Range: variant; FontName: string);
begin
  Range.Font.Name:=FontName;
end;

procedure TExcel.fSetFontSize(var Range: variant; Size: integer);
begin
  Range.Font.Size:=Size;
end;

procedure TExcel.fSetFontStyle(var Range: variant;
  FontStyles: TFontStyles);
begin
  Range.Font.Bold:=(fsBold in FontStyles);
  Range.Font.Italic:=(fsItalic in FontStyles);
  Range.Font.Underline:=(fsUnderline in FontStyles);
end;

procedure TExcel.SetFont(RangeStr: string; Font: TFont);
var
  Range:variant;
begin
  fExcel.Range[RangeStr].Select;
  Range:=fExcel.Selection;
  fSetFontColor(Range,Font.Color);
  fSetFontSize(Range,Font.Size);
  fSetFontName(Range,Font.Name);
  fSetFontStyle(Range,Font.Style);
end;

procedure TExcel.SetFontPos(RangeStr: string; hAlign, vAlign: Cardinal);
begin
  fExcel.Range[RangeStr].HorizontalAlignment:=hAlign;
  fExcel.Range[RangeStr].VerticalAlignment:=vAlign;
end;

procedure TExcel.SetHeight(RowNum: string; Height: integer);
begin
  if fExcel.Rows[RowNum+':'+RowNum].RowHeight<Height then begin
    fExcel.Rows[RowNum+':'+RowNum].RowHeight:=Height;
  end;
end;

procedure TExcel.SetHeight(RowNum, Height: integer);
var
  RowStr:string;
begin
  RowStr:=IntToStr(RowNum);
  SetHeight(RowStr,Height);
end;

procedure TExcel.SetWidth(ColNum, Width: integer);
var
  ColName:string;
begin
  ColName:=Num2Col(ColNum);
  SetWidth(ColName,Width);
end;

procedure TExcel.SetWidth(ColName: string; Width: integer);
begin
  if fExcel.Columns[ColName+':'+ColName].ColumnWidth<Width then begin
     fExcel.Columns[ColName+':'+ColName].ColumnWidth:=Width;
  end;
end;

procedure TExcel.MergeRange(RangeStr: string; hAlign, vAlign: Cardinal);
var
  Range:variant;
begin
  Range:=fExcel.Range[RangeStr];
  Range.HorizontalAlignment:=hAlign;
  Range.VerticalAlignment:=vAlign;
  Range.WrapText:=False;
  Range.Orientation:=0 ;
  Range.AddIndent:=False;
  Range.ShrinkToFit:=False;
  Range.MergeCells:=False;
  Range.Merge;
end;

procedure TExcel.Refresh;
begin
  fExcel.Application.DisplayFullScreen := True;
  fExcel.Application.DisplayFullScreen := False;
end;

procedure TExcel.SetCellValue(CellName:string;CellValue: variant);
begin
  fExcel.ActiveSheet.Range[CellName].Value:= CellValue ;
end;

function TExcel.GetCellValue(CellName: string): Variant;
begin
  Result:=fExcel.ActiveSheet.Range[CellName].Value;
end;

procedure TExcel.CopyUserRangeToAnotherSheet(AnotherSheetName, AnotherBook,SpecifySheetName, SpecifyBook: string);
begin
  if SpecifyBook<>'' then begin
    ActiveWindow(SpecifyBook);
  end;
  fExcel.Sheets.Item[SpecifySheetName].Select;
  fExcel.Sheets.Item[SpecifySheetName].Cells.Select;
  fExcel.Sheets.Item[SpecifySheetName].Cells.Copy;
  fExcel.ActiveSheet.Range['A1'].Select;

  ActiveWindow(AnotherBook);
  fExcel.Sheets.Item[AnotherSheetName].Select;
  fExcel.Sheets.Item[AnotherSheetName].Cells.Select;
  fExcel.Sheets.Item[AnotherSheetName].Paste;
  fExcel.ActiveSheet.Range['A1'].Select;
end;

procedure TExcel.CopyDataAreaToAnotherSheet(AnotherSName, AnotherBook,
  FromDataArea, SpecifySheetName, SpecifyBook: string);
var
  ToDataArea:string;
  DataAreas:TDataAreas;
  i:integer;
begin
  AnalyzeDataAreas(DataAreas,FromDataArea);
  for i:=0 to Length(DataAreas)-1 do begin
    FromDataArea:=DataAreas[i];

    if SpecifyBook<>'' then begin
      ActiveWindow(SpecifyBook);
    end;
    fExcel.Sheets.Item[SpecifySheetName].Select;
    fExcel.ActiveSheet.Range[FromDataArea].Select;
    fExcel.Selection.Copy;
    fExcel.ActiveSheet.Range['A1'].Select;

    ToDataArea:=GetHalfDataArea(FromDataArea,True);

    ActiveWindow(AnotherBook);
    fExcel.Sheets.Item[AnotherSName].Select;
    fExcel.ActiveSheet.Range[ToDataArea].Select;
    fExcel.ActiveSheet.Paste;
    fExcel.ActiveSheet.Range['A1'].Select;
  end;
end;

procedure TExcel.SetActiveSheet(Value: string);
begin
  fExcel.Sheets.Item[Value].Select;
  fActiveSheet:=fExcel.ActiveSheet.Name;
end;

function TExcel.GetActiveSheet: string;
begin
  fActiveSheet:=fExcel.ActiveSheet.Name;
end;

function TExcel.GetUserRangeStr: string;
var
  sRow,eRow,sCol,eCol:integer;
begin
  sRow:=fExcel.ActiveSheet.UsedRange.Row;
  sCol:=fExcel.ActiveSheet.UsedRange.Column;
  eRow:=fExcel.ActiveSheet.UsedRange.Rows.Count+sRow-1;
  eCol:=fExcel.ActiveSheet.UsedRange.Columns.Count+sCol-1;
  Result:=Num2Col(sCol)+IntToStr(sRow)+':'+Num2Col(eCol)+IntToStr(eRow);
end;

function TExcel.GetUserRangeRect: TRect;
var
  sRow,eRow,sCol,eCol:integer;
begin
  sRow:=fExcel.ActiveSheet.UsedRange.Row;
  sCol:=fExcel.ActiveSheet.UsedRange.Column;
  eRow:=fExcel.ActiveSheet.UsedRange.Rows.Count+sRow-1;
  eCol:=fExcel.ActiveSheet.UsedRange.Columns.Count+sCol-1;
  Result.Left:=sCol;
  Result.Top:=sRow;
  Result.Right:=eCol;
  Result.Bottom:=eRow;
end;

procedure TExcel.CopyDataAreaToClipBoard(DataArea, SheetName: string);
begin
  if SheetName<>'' then begin
    fExcel.Sheets.Item[SheetName].Select;
  end;
  fExcel.Range[DataArea].Select;
  fExcel.Selection.Copy;
end;

procedure TExcel.CopyUsedRangeToClipBoard(SheetName: string);
begin
  if SheetName<>'' then begin
    fExcel.Sheets.Item[SheetName].Select;
  end;
  fExcel.ActiveSheet.UsedRange.Select;
  fExcel.Selection.Copy;
end;

procedure TExcel.SelectSheet(SheetName: string);
begin
  fExcel.Sheets.Item[SheetName].Select;
end;

procedure TExcel.SelectSheet(SheetIndex: integer);
begin
  fExcel.Sheets.Item[SheetIndex].Select;
end;

procedure TExcel.GetSheets(var SheetList: TStrings);
var
  i:integer;
  Count:integer;
begin
  SheetList.Clear;
  Count:=fExcel.Sheets.Count;//如果出现ole错误的话请看是否打开了文件
  for i:=1 to Count do begin
    SheetList.Add(fExcel.Sheets.Item[i].Name);
  end;
end;

function TExcel.GetSheetIndex(Name: string): integer;
begin
  Result:=fExcel.Sheets.Item[Name].Index;
end;

function TExcel.GetSheetName(Index: integer): string;
begin
  Result:=fExcel.Sheets.Item[Index].Name;
end;

end.

uShareFunc文件入下:

unit uShareFunc;

interface

uses
  windows,Classes,sysutils,Math,Forms,ShellApi,ClipBrd,Grids,ShlObj;

resourcestring
  rcNoFoundHelpFile='没有找到帮助文件 - (%s)';
  rcRunHelpFailed='运行帮助发生错误　- (%s)';
  rcCreateSemaphoreError='建立互斥对象发生错误';  
//错误激发函数RaiseError参数和Format类似。
procedure RaiseError(const ErrMsg:string;const Values:array of const);overload;
procedure RaiseError(const ErrMsg:string);overload;
function  GetWindowCurPos():HWND;
function  GetExeDir():string;
function  GetTextFromClipBoard():string;
procedure CopyClipBoardToStringGrid(sCol,sRow:integer;var StringGrid:TStringGrid);
procedure MsgInfo(Text:string);
function  MsgConfirm(Text:string):boolean;
function  Pad0(Value:int64;Size:integer;IsBefore:boolean):string;overload;
function  Pad0(Value:integer;Size:integer;IsBefore:boolean):string;overload;
procedure ShowFormModal(Form:TForm);
procedure RunHelp(HelpFile:string);
procedure RunOnlyOne(App:TApplication);//程序只运行一次：适用任何情况
function  GetFileNameWithoutExt(FileName:string):string;
function  GetSelectDirectory():string;
procedure GetDirctoryFiles(var Files:TStrings;Path:string);
function  PathToDir(Path:string):string;
procedure SetStringGridWidth(StringGrid:TStringGrid;const Col,Row:integer);
function  ReplaceText(RepText,FindText,Text:string):string;

implementation

function  ReplaceText(RepText,FindText,Text:string):string;
var
  FindLen,FindPos:integer;
begin
  FindText:=UpperCase(FindText);
  FindPos:=Pos(FindText,UpperCase(Text));
  if FindPos<>0 then
    Result:=Copy(Text,1,FindPos-1)+RepText
  else begin
    Result:=Text;
    Exit;
  end;
  FindLen:=Length(FindText);
  while True do begin
    Text:=Copy(Text,FindPos+FindLen,Length(Text));
    FindPos:=Pos(FindText,UpperCase(Text));
    if FindPos<>0 then
      Result:=Result+Copy(Text,1,FindPos-1)+RepText
    else begin
      Result:=Result+Text;
      Break;
    end;
  end;
end;

function  GetWindowCurPos():HWND;
var
 CursorPos:TPoint;
begin
  GetCursorPos(CursorPos);
  Result:=WindowFromPoint(CursorPos);
end;
function  GetExeDir():string;
begin
  Result:=ExtractFileDir(ParamStr(0));
  if Result[Length(Result)]='/' then
    Result:=Copy(Result,1,Length(Result)-1);
end;
function  GetTextFromClipBoard():string;
var
  ClipBoard:TClipBoard;
begin
  ClipBoard:=TClipBoard.Create();
  try
    Result:=ClipBoard.AsText;
  finally
    ClipBoard.Free;
  end;
end;
procedure CopyClipBoardToStringGrid(sCol,sRow:integer;var StringGrid:TStringGrid);
var
  Row,Col,EnterPos,TabPos,Len:integer;
  TextLeft,LineText,Str:string;
begin
  Row:=0;
  TextLeft:=GetTextFromClipBoard();
  if TextLeft<>'' then begin
    Len:=Length(TextLeft);
    if (Len=1) or ( not ((TextLeft[Len]=#$A) and (TextLeft[Len-1]=#$D))) then
      TextLeft:=TextLeft+#$D#$A;
    while True do begin
      Col:=0;
      EnterPos:=Pos(#$D#$A,TextLeft);
      if EnterPos=0 then break;
      SetLength(LineText,EnterPos-1);
      Move(TextLeft[1],LineText[1],EnterPos-1);
      LineText:=LineText+#9;
      Delete(TextLeft,1,EnterPos+1);
      while True do begin
        TabPos:=Pos(#9,LineText);
        if TabPos=0 then break;
        SetLength(Str,TabPos-1);
        Move(LineText[1],Str[1],TabPos-1);
        Delete(LineText,1,TabPos);
        StringGrid.Cells[sCol+Col,sRow+Row]:=Str;
        SetStringGridWidth(StringGrid,Col+Col,sRow+Row);
        Inc(Col);
      end;
      Inc(Row);
    end;
  end;  
end;
procedure MsgInfo(Text:string);
var
 Wnd:HWND;
begin
  Wnd:=GetWindowCurPos();
  MessageBox(Wnd,PChar(Text),PChar('提示信息'),MB_ICONINFORMATION+MB_OK);
end;
function MsgConfirm(Text:string):boolean;
var
 Wnd:HWND;
begin
  Wnd:=GetWindowCurPos();
  Result:=MessageBox(Wnd,pchar(Text),pchar('确认信息'),MB_ICONEXCLAMATION+MB_OKCANCEL)=IDOK ;
end;

procedure RaiseError(const ErrMsg:string;const Values:array of const);overload;
begin
  raise Exception.Create(Format(ErrMsg,Values));
end;
procedure RaiseError(const ErrMsg:string);overload;
begin
  raise Exception.Create(ErrMsg);
end;

function  Pad0(Value:integer;Size:integer;IsBefore:boolean):string;
var
  FactSize:integer;
  ValueStr:string;
  Int64Value:int64;
begin
  ValueStr:=IntToStr(Value);
  FactSize:=Length(ValueStr);
  if FactSize>=Size then begin
    Result:=ValueStr;
    Exit;
  end;
  if IsBefore then begin
    Int64Value:=Value+Trunc(IntPower(10,Size));
    ValueStr:=IntToStr(Int64Value);
    Result:=Copy(ValueStr,2,Length(ValueStr));
  end else begin
    Int64Value:=Value*Trunc(IntPower(10,Size-FactSize));
    ValueStr:=IntToStr(Int64Value);
    Result:=Copy(ValueStr,1,Length(ValueStr));
  end;
end;

function  Pad0(Value:int64;Size:integer;IsBefore:boolean):string;
var
  FactSize:integer;
  ValueStr:string;
begin
  ValueStr:=IntToStr(Value);
  FactSize:=Length(ValueStr);
  if FactSize>=Size then begin
    Result:=ValueStr;
    Exit;
  end;
  if IsBefore then begin
    Value:=Value+Trunc(Power(10,Size*1.0));
    ValueStr:=IntToStr(Value);
    Result:=Copy(ValueStr,2,Length(ValueStr));
  end else begin
    Value:=Value*Trunc(Power(10,(Size-FactSize)*1.0));
    ValueStr:=IntToStr(Value);
    Result:=Copy(ValueStr,1,Length(ValueStr));
  end;
end;
procedure ShowFormModal(Form:TForm);
begin
  try
    Form.ShowModal;
  finally
    Form.Release;
  end;
end;

procedure RunHelp(HelpFile:string);
begin
  if FileExists(HelpFile) then   begin
    if ShellExecute(0,nil,PChar(HelpFile),nil,nil,SW_NORMAL)<=32 then begin
      RaiseError(rcRunHelpFailed,[HelpFile]);
    end;
  end else RaiseError(rcNoFoundHelpFile,[HelpFile]);//ShowMessage('没有找到帮助文件:'+HelpFile);
end;

procedure RunOnlyOne(App:TApplication);//程序只运行一次：适用任何情况
var
  Sem:integer;
begin
  Sem:=CreateSemaphore(nil,0,1,'{C0C658A0-FAD5-11D5-9196-0050BAF08A43}');
  if Sem=0 then RaiseError(rcCreateSemaphoreError);// Exception.Create('');
  if not ReleaseSemaphore(sem,1,nil) then halt;
end;
function  GetFileNameWithoutExt(FileName:string):string;
var
  Ext:string;
  Len:integer;
begin
  FileName:=ExtractFileName(FileName);
  Ext:=ExtractFileExt(FileName);
  Len:=Length(Ext);
  Delete(FileName,Length(FileName)-Len+1,Len);
  Result:=FileName;
end;

procedure GetDirctoryFiles(var Files:TStrings;Path:string);
var
  sr:TSearchRec;
begin
  Files.Clear;
  if FindFirst(Path,faAnyFile,sr)=0  then begin
    Files.Add(sr.Name);
    while FindNext(sr)=0 do begin
      Files.Add(sr.Name);
    end;
    FindClose(sr);
  end;
end;



function  PathToDir(Path:string):string;
var
  Len:integer;
begin
  Len:=Length(Path);
  if Len=0 then Exit;
  if Path[Len]='/' then begin
    System.Delete(Path,Len,1);
  end;
  Result:=Path;
end;
procedure SetStringGridWidth(StringGrid:TStringGrid;const Col,Row:integer);
var
  OldWidth,NewWidth:integer;
  Text:string;
begin
  if Col>StringGrid.ColCount-1 then Exit;
  OldWidth:=StringGrid.ColWidths[Col];
  Text:=StringGrid.Cells[Col,Row];
  Text:=ReplaceText('3',' ',Text);
  Text:=ReplaceText('伙','　',Text);
  NewWidth:=StringGrid.Canvas.TextWidth(Text+'伙');
  if OldWidth>= NewWidth then Exit;
  StringGrid.ColWidths[Col]:=NewWidth;
end;
function  GetSelectDirectory():string;
var
  Bi:BROWSEINFO;
  DisplayName:array  [0..MAX_PATH-1]of char;
  pIDl:PItemIDList;
begin
  Result:='';
  BI.hwndOwner:=GetWindowCurPos();
  Bi.pidlRoot:=nil;
  Bi.pszDisplayName:=@DisplayName;
  Bi.ulFlags:=BIF_RETURNONLYFSDIRS ;
  Bi.lpszTitle:='选择文件夹:';
  Bi.lpfn :=nil;
  Bi.lParam:= 0;
  Bi.iImage:= 0;
  pIDl:=(SHBrowseForFolder(Bi));
  if pIDl<>nil then begin
    SHGetPathFromIDList(pIDl,@DisplayName);
    Result:=StrPas(DisplayName);
    Result:=PathToDir(Result);
  end;
end;
end.