100分，求最完美的execl的控制程序！谢谢！(100分)

给了提示也给分，千万别让我用“ole”。
控制execl最好的，速度最快的用什么方式？谢谢！

这有一个例子你看看对你有没有帮助！！
http://stgzs.myetang.com/DelphiSrc/tstexcel.zip

文件列表:
uExcel
uShareFunc

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 in ['A'..'Z'] then
Result:=Result+HalfDataArea
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 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);
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);
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 in ['0'..'9']) then begin
Result:=False;
Break;
end;
end;
if i=1 then begin//如果首个是数字为假
Result:= not(HalfStr in ['0'..'9']);
if (not Result) then Break;
end;
if HalfStr in ['A'..'Z','a'..'z','0'..'9'] then begin
//如果还没有开始数字字符，则判断是否开始了数字．如果开始
//如果开始了数字则不判断了．
if not StartNum then StartNum:=(HalfStr in ['0'..'9']);
if StartNum then begin
Result:= not(HalfStr 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;
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)-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.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;
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.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;
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;

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.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;
pIDlItemIDList;
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.

多人接受答案了。

ok