myclass.pas

数据库通用工具

unit myclass;
{
一组文件及目录操作函数，可直接引用此单元文件。
欢迎大家批评指正！
作者：董晓军(lukisy)
E-mail:[e-mail]
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.