unit myclass;
{
一組文件及目錄操作函數，可直接引用此單元文件。
歡迎大家批評指正！
作者：董曉軍(lukisy)
E-mail:lukisy@sohu.com
http://www.jlspinfo.com
}
interface
uses
windows,SysUtils,shellapi,classes,forms,ADODB,Controls,inifiles,dialogs,filectrl;
 type
    TMyfunction = class (TComponent)
        private
          AdoAccesscon:string;
          AdoSqlserver:string;
          Confingfiles:string;
          TTmpfiles:string;
          TLogfiles:string;
          TErrfiles:string;
          Function Dir(source,dest,cmd:string):boolean;   //1
        public
          Function DCopyDirectorysub(source,dest:string):boolean;   //  2  復制目錄，在目標路徑下生成原目錄
          Function DCopyDirectorynul(source,dest:string):boolean;   //  3  復制目錄，在目標路徑下生不成原目錄
          Function DMoveDirectory(source,dest:string):boolean;      //  4  移動目錄，
          Function DDeleteDirectory(source:string):boolean;         //  5  刪除目錄
          Function DFindDirectory(source:string;findout:tstringlist):boolean;  //  6  查找子目錄，結果保存在findout中
          Function DGetdir:string;  //選擇目錄
          Function FFileSearch(Filepath,Ext:string;findout:tstringlist;Subdir:boolean):boolean;
          //  7  查找文件，filepath 路徑，ext 擴展名，findout 結果， subdir 是否查找子目錄。
          Function SSetAdoaccess(Accessfile,passwd:string):string;
          // 8  設置adoaccess連接
          Function SSetAdosqlserver(Host,User,Passwd,Database:string):string;overload;
          Function SSetAdosqlserver(Configfile:string):string;overload;
          //  9，10  設置adosqlserver連接。
          Function WRunproc(filepaths:string):boolean;
          //  11  執行外部程序
          Function WAskinfo(title:string;body:string):boolean;
          // 12 詢問框，
          Function WWriteerrorlog(filename:string;data:string;notime:boolean=false):boolean;
          // 13  寫錯誤日志  notime 是否寫時間

 end;
 procedure Register;
implementation


procedure Register;
begin
//  registercomponents('myclass',
  RegisterComponents('MyClass', [TMyfunction]);
end;
Function TMyfunction.Dir(source,dest,cmd:string):boolean;
var
//1
 fo: TSHFILEOPSTRUCT;
begin
 FillChar(fo, SizeOf(fo), 0);
 with fo do
 begin
   Wnd := 0;
   if cmd='copy' then
   wFunc := FO_COPY
   else
   wFunc := FO_MOVE;
   pFrom := PChar(source+#0);
   pTo := PChar(Dest+#0);
   fFlags := FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR+FOF_SILENT;//FOF_SILENT不顯示進度條
 end;
 {
 FO_COPY:拷貝pfrom域中指定的（目錄，例中是'c:\a'）到pto中指定的位置（例中為'c:\b') 
        FO_DELET:刪除pfrom中指定的文件.   (pTo不用) 
        FO_MOVE:移動PFrom中指定的文件到pto中指定的位置。  
        FO_RENAME:給PFrom中指定的文件改名。
pFrom:指定一個或多個源文件名的緩沖區地址。多個名字必須用NULL分隔。名字列表必須用兩個NULL（nil,'\0')來結束。
pTo：目標文件或目錄名緩沖區地址。 如果fFlags域指定FOF_MULTIDESTFILES，緩沖區可以包含多個目標文件名。多個名字必須用NULL分隔。名字列表必須用兩個NULL（nil,'\0')
fFlags :控制操作的標志,可以是以下各值組合：
        FOF_ALLOWUNDO:保留Undo信息， 如果pFrom沒有包含全的絕對的路徑或文件名此值忽略。
        FOF_CONFIRMMOUSE:沒有實現.
        FOF_FILESONLY:只有文件名使用通配符時（*.*)才對文件操作。
        FOF_MULTIDESTFILES:  pTo域指一定了多個目標文件.(一個對就一個源文件) 而不是指定一個目錄來存放所有源文件  
        FOF_NOCONFIRMATION:所有顯示的對話框全部選擇yes to all
        FOF_NOCONFIRMMKDIR: 如果需要創建一個新目錄不確認。
        FOF_NOCOPYSECURITYATTRIBS:  4.71. Microsoft® Windows NT® only. 安全屬性不復制.
        FOF_NOERRORUI:發生錯誤時不提供用戶接口。
        FOF_RENAMEONCOLLISION:  move,copy,rename操作時如目標文件存在，給操作的文件另起一個名字。
        FOF_SILENT:不顯示進度對話框
        FOF_SIMPLEPROGRESS:顯示進度對話框但不顯示文件名。
        FOF_WANTMAPPINGHANDLE:如果指定了FOF_RENAMEONCOLLISION 當任何文件改名時將填寫hNameMappings 域
fAnyOperationsAborted:當用戶在完成前取消任何文件操作時賦值TRUE，否則FALSE.
}
 Result := (SHFileOperation(fo) = 0);
end;
///////////////////////////////////////
Function TMyfunction.DCopyDirectorysub(source,dest:string):boolean;
begin
//2
 if directoryexists(source) then
     begin
         if not directoryexists(dest) then
            ForceDirectories(dest);
         result:=Dir(source,dest,'copy');
     end else
         begin
             result:=false;
         end;
end;
///////////////////////////////////////
Function TMyfunction.DCopyDirectorynul(source,dest:string):boolean;
//3
//目錄復制,將原目錄中的所有文件復制到目標目錄中,且在
//目標目錄中不生成原目錄名.
    var
      Search : TSearchRec;
      Rec    : word;
Begin
      result:=false;
      try
      Source := IncludeTrailingBackslash(Source);
      dest   := IncludeTrailingBackslash(Dest);
      Rec := FindFirst(Source + '*.*', faAnyFile, Search);
      While Rec = 0 Do
      Begin
        If Search.Name[1] <> '.' Then
        Begin
          If (Search.Attr And faDirectory) = faDirectory Then
          Begin
            Windows.CreateDirectory(PChar(Dest+Search.Name), nil);
            FileSetAttr(Dest+Search.Name, FileGetAttr(Source+Search.Name));
            DCopyDirectorynul(Source+ Search.Name, Dest+ Search.Name);
          end
          Else
          Begin
            CopyFile(PChar(Source+ Search.Name),PChar(Dest+ Search.Name), True);
            FileSetAttr(Dest+ Search.Name, FileGetAttr(Source+ Search.Name));
            Application.ProcessMessages;
          end;
        end;
        Rec := FindNext(Search);
      end;
      FindClose(Search);
      result:=true;
      except
      end;
end;
///////////////////////////////////////
Function TMyfunction.DMoveDirectory(source,dest:string):boolean;
begin
//4
 if directoryexists(source) then
     begin
         if not directoryexists(dest) then
            ForceDirectories(dest);
         result:=Dir(source,dest,'cut');
     end else
         begin
             result:=false;
         end;
end;
///////////////////////////////////////
Function TMyfunction.DDeleteDirectory(source:string):boolean;
var
//5
   lpFileOp: TSHFileOpStruct;
begin
   with lpFileOp do
     begin
     Wnd := application.Handle;
     wFunc := FO_DELETE;
     pFrom := pchar(source + #0);//此為要刪除的文件或目錄，支持*、？
     pTo := nil;
     fFlags := FOF_noconfirmation;
     hNameMappings := nil;
     lpszProgressTitle := nil;
     fAnyOperationsAborted := True;
   end;
if SHFileOperation(lpFileOp) <> 0 then
//   ShowMessage('刪除失敗，請查實。');
end;
///////////////////////////////////////
Function TMyfunction.DFindDirectory(source:string;findout:tstringlist):boolean;
var
//6
//查找所選目錄下的所有子目錄
 sr: TSearchRec;
begin
Source := IncludeTrailingBackslash(Source);
 if FindFirst(source + '*.*', faDirectory, sr) = 0 then
   begin
     repeat
       if ((sr.Attr and faDirectory) > 0) and (sr.Name <> '.') and (sr.Name <> '..') then
         begin
           findout.Add(sr.Name);
           //a.Add(source + sr.Name);
         end;
     until FindNext(sr) <> 0;
     FindClose(sr);
   end;
end;
///////////////////////////////////////
Function TMyfunction.FFileSearch(Filepath,Ext:string;findout:tstringlist;Subdir:boolean):boolean;
var
//7
 sr: TSearchRec;
 a,b,c:tstringlist;
 i:integer;
begin
{遞歸查找指定目錄下的所有文件
pathname為指定的目錄，格式為： 'c:\a';
filename為要查找的文件名，支持通配符號
nt為是否查找子目錄，當為 true時 會自動查找 pathname的子目錄。
返回值為查找結果字符串
}
a:=tstringlist.Create;
b:=tstringlist.Create;
c:=tstringlist.Create;
DFindDirectory(filepath,c);
application.ProcessMessages;
filepath:=IncludeTrailingBackslash(filepath);
   if FindFirst(filepath+ext, faAnyFile, sr) = 0 then
    begin
     if (sr.Name = '.') or (sr.Name = '..') then
     else
        if (sr.Attr and faDirectory)=0 then
            b.Add(filepath+sr.name); //文件
        //else
            //a.Add(filepath+sr.name);
     while FindNext(sr) = 0 do
       begin
          //showmessage(sr.Name);
          application.ProcessMessages;
          if (sr.Name = '.') or (sr.Name = '..') then
          else
             if (sr.Attr and faDirectory)=0 then
                 b.Add(filepath+sr.name);
            // else
            //     a.Add(filepath+sr.name);
       end;
    FindClose(SR);
    application.ProcessMessages;
    end;
   // showmessage(c.text);
  if (trim(c.text)<>'') and (Subdir) then
  for i:=0 to c.Count-1 do
    begin
      if directoryexists(filepath+c[i]) then
        begin
         //if nt then
           application.ProcessMessages;
           FFileSearch(filepath+c[i],ext,findout,Subdir);
           application.ProcessMessages;
        end
      else
        begin
          application.ProcessMessages;
          //b.Add(pathname+'\'+a[i]);
        end;
    end;
for i:=0 to b.Count-1 do
   begin
       if trim(b[i])<>'' then
           a.Add(b[i]);
   end;
//a:=a+b;
//result:=trim(a.Text);
findout.Text:=findout.text+trim(a.Text);
a.free;
c.Free;
b.Free;
end;
///////////////////////////////////////
Function TMyfunction.SSetAdoaccess(Accessfile,passwd:string):string;
begin
//8
result:='Provider=Microsoft.Jet.OLEDB.4.0;Data Source='
        +trim(Accessfile)+';Persist Security Info=False'
        +';Jet OLEDB:Database Password='+trim(passwd);
end;
Function TMyfunction.SSetAdosqlserver(Host,User,Passwd,Database:string):string;
begin
//9
host:=trim(host);
user:=trim(user);
passwd:=trim(passwd);
database:=trim(database);
result:='Provider=SQLOLEDB.1;Password='+passwd
        +';Persist Security Info=True;User ID='+user
        +';Initial Catalog='+database+';Data Source='+host;

end;
///////////////////////////////////////
Function TMyfunction.SSetAdosqlserver(Configfile:string):string;
var
//10
ini:tinifile;
a:tstringlist;
pass,username,host,db:string;
begin
a:=tstringlist.create;
if trim(configfile)<>'' then
Ini := TIniFile.Create(Configfile)
else
ini :=tinifile.Create(extractfilepath(paramstr(0))+'config.ini');
try
Ini.ReadSectionValues('Config',a);
username:=copy(a[0],10,100);
pass:=copy(a[1],10,100);
host:=copy(a[2],6,100);
db:=copy(a[3],10,100);
result:='Provider=SQLOLEDB.1;'+
        'Password='+pass+
        ';Persist Security Info=True;'+
        'User ID='+username+
        ';Initial Catalog='+db+
        ';Data Source='+host;
finally
a.Free;
ini.Free;
end;
end;
///////////////////////////////////////
function TMyfunction.WRunproc(filepaths:string):boolean;
//11
begin
 result:=true;
 ShellExecute(application.Handle ,'open',pchar(filepaths),nil,nil,SW_ShowNormal);
end;
///////////////////////////////////
function  TMyfunction.WAskinfo(title:string;body:string):boolean;
//12
begin
if  application.MessageBox(pchar(body),pchar(title),mb_yesno)=mryes  then
  begin
  result:=true
  end
else
  begin
  result:=false;
  end;
end;

Function TMyfunction.WWriteerrorlog(filename:string;data:string;notime:boolean=false):boolean;
// 13
//寫記錄文件，filename：文件絕對路徑和文件名，data：記錄內容
var
err:textfile;
begin
try
filename:=trim(filename);
assignfile(err,filename);
if fileexists(filename) then
 begin
  append(err);
 end
else
 begin
  rewrite(err);
 end;
if notime then
writeln(err,data)
else
writeln(err,data+'   '+datetimetostr(now()));
closefile(err);
result:=true;

except
on e:exception do
 begin
  // e.Message
 end;
end;
end;
///////////////////////////////////
function TMyfunction.DGetdir:string ;
var
s:string;
begin
if selectdirectory('','',s) then
  result:=trim(s);
end;
end.