unit Unit2;

interface

uses
   Windows,SysUtils, Controls,Classes,Messages,//,Dialogs// Forms,
  //NMFtp,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,IdFTP,
  inifiles,Cryptcon,Desunit2,rjmime,shellapi; //   ComCtrls,  Psock,
               
type
  TSetOracleEnv = function(dir:pchar;IsOCI:Boolean=true;dbtype:Integer=0):boolean;stdcall;
  EDLLLoadError = class(Exception); //定义异常类，捕捉调用DLL异常

  const
    iniFileName1:String='oraback.ini';

    ExportParamCount = 32;     
    SCHEME_VALUES:Array[0..ExportParamCount] Of String=
      ('NAME','PARFILE','RUNTIME','RUNDATE','CYCLE','USERNAME','PASSWORD','SERVER','ARCDIR','ISZIP'
      ,'SAVECYCLE','LEVELAST','FTP_HOST','FTP_USE','FTP_PASS','FTP_PORT','FTP_DMP','FTP_RAR','LASTTIME','RUNCOUNT'
      ,'THEHOLDDAYS','ISDELZIP','FTP_DIR','ZIPPASSWORD','ORACLEHOME','SERVER2','NoPassive','IsShow','IsContinue'
      ,'DbType','INCTYPE','FtpIsUtf8','FtpIsUTC'
    );
    //计划参数名称数组
    PlanParamCount = 10;
    PLAN_VALUES:Array[0..PlanParamCount] Of String=
      ('NAME','RUNTIME','RUNDATE','CYCLE','LASTTIME','RUNCOUNT','ISSTART','SECTIONS','SECTIONNAMES','INDEX','IsShow'
    );
    //增加备份文件缺省后缀 
    DEFAULT_FILE_EXT:Array[0..2] Of String=
      ('.dmp','.bak','.sql'
    );
    //备份数据库类型
    Database_Types:Array[0..2] Of String= ('Oracle','SQLServer','MySQL');

var
    NMFTP1: TIdFTP;
    TheDate:TDate;
    iniFileName:String;
    Current_Scheme_Values:Array[0..ExportParamCount] Of String;
        boutarray: array[0..31] of char; 
    Current_Plan_Values:Array[0..PlanParamCount] Of String;
    path:String;//当前路径
    MaxExitCode:Cardinal=3;//数据导出最大正常退出码
    Curr_DBFile_Ext:String='.dmp';//当前文件后缀
    Curr_ZipFile_Ext:String='.7z';//改为7z压缩 '.当前压缩文件后缀
    Curr_DB_Type:Integer=0;//当前数据库类型
    FtpIsUtf8:Integer=1;//Ftp服务器是否支持 UTF8 编码
    IsWindowsUser:boolean=false;
    FtpIsUTC:Integer=1;//Ftp上传文件日期是否转换标准时间


    procedure callPlan(cmd,param,isShow:String);


implementation

uses Math;

function ArrayLength(a:Array of char):integer;
var i:integer;
begin
  Result:=0;
  for i:=high(boutarray)-1 downto 0 do begin
    if (boutarray[i]<>#0) and (i<>0) then begin
      Result:=i+1;
      Break;
    end;
  end;
end;


function decode_string(s:string ):string;
var s1:string;ot:array[0..31] of char;
  i:integer;
  des1 : Tdes;
begin
  if length(trim(s))=0 then begin
    result:='';
    exit;
  end;
  des1 := TDES.Create(nil);
  try
    fillchar(boutarray,sizeof(boutarray),#0);
    fillchar(ot,sizeof(ot),' ');
    s1:=MimeDecodeString(s);
    for i:=1 to length(s1) do begin
      boutarray[i-1]:=s1[i];
    end;
    {StrPCopy(inStr, Edit2.Text);}
    des1.Key := 'abcdefghijklmnopqrstuvwxyz';
    des1.InputLength := length(s1);//8;
    des1.CipherMode := ECBMode;
    des1.pInputArray := @boutarray;
    des1.InputType := SourceByteArray;
    des1.pOutputArray :=@ot;
    des1.DecipherData(False);
    i:=ArrayLength(ot);
    SetString(s1, ot, i);
    Result:=trim(s1);
  finally
   des1.Destroy;
 end;{Finally}

end;


procedure SaveErrorLog(msg:String;flag:Integer=0);
    //增加保存错误日志的函数
const  //xxy 2021-05-08 增加
  logname:array[0..1,0..1] of String = (('expback_error.log','expback_exp.log'),('错误','信息'));
var
  s,n:String;
  hLogFile:TextFile;
  info:String;
begin
  try
    flag := flag mod 2;
    n := logname[0,flag];
    info := ',' + logname[1,flag] + ':';

    n:=path+'log\'+n;
    try
      AssignFile(hLogFile, n);
      If FileExists(n) Then
        Append(hLogFile)
      Else
        Rewrite(hLogFile);
      //处理缺省方案
      s := Current_Scheme_Values[1];
      if s='NULL' then
        s:='缺省';
      s := FormatDateTime('yyyy-MM-dd HH:mm:ss ZZZ',now) + ',当前方案:'+s+ info +msg;
      Writeln(hLogFile,s);
    finally
      CloseFile(hLogFile);
    end;
  except
  end;
end;

function LocalToUTCTime(time1:TDatetime):TDateTime;
//将本地时间转换成UTC标准时间
var
  tziOld:TIME_ZONE_INFORMATION;
begin
  GetTimeZoneInformation(tziOld);
  result:=time1+tziOld.Bias/(60*24);
end;

procedure FTPBackFile;
var s,SCH,dmpname,rarname:string;
  IsZip:boolean;
  d1,d2:String;
  dmpname1,rarname1:string; //转换utf8后的文件名
begin
  if Current_Scheme_Values[12]='' then exit;
  if (Current_Scheme_Values[16]<>'1') and (Current_Scheme_Values[17]<>'1') then exit;
  //如果使用了压缩,那么不管设置如何,有上传时,只上传压缩后的文件
  IsZip:=Current_Scheme_Values[9]='1';

  NMFTP1:=TIdFTP.Create(nil);
  NMFTP1.Host:=Current_Scheme_Values[12];
  NMFTP1.Username:=Current_Scheme_Values[13];
  NMFTP1.Password:=decode_string(Current_Scheme_Values[14]);
  NMFTP1.Port:=StrToInt(Current_Scheme_Values[15]);
  if Current_Scheme_Values[26] <> '1' then
      NMFTP1.Passive := true;
  try
    NMFTP1.Disconnect;
  except 
  end;
  try
    NMFTP1.connect;
  except on E: Exception do
    SaveErrorLog('FTP连接错误:'+e.Message);
  end;
  if NMFTP1.Connected then begin
  SCH:=Current_Scheme_Values[1];
  if SCH='缺省' then
      SCH:=''
  else
      SCH:='_'+SCH;
  S:=FormatDateTime('YYYY-MM-DD',TheDate);
  dmpname:=Current_Scheme_Values[5]+'_'+S+SCH+Curr_DBFile_Ext;
  rarname:=Current_Scheme_Values[5]+'_'+S+SCH+Curr_ZipFile_Ext;
  if FtpIsUTC <> 1 then
  begin
    d1 := FormatDateTime('yyyyMMddHHmmss',FileDateToDateTime(FileAge(Current_Scheme_Values[5]+'\'+dmpname)));
    d2 := FormatDateTime('yyyyMMddHHmmss',FileDateToDateTime(FileAge(Current_Scheme_Values[8]+'\'+Current_Scheme_Values[5]+'\'+rarname)));
  end else begin
    d1 := FormatDateTime('yyyyMMddHHmmss',LocalToUTCTime(FileDateToDateTime(FileAge(Current_Scheme_Values[5]+'\'+dmpname))));
    d2 := FormatDateTime('yyyyMMddHHmmss',LocalToUTCTime(FileDateToDateTime(FileAge(Current_Scheme_Values[8]+'\'+Current_Scheme_Values[5]+'\'+rarname))));
  end;

  //增加文件名转换
  if FtpIsUtf8 = 1 then
  begin
    dmpname1 := AnsiToUtf8(dmpname);
    rarname1 := AnsiToUtf8(rarname);
  end else begin
    dmpname1 := dmpname;
    rarname1 := rarname;
  end;
  try
    try

      try //2009-06-24 增加FTP服务器也增加总备份目录
        NMFTP1.ChangeDir(Current_Scheme_Values[22]);
      except
         NMFTP1.MakeDir(Current_Scheme_Values[22]);
         NMFTP1.ChangeDir(Current_Scheme_Values[22]);
      end;
      try
        NMFTP1.ChangeDir(Current_Scheme_Values[5]);
      except
         NMFTP1.MakeDir(Current_Scheme_Values[5]);
         NMFTP1.ChangeDir(Current_Scheme_Values[5]);
      end;
      //2009-06-23 增加FTP也按用户目录保存
      if (not IsZip) and (Current_Scheme_Values[16]='1') and FileExists(Current_Scheme_Values[5]+'\'+dmpname) then
      begin         

          NMFTP1.Put(Current_Scheme_Values[5]+'\'+dmpname,dmpname1);

          NMFTP1.SendCmd('MDTM ' + d1 + ' ' + dmpname1);
      end;

      if (IsZip) or (Current_Scheme_Values[17]='1') or FileExists(Current_Scheme_Values[8]+'\'+Current_Scheme_Values[5]+'\'+rarname) then
      begin

          NMFTP1.Put(Current_Scheme_Values[8]+'\'+Current_Scheme_Values[5]+'\'+rarname,rarname1);

          NMFTP1.SendCmd('MDTM ' + d2 + ' ' + rarname1);
      end;
    except on E: Exception do 
      //增加保存错误日志
      SaveErrorLog('FTP上传错误:'+e.Message);
    end;
  finally
    NMFTP1.Disconnect;
    NMFTP1.Destroy;
  end;
  end;
end;

procedure DelOldFile;
var
  dmpname,rarname,S,SCH:String;
  D1,D2:TDate;
  I,DayCount,HoldDays:INTEGER;
  HasLeve:boolean;
    SaveCycle:Integer;
    IsZip,LeveLast,IsDelZip:Boolean;
    ArcDir,UserName:String;
begin

  SaveCycle:=StrToInt(Current_Scheme_Values[10]);
  IsZip:=Current_Scheme_Values[9]='1';
  ArcDir:=Current_Scheme_Values[8];
  UserName:=Current_Scheme_Values[5];
  LeveLast:=Current_Scheme_Values[11]='1';
  S := Current_Scheme_Values[20];
  IsDelZip:=Current_Scheme_Values[21]='1';
  //HoldDays := 1;
  try
    HoldDays := StrToInt(S);
  except
    HoldDays := 1;
  end;
  If HoldDays<1 Then
    HoldDays := 1;

  case SaveCycle of
    1: //一个月
    begin
        D1:=IncMonth(TheDate,-2)+1;
        D2:=IncMonth(TheDate,-1);
        HasLeve:=true;
    end;
    2: //一周
    begin
        D1:=TheDate-13;
        D2:=D1+6;
        HasLeve:=true;
    end;
    3: //本月
    begin
        D1:=StrToDate(FormatDateTime('YYYY-MM',IncMonth(TheDate,-1))+'-01');
        D2:=IncMonth(D1,1)-1;
        HasLeve:=false;
    end;
    4: //本周
    begin
        D1:=(TheDate-DayOfWeek(TheDate)+2)-7;
        D2:=D1+6;
        HasLeve:=false;
    end;
    5: //当天
    begin
        D1:=TheDate-7;
        D2:=D1+6;
        HasLeve:=true;
    end;
    6: //指定天数
    begin
        D1:=TheDate-2*HoldDays+1;
        D2:=D1+HoldDays-1;
        HasLeve:=true;
    end;
    7: //不保存dmp 2012-02-28
    begin
        D1:=TheDate;
        D2:=D1;
        HasLeve:=true;
    end;
  else begin
      exit;
  end;
  end;
  SCH:=Current_Scheme_Values[1];
  if SCH='缺省' then
      SCH:=''
  else
      SCH:='_'+SCH;
  //当使用了文件压缩时,则不保存dmp原文件,因为这样加密压缩没有意义了,如果勾选了删除zip文件,又选择了不保存,则按保存当天处理
  if IsZip then
  begin
    S:=FormatDateTime('YYYY-MM-DD',TheDate);
    dmpname:=UserName+'\'+UserName+'_'+S+SCH+Curr_DBFile_Ext;//xxy 2020-09-05 '.dmp';
    rarname:=ArcDir+'\'+UserName+'\'+UserName+'_'+S+SCH+Curr_ZipFile_Ext;//xxy 2020-09-05 '.rar';
    if FileExists(rarname) then
      DeleteFile(dmpname);
  end;
  if IsZip and IsDelZip and (SaveCycle = 7) then
  begin
    D1:=TheDate-7;
    D2:=D1+6;
    HasLeve:=true;
  end;

  DayCount:=round(D2-D1);
  for I := 0 to DayCount do
  begin
      S:=FormatDateTime('YYYY-MM-DD',D2-I);
      dmpname:=UserName+'\'+UserName+'_'+S+SCH+Curr_DBFile_Ext;
      rarname:=ArcDir+'\'+UserName+'\'+UserName+'_'+S+SCH+Curr_ZipFile_Ext;
      if FileExists(dmpname) then
      begin
          if LeveLast and not HasLeve then
          begin
             HasLeve:=true;
             continue;
          end;
          DeleteFile(dmpname);
      end;
      if IsDelZip AND IsZip and FileExists(rarname) then
      begin
          if not HasLeve then
          begin
              HasLeve:=true;
              continue;
          end;
          DeleteFile(rarname);
      end;
  end;
end;

//取本机的计算机名
{ ComputerName }
function ComputerName: string;
var
    FStr: PChar;
    FSize: Cardinal;
begin
    FSize := 255;
    GetMem(FStr, FSize);
    Windows.GetComputerName(FStr, FSize);
    Result := FStr;
    FreeMem(FStr);
end;


//取Windows登录用户名
{ WinUserName }
function WinUserName: string;
var
    FStr: PChar;
    FSize: Cardinal;
begin
    FSize := 255;
    GetMem(FStr, FSize);
    GetUserName(FStr, FSize);
    Result := FStr;
    FreeMem(FStr);
end;

function GetCurrentScheme(name,temp:String;index:Integer=-1):boolean;
var ini: TIniFile;    
s,name1:String;
i,J:Integer;
begin
  result := true;
  iniFileName := path + iniFileName1;
  ini:=TIniFile.Create(iniFileName);
  name1:='';
  if temp<>'temp' then
  begin
    if index > -1 then
      name1 := 'SCHEME'+IntToStr(index + 1)
    else begin
      J:=Strtoint(ini.ReadString('MAIN','COUNT','0'));
      for I := 1 to J do
      begin
          S:=ini.ReadString('SCHEME'+IntToStr(I),'NAME','');
          if S=name then
          begin
              name1:='SCHEME'+IntToStr(I);
              break;
          end;
      end;
    end;
  end else
      name1:='TEMP';
  MaxExitCode := ini.ReadInteger('MAIN','MaxExitCode',3);
  //增加读取Ftp服务器是否支持UTF8
  FtpIsUtf8 := ini.ReadInteger('MAIN','FtpIsUtf8',1);
  //增加判断方案是否存在
  if not ini.SectionExists(name1) then
  begin
    result := false;
    ini.Destroy;
    exit;
  end;
  for i := 0 to length(SCHEME_VALUES)-1  do
  begin
      Current_Scheme_Values[i]:=ini.ReadString(name1,SCHEME_VALUES[i],'');
  end;
  ini.Destroy;
  Current_Scheme_Values[0]:=name;
  Current_Scheme_Values[1]:=name;

  If Current_Scheme_Values[3]='' Then
      Current_Scheme_Values[3]:=FormatDateTime('YYYY-MM-DD',date);
  If Current_Scheme_Values[4]='' Then
      Current_Scheme_Values[4]:='0';
  If Current_Scheme_Values[2]='' Then
      Current_Scheme_Values[2]:='00:00:00';
  If Current_Scheme_Values[9]='' Then
      Current_Scheme_Values[9]:='1';
  If Current_Scheme_Values[10]='' Then
      Current_Scheme_Values[10]:='0';
  If Current_Scheme_Values[11]='' Then
      Current_Scheme_Values[11]:='1';

  If Current_Scheme_Values[16]='' Then
      Current_Scheme_Values[16]:='1';
  If Current_Scheme_Values[17]='' Then
      Current_Scheme_Values[17]:='1';
  If Current_Scheme_Values[20]='' Then
      Current_Scheme_Values[20]:='1';
  If Current_Scheme_Values[21]='' Then
      Current_Scheme_Values[21]:='0';
  If Current_Scheme_Values[22]='' Then
      Current_Scheme_Values[22]:='databack';
  //增加设置数据库类型和增量类型的缺省值
  If Current_Scheme_Values[29]='' Then
      Current_Scheme_Values[29]:='0';
  If Current_Scheme_Values[30]='' Then
      Current_Scheme_Values[30]:='0';
  //增加数据库类型变量赋值
  Curr_DB_Type := StrToIntDef(Current_Scheme_Values[29],0) mod length(Database_Types);
  Curr_DBFile_Ext := DEFAULT_FILE_EXT[Curr_DB_Type];
  //增加处理用户名为空,取系统用户的情况
  if (Current_Scheme_Values[5]='') or (Current_Scheme_Values[5]='NULL') then
  begin
    Current_Scheme_Values[5] := WinUserName;
    IsWindowsUser := true;
  end;
  FtpIsUtf8 := StrToIntDef(Current_Scheme_Values[31],0); //缺省不进行 utf8 转换
  FtpIsUTC := StrToIntDef(Current_Scheme_Values[32],1);  //缺省进行 时区 转换
end;

procedure run(da,sc,temp:String);
var
  SCH:String;
  SysFrset: TFormatSettings;
begin

  SysFrset.ShortDateFormat:='yyyy-mm-dd';
  SysFrset.DateSeparator:='-';
  TheDate := StrToDate(da,SysFrset);
  SCH:=sc;
  if SCH='NULL' then
      SCH:='缺省';
  //方案不存在则不执行 GetCurrentScheme(SCH,temp);
  if GetCurrentScheme(SCH,temp) then
  begin
  FTPBackFile;
  DelOldFile;
  end;
end;

function RunProcess(dir,FileName,param: string; ShowCmd: Integer; wait: Boolean; ProcID:  PDWORD): Longword;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  p:PAnsiChar;
BEGIN
  FillChar(StartupInfo, SizeOf(StartupInfo), #0);
  StartupInfo.cb := SizeOf(StartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
  //用这种方式,不管传入的是 SW_NORMAL,还是 SW_SHOW,都不显示 exp.exe 的窗口,这样也只有 SW_SHOW 显示
  StartupInfo.wShowWindow := ShowCmd;
  p := PAnsiChar(FileName + ' ' + param);
  if not CreateProcess(nil,p,nil,nil,False,CREATE_NEW_CONSOLE OR NORMAL_PRIORITY_CLASS,nil,@dir[1],StartupInfo,ProcessInfo) THEN
  begin
    Result := WAIT_FAILED;

    SaveErrorLog('运行进程:'+FileName+','+dir+#13#10+SysErrorMessage(GetLastError));
  end else  BEGIN
    if wait = FALSE then
    begin
      if ProcID <> nil then
        ProcID^ := ProcessInfo.dwProcessId;
      result := WAIT_FAILED;
      exit;
    end;
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    GetExitCodeProcess(ProcessInfo.hProcess, Result);
  end;
  if ProcessInfo.hProcess <> 0 then
    CloseHandle(ProcessInfo.hProcess);  
  if ProcessInfo.hThread <> 0 then
    CloseHandle(ProcessInfo.hThread);
end;

function RunAndProcess(dir,cmd,param:String;isShow:Integer): Longword;
  //执行导出功能
var
  ShExecInfo:SHELLEXECUTEINFO;
begin

  ShExecInfo.cbSize := sizeof(SHELLEXECUTEINFO);
  ShExecInfo.fMask := SEE_MASK_NOCLOSEPROCESS;
  ShExecInfo.Wnd := 0;
  ShExecInfo.lpVerb := nil;
  ShExecInfo.lpFile :=  pchar(dir+cmd);
  ShExecInfo.lpParameters := pchar(param);
  ShExecInfo.lpDirectory := pchar(dir);

    ShExecInfo.nShow := isShow;
  ShExecInfo.hInstApp := 0;
  try
    if not ShellExecuteEx(@ShExecInfo) then
    begin
      SaveErrorLog('运行进程:'+dir+cmd+#13#10+SysErrorMessage(GetLastError));
      exit;
    end;
    WaitForSingleObject(ShExecInfo.hProcess, INFINITE);
  finally
    GetExitCodeProcess(ShExecInfo.hProcess, Result);
    if ShExecInfo.hProcess <> 0 then
      CloseHandle(ShExecInfo.hProcess);
    //if ShExecInfo.hThread <> 0 then
    //  CloseHandle(ShExecInfo.hThread);
  end;

end;

procedure CompressFiles(SourceFiles:String;var TargetFile:String;Willcards:String='*.*';CompressLevel:Integer=4;
           CompressMode:Integer=1;CompressType:Integer=8;Password:String='';path:String='';IsSFX:Integer=0
           ;IsAppend: Boolean=false  
           );
  type TCompressFiles = function(SourceFiles:pchar;var TargetFile:pchar;Willcards:pchar;CompressLevel:Integer;
           CompressMode:Integer;CompressType:Integer;Password:pchar;path:pchar;IsSFX:Integer
           ;IsAppend: Boolean=false  
           ):boolean; stdcall;
var
  LibHandle: THandle;
  P_device:TCompressFiles;
  p:pchar;
begin
  LibHandle := LoadLibrary('servdata.dll');
  try
    if LibHandle <=32 then raise EDLLLoadError.Create('调用 servdata.dll 失败！')
    else  begin
      @P_device := GetProcAddress(LibHandle, 'CompressFiles');
      if not (@P_device = nil) then
      begin
        try
          p := pchar(TargetFile);
          P_device(pchar(SourceFiles),p,pchar(Willcards),CompressLevel,CompressMode,CompressType,pchar(Password),pchar(path),IsSFX,IsAppend);
          TargetFile := trim(String(p));
        except on e:Exception do
          SaveErrorLog('压缩错误:'+e.Message);
        end;
      end;
    end;
  finally
    FreeLibrary(LibHandle);
  end;
end;

procedure Compress(exitcode:Integer;filename,arcdir,username,nozippass,dir:String;show:Integer;ProcID: Cardinal);
  //提取为单独的过程,统一处理文件压缩
var
  param:String;
begin
  if nozippass <> '' then
    nozippass := '-p'+nozippass;
    if (exitcode <= MaxExitCode)  then
    begin
      if FileExists(filename + Curr_DBFile_Ext) then
      begin

        param := 'a -r -mx=9 -t7z -mhe ' + nozippass + ' ' + arcdir + '\' + username + '\' + filename + Curr_ZipFile_Ext +' ' + filename + Curr_DBFile_Ext;
        RunProcess(dir + username,path + '7z',param,show,true,@ProcID);
      end;
      if FileExists('log\EXP_' + filename + '.log') then
      begin

        param := 'u -r -mx=9 -t7z ' + arcdir + '\' + username + '\' + username +'_log' + Curr_ZipFile_Ext + ' log\EXP_' + filename +'.log';
        RunProcess(dir + username,path + '7z',param,show,true,@ProcID);
        DeleteFile(dir + username+'\log\EXP_' + filename +'.log') ;
      end;
     end;
end;

function checkDir(dir,username,arcdir:String):String;
  //增加,将目录检查和建立提取为函数
begin
    //建立目录
    //导出目录增加一级 expdata
    if not DirectoryExists(dir + 'expdata') then
      MkDir(dir + 'expdata');
    dir := dir + 'expdata\';
    result := dir;
    if not DirectoryExists(dir + username) then
      MkDir(dir + username);
    SetCurrentDir(dir + username);
    if not DirectoryExists(dir + username + '\log') then
      MkDir(dir + username + '\log');
    if not DirectoryExists(arcdir +'\' + username) then
      //改为创建多级目录,避免 arcdir 不存在时的错误
      ForceDirectories(arcdir +'\' + username);
end;

function runBackSql(dir:String;show:Integer;ss:TStrings):Longword;
  //执行 SQL Server 数据库备份
var
  username,expproc,server,arcdir,rardir,date,parfile,istemp,nozippass,pass,db,inctype:String;
  count:Integer;
  filename:String;
  param:String;
  ProcID: Cardinal;
  exitcode:Longword;
  isContinue:boolean;
begin
  count := -1;
  if ss <> nil then
    count := ss.Count;
  if count > 0 then
    username := ss.Strings[0];
  if count > 1 then
    expproc := ss.Strings[1];
  if count > 2 then
    server := ss.Strings[2];
  if count > 3 then
    arcdir := ss.Strings[3];
  if count > 4 then
    rardir := ss.Strings[4];
  if count > 5 then
    date := ss.Strings[5];
  if count > 6 then
    parfile := ss.Strings[6];
  if count > 7 then
    istemp := ss.Strings[7];
  if count > 8 then
    nozippass := ss.Strings[8];
  if count > 9 then
    isContinue := ss.Strings[9] = '1'
  else isContinue := false;

  pass := decode_string(Current_Scheme_Values[6]);
  server := Current_Scheme_Values[7];
  db := Current_Scheme_Values[25];
  inctype := Current_Scheme_Values[30];
  if inctype = '1' then
    inctype := 'Differential'
  else
    inctype := 'INIT';
  SetCurrentDir(dir);
  try
    //设置环境
    expproc := 'sqlcmd.exe';
    if Current_Scheme_Values[24] <> '' then
      expproc := Current_Scheme_Values[24] + '\sqlcmd.exe';

    if nozippass <> 'NULL' then
      nozippass := nozippass 
    else
      nozippass := '';
    //文件名
    filename := username + '_' + date;
    if parfile <> 'NULL' then
      filename := filename + '_'+ parfile;

    //建立目录
    dir := checkDir(dir,username,arcdir);

    ProcID := 0;
    if (server = '') or (server = 'NULL') then
      server:= '.';
    //增加处理windows 用户登录的情况
    if isWindowsUser then
      param := ' -S ' + server + ' -Q "Backup Database '+db+' to disk='''+dir + username +'\'+filename + Curr_DBFile_Ext +''' WITH '+inctype +'" ' // -0 .\log\EXP_' + filename+'.log';
    else
    param := '-U '+username + ' -S ' + server + ' -P ' + pass + ' -Q "Backup Database '+db+' to disk='''+dir + username +'\'+filename + Curr_DBFile_Ext +''' WITH '+inctype +'" ';// -0 .\log\EXP_' + filename+'.log';
    exitcode := RunProcess(dir + username,expproc,param,show,true,@ProcID);

    SaveErrorLog('执行'+Database_Types[Curr_DB_Type]+'导出信息,退出码:'+IntToStr(exitcode),1);
    if isContinue then
      exitcode := 1;

     Compress(exitcode,filename,arcdir,username,nozippass,dir,show,ProcID);
    SetCurrentDir(dir);
  finally
  end;
  result := exitcode;
end;

function runBackMySql(dir:String;show:Integer;ss:TStrings):Longword;
  //执行 MySQL 数据库备份
var
  username,expproc,server,arcdir,rardir,date,parfile,istemp,nozippass,pass,db,inctype:String;
  count:Integer;
  filename:String;
  param:String;
  ProcID: Cardinal;
  exitcode:Longword;
  isContinue:boolean;
begin
  count := -1;
  if ss <> nil then
    count := ss.Count;
  if count > 0 then
    username := ss.Strings[0];
  if count > 1 then
    expproc := ss.Strings[1];
  if count > 2 then
    server := ss.Strings[2];
  if count > 3 then
    arcdir := ss.Strings[3];
  if count > 4 then
    rardir := ss.Strings[4];
  if count > 5 then
    date := ss.Strings[5];
  if count > 6 then
    parfile := ss.Strings[6];
  if count > 7 then
    istemp := ss.Strings[7];
  if count > 8 then
    nozippass := ss.Strings[8];
  if count > 9 then
    isContinue := ss.Strings[9] = '1'
  else isContinue := false;
  pass := decode_string(Current_Scheme_Values[6]);
  server := Current_Scheme_Values[7];
  db := Current_Scheme_Values[25];
  inctype := Current_Scheme_Values[30];
  if inctype = '1' then
    inctype := 'Differential'
  else
    inctype := 'INIT';
  SetCurrentDir(dir);
  try
    //设置环境
    expproc := 'mysqldump.exe';
    if Current_Scheme_Values[24] <> '' then
      expproc := Current_Scheme_Values[24] + '\'+expproc;

    if nozippass <> 'NULL' then
      nozippass := nozippass 
    else
      nozippass := '';
    //文件名
    filename := username + '_' + date;
    if parfile <> 'NULL' then
      filename := filename + '_'+ parfile;

    //建立目录
    dir := checkDir(dir,username,arcdir);
    ProcID := 0;
    if (server = '') or (server = 'NULL') then
      server:= '.';
    if pos(':',server) > 0 then
      server := StringReplace(server,':',' -P',[]);
    param := '-u'+username + ' -h' + server + ' -p' + pass + ' --databases '+db+' -r'+dir + username +'\'+filename + Curr_DBFile_Ext;// -0 .\log\EXP_' + filename+'.log';
    exitcode := RunProcess(dir + username,expproc,param,show,true,@ProcID);
    SaveErrorLog('执行'+Database_Types[Curr_DB_Type]+'导出信息,退出码:'+IntToStr(exitcode),1);
    if isContinue then
      exitcode := 1;

     Compress(exitcode,filename,arcdir,username,nozippass,dir,show,ProcID);
    SetCurrentDir(dir);
  finally
  end;
  result := exitcode;
end;

function runBack(dir:String;show:Integer;ss:TStrings):Longword;
  //替换 expback.bat文件

var
  username,expproc,server,arcdir,rardir,date,parfile,istemp,nozippass:String;
  count:Integer;
  ora_home,tns:String;
  home,path2,filename:String;
  param:String;
  ProcID: Cardinal;
  exitcode:Longword;
  isContinue:boolean;
  path_:String; 
begin
  count := -1;
  if ss <> nil then
    count := ss.Count;
  if count > 0 then
    username := ss.Strings[0];
  if count > 1 then
    expproc := ss.Strings[1];
  if count > 2 then
    server := ss.Strings[2];
  if count > 3 then
    arcdir := ss.Strings[3];
  if count > 4 then
    rardir := ss.Strings[4];
  if count > 5 then
    date := ss.Strings[5];
  if count > 6 then
    parfile := ss.Strings[6];
  if count > 7 then
    istemp := ss.Strings[7];
  if count > 8 then
    nozippass := ss.Strings[8];

  if count > 9 then
    isContinue := ss.Strings[9] = '1'
  else isContinue := false;
  ora_home := GetEnvironmentVariable('ORACLE_HOME');
  path_ := GetEnvironmentVariable('PATH');
  tns := GetEnvironmentVariable('TNS_ADMIN');
  SetCurrentDir(dir);
  try
    //设置环境
    SetEnvironmentVariable('NLS_LANG','SIMPLIFIED CHINESE_CHINA.ZHS16GBK');
    home := ora_home;
    if expproc <> 'NULL' then
      home := expproc;
    path2 := home;

    expproc := 'exp.exe';
    if FileExists(path2 + '\oci.dll') then  //简易客户端模式
    begin
      if (not FileExists(path2 + '\' + expproc)) or (not FileExists(path2 + '\exp80.exe')) then
        path2 := path2 + '\bin';
    end else begin  //正常客户端模式
      path2 := path2 + '\bin';
    end;
    SetEnvironmentVariable('PATH',PAnsiChar(path2+';'+path_));
    if FileExists(path2 + '\exp80.exe') then
      expproc := path2 + '\exp80.exe'
    else
      expproc := path2 + '\' + expproc;
    if home <> path2 then
      SetEnvironmentVariable('TNS_ADMIN',PAnsiChar(home +'\network\ADMIN'))
    else if FileExists(home + '\tnsnames.ora') then
      SetEnvironmentVariable('TNS_ADMIN',PAnsiChar(home))
    else
      SetEnvironmentVariable('TNS_ADMIN',PAnsiChar(home +'\network\ADMIN'));
    if nozippass <> 'NULL' then
      nozippass := nozippass 
    else
      nozippass := '';
    //文件名
    filename := username + '_' + date;
    if parfile <> 'NULL' then
      filename := filename + '_'+ parfile
    else IF FileExists(dir + 'par\default.par') then
      parfile := 'default';
    if istemp = 'temp' then
      parfile := 'temp';

    //建立目录
    dir := checkDir(dir,username,arcdir);

    ProcID := 0;
    if parfile = '' then
    begin
      param := username + '/' + server + ' FULL=Y file=' + filename +'.dmp log=.\log\EXP_' + filename+'.log';
      exitcode := RunProcess(dir + username,expproc,param,show,true,@ProcID);
    end else begin
      param := username + '/' + server + ' parfile=..\..\par\' + parfile + '.par file=' + filename +'.dmp log=.\log\EXP_'+ filename+'.log';
      exitcode := RunProcess(dir + username,expproc,param,show,true,@ProcID);
    end;
    SaveErrorLog('执行'+Database_Types[Curr_DB_Type]+'导出信息,退出码:'+IntToStr(exitcode),1);
    if isContinue then
      exitcode := 1;

     Compress(exitcode,filename,arcdir,username,nozippass,dir,show,ProcID);
    SetCurrentDir(dir);
  finally
    SetEnvironmentVariable('ORACLE_HOME',PAnsiChar(ora_home));
    SetEnvironmentVariable('PATH',PAnsiChar(path_));
    SetEnvironmentVariable('TNS_ADMIN',PAnsiChar(tns));
  end;
  result := exitcode;
end;

procedure call(cmd,param,isShow:String);
  //执行导出功能
var
  s,dir:String;
  ss:TStrings;
  show:Integer;
  exitcode:Longword;
begin
  s := param;
  dir := path;
  if isShow = '1' then
    show := SW_NORMAL
  else
    show := SW_HIDE;
  ss := TStringlist.Create;
  try
    ss.Delimiter := ' ';
    ss.DelimitedText := s;

    //2020-09-05 增加 SQL Server 数据库的备份
    If Curr_DB_Type = 1 Then
      exitcode := runBackSql(dir,show,ss)
    else If Curr_DB_Type = 2 Then //2020-09-06 增加 MySQL
      exitcode := runBackMySql(dir,show,ss)
    else
    exitcode := runBack(dir,show,ss);
    if (exitcode <= MaxExitCode) or ((ss.Count > 9) and (ss.Strings[9] = '1')) then
      run(ss.Strings[5],ss.Strings[6],ss.Strings[7]);
  finally
    ss.Destroy;
  end;
end;

procedure SetOracleEnv(Ora_dir:String;IsOCI:boolean=true;dbtype:Integer=0);

const    DLLFILENAME='servdata.dll';
var
  LibHandle: THandle;
  P_device:TSetOracleEnv;
begin
  LibHandle := LoadLibrary(dllfilename);
  try
    if LibHandle <=32 then raise EDLLLoadError.Create('调用 '+dllfilename+' 失败！')
    else  begin
      @P_device := GetProcAddress(LibHandle, 'SetOracleEnv');
      if not (@P_device = nil) then
      begin
        try
         P_device(pchar(Ora_dir),IsOCI,dbtype);
        except
        end;
      end;
    end;
  finally
    FreeLibrary(LibHandle);
  end;
end;

function nvl(s:String;def:String=' '):String;
begin
   result:=s;
   if (s='') or (trim(s)='') then
       result:=def;
end;

function CheckLastDir(dir:String):String;
var
  l:Integer;
begin
  l := length(dir);
  result := dir;
  if l = 0 then exit; 
  if result[l] = '\' then
    result := copy(result,1,l - 1);
end;

function getParam(da,rar,temp:String):String;

var
  param:String;
begin
    SetOracleEnv(Current_Scheme_Values[24],pos(':',Current_Scheme_Values[25])<0,Curr_DB_Type);

    param:='';

        param:=nvl(Current_Scheme_Values[5],'NULL')+' "'+nvl(CheckLastDir(Current_Scheme_Values[24]),'NULL')+'" '+nvl(decode_string(Current_Scheme_Values[6]),'NULL')
           +'@'+nvl(Current_Scheme_Values[7],'NULL')+' '+nvl(Current_Scheme_Values[8],'NULL')+' ';
        if Current_Scheme_Values[9]='1' then
            param:= param+rar
        else
            param:= param+'NULL';
        param:= param+' '+da+' ';
        If Current_Scheme_Values[1]<>'缺省' Then //  Then
          param:= param+Current_Scheme_Values[1]
        else
          param:= param+'NULL';

        param:= param+' '+nvl(temp,'NULL');
        if trim(Current_Scheme_Values[23]) <> '' then
            param:= param+' '+decode_string(Current_Scheme_Values[23])
        else
            param:= param+' NULL';
        //2019-11-07 增加中断是否继续压缩
        if trim(Current_Scheme_Values[28]) = '1' then
            param:= param+' 1'
        else
            param:= param+' 0';
    Result:=param;
end;

procedure GetCurrentPlan(index:Integer);
  //2019-11-09 增加
var ini: TIniFile;
name1:String;
i:Integer;
begin
  iniFileName := path + iniFileName1;
  ini:=TIniFile.Create(iniFileName);
  if index >= 0 then
  begin
    name1:='PLAN'+IntToStr(index + 1);
  end else
    name1:='PLANTEMP';
  for i := 0 to length(PLAN_VALUES)-1  do
  begin
      Current_Plan_Values[i]:=ini.ReadString(name1,PLAN_VALUES[i],'');
  end;
  ini.Destroy;
end;

procedure RemoveDeadIcons2;
    //2017-08-21 Delphi刷新托盘，去掉非正常退出的程序的托盘图标 .
var
  wnd : cardinal;
  rec : TRect;
  w,h : integer;
  x,y : integer;
begin
  // find a handle of a tray
  wnd := FindWindow('Shell_TrayWnd', nil);
  wnd := FindWindowEx(wnd, 0, 'TrayNotifyWnd', nil);
  wnd := FindWindowEx(wnd, 0, 'SysPager', nil);
  wnd := FindWindowEx(wnd, 0, 'ToolbarWindow32', nil);
  // get client rectangle (needed for width and height of tray)
  windows.GetClientRect(wnd, rec);
  // get size of small icons
  w := GetSystemMetrics(sm_cxsmicon);
  h := GetSystemMetrics(sm_cysmicon);
  // initial y position of mouse - half of height of icon
  y := w shr 1;
  while y < rec.Bottom do
  begin // while y < height of tray
    x := h shr 1; // initial x position of mouse - half of width of icon
    while x < rec.Right do
    begin // while x < width of tray
      SendMessage(wnd, wm_mousemove, 0, y shl 16 or x); // simulate moving mouse over an icon
      x := x + w; // add width of icon to x position
    end;
    y := y + h; // add height of icon to y position
  end;
end;

procedure callPlan(cmd,param,isShow:String);
  //2019-11-09 执行计划任务
var
  s:String; 
  ss,ss1:TStrings;
  i:Integer;
  groupnum,groupindex,rar,name,da,temp:String;
begin
  s := param;
  path := ExtractFilePath(ParamStr(0));
  ss := TStringlist.Create;
  ss1 := TStringlist.Create;
  try
    ss.Delimiter := ' ';
    ss.DelimitedText := s;
    if ss.Count > 5 then  //原来的参数方式,直接调用备份方案
      call(cmd,param,isShow)
    else begin
      groupnum := ss.Strings[0];
      groupindex := ss.Strings[1];
      rar := ss.Strings[2];
      name := ss.Strings[3];
      da := ss.Strings[4];
      temp := '';
      if groupnum = '0' then
      begin  //新的方案调用方式  组号,组序号,rar目录,名称,服务器时间
        if groupindex = '-1' then
          temp := 'temp';
        //方案不存在则不执行备份
        if GetCurrentScheme(name,temp,StrToInt(groupindex)) then
          call('',getParam(da,rar,temp),isShow);
      end else begin //计划任务调用方式
        GetCurrentPlan(StrToInt(groupindex));
        ss.Delimiter := ',';
        ss.DelimitedText := Current_Plan_Values[7];
        ss1.Delimiter := ',';
        ss1.DelimitedText := Current_Plan_Values[8];
        for i := 0 to ss.Count - 1 do
        begin
          //方案不存在则不执行备份
          if GetCurrentScheme(ss1.Strings[i],temp,StrToInt(ss.Strings[i])) then
          begin
            s := getParam(da,rar,'');
            call('',s,isShow);
          end;
        end;
      end;
    end;
    //2019-11-09 清除任务栏无效图标
    RemoveDeadIcons2;
  finally
    ss.Destroy;
    ss1.Destroy;
  end;
end;

end.