master

分支 (1)

标签 (2)

管理

管理

master

v1.5.0.22

v1.6.0.25

oraback
/
Unit10.pas

unit Unit10;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Db,  shellapi, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdFTP, SevenZipVCL;

type
  TDM_Main11 = class(TForm)
    SevenZip1: TSevenZip;
    NMFTP1: TIdFTP;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure setDatabaseParam(u, p, s: String);
    procedure QueryClose(dataset: TDataset);
    procedure FreeDadaBaseMem;
    //2020-09-09 增加压缩与ftp测试
    procedure DoCompressFiles(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=true
           );
    function TestFTP(ftp_host, ftp_user, ftp_pass: String;
      ftp_port: Integer; passive: boolean=false): String;
  public
    { Public declarations }
    function GetADOConnectString(user, pass, serv: String): String;
  end;

var
  DM_Main11: TDM_Main11;
  //2015-06-25 除RunBack全部函数都增加ORACLE环境参数
  //2021-12-28 所有后台数据库调用函数,都增加数据库类型参数,以便将来扩充功能 ;dbtype:Integer=0:
  function GetStringsList(user,pass,serv,sqlstr:pchar;var l:TStrings;dir:pchar;dbtype:Integer=0):boolean ;stdcall;//  List
  function StartMulSelect(user,pass,serv,sqlstr:pchar;var inSelectValues,selectItem:TStrings;dir:pchar; isOnlyOne:Boolean=false;dbtype:Integer=0):boolean;stdcall;
  function TestConnect(user,pass,serv:pchar;dir:pchar;dbtype:Integer=0):boolean;stdcall;
  function RunBack(CMDLine,param:pchar;isShow:Boolean=false):boolean; stdcall;
  function GetStringsListEx(user,pass,serv,sqlstr:pchar;var l:pchar;dir:pchar;dbtype:Integer=0):boolean ;stdcall;//  List
  function StartMulSelectEx(user,pass,serv,sqlstr:pchar;var inSelectValues,selectItem:pchar;dir:pchar; isOnlyOne:Boolean=false;dbtype:Integer=0):boolean;stdcall;
  //2015-06-25 增加设置ORACLE环境参数
  function SetOracleEnv(dir:pchar;IsOCI:Boolean=true;dbtype:Integer=0):boolean;stdcall;
    //2020-09-09 7z压缩功能
  function CompressFiles(SourceFiles:pchar;var TargetFile:pchar;Willcards:pchar;CompressLevel:Integer;
           CompressMode:Integer;CompressType:Integer;Password:pchar;path:pchar;IsSFX:Integer=0
           ;IsAppend: Boolean=true
           ):boolean; stdcall;
   function TestFTP(ftp_host, ftp_user, ftp_pass: pchar; ftp_port: Integer;passive:boolean=false):pchar; stdcall;


implementation

uses mulselect, U_servmod, StrUtils;

{$R *.DFM}

procedure SaveErrorLog(msg:String;flag:Integer=0;dbtype:Integer=0);
  //2021-12-29 从 deloldfile.exe 移植,并将所有函数和过程的错误信息都增加日志记录,增加数据库类型
const
  logname:array[0..1,0..1] of String = (('expback_error.log','expback_exp.log'),('错误','信息'));
var
  s,n:String;
  hLogFile:TextFile;
  info:String;
    path:String;
begin
  try
    flag := flag mod 2;
    n := logname[0,flag];
    info := ',' + logname[1,flag] + ':';
    path := ExtractFilePath(ParamStr(0));
    n:=path+'log\'+n;
    try
      AssignFile(hLogFile, n);
      If FileExists(n) Then
        Append(hLogFile)
      Else
        Rewrite(hLogFile);
      s := '';
      if dbtype > -1 then
        s := ',当前数据库:'+Database_Types[1,dbtype];
      s := FormatDateTime('yyyy-MM-dd HH:mm:ss ZZZ',now) + s + info +msg;
      Writeln(hLogFile,s);
    finally
      CloseFile(hLogFile);
    end;
  except
  end;
end;

function SetOracleEnv1(dir:pchar):String;
var
  Ora_dir,s1,s2,s3:String;
begin
   Result:=GetCurrentDir;
   if dir = '' then exit;
 try
  Ora_dir := trim(String(dir));
  if Ora_dir = '' then exit;
  if RightStr(Ora_dir,1) = '\' then
    delete(Ora_dir,length(Ora_dir),1);
  s3 := Database_Types[2,dbtype];
  if FileExists(Ora_dir+'\'+s3) then

  begin
    s2 := Ora_dir;
  end else begin
    s2 := Ora_dir+'\BIN';
  end;
  case dbtype of
    0:begin  //oracle
      SetEnvironmentVariable('ORACLE_HOME',pchar(Ora_dir));
      if FileExists(Ora_dir+'\tnsnames.ora') then
      begin
        s1 := Ora_dir;
        //s1 := Ora_dir + 'NETWORK\ADMIN';
      end else begin
        s1 := Ora_dir + 'NETWORK\ADMIN';
      end;
      SetEnvironmentVariable('TNS_ADMIN',pchar(s1));
    end;
    1:begin  //sql server
    end;
    2:begin  //mysql
    end;
  end;
    SetEnvironmentVariable('PATH',pchar(s2+';%PATH%'));


    except on e:Exception do //ShowMessage(e.Message);
      //2021-12-29 增加错误日志记录
      SaveErrorLog('SetOracleEnv,'+e.Message,0,dbtype);
    end;
end;

function GetStringsList(user,pass,serv,sqlstr:pchar;var l:TStrings;dir:pchar;dbtype:Integer=0):boolean ;stdcall;// List
var
s:String;
begin
Result:=true;

DM_Main:=TDM_Main.Create(Application);
try
try
   SetOracleEnv1(dir,dbtype);
    DM_Main.setDatabaseParam(user,pass,serv,dbtype);
    DM_Main.Query1.SQL.Text:= sqlstr;
    DM_Main.Query1.Open;
    while Not DM_Main.Query1.Eof do
    begin
        s:=DM_Main.Query1.fields[0].AsString;
        l.Add(s);
        DM_Main.Query1.Next;
    end;
finally
  DM_Main.FreeDadaBaseMem;
  DM_Main.free;
end;
except on e:Exception do //ShowMessage(e.Message);
      //xxy 2021-12-29 增加错误日志记录
      SaveErrorLog('GetStringsList,'+e.Message,0,dbtype);
end;
end;

function StartMulSelect(user,pass,serv,sqlstr:pchar;var inSelectValues,selectItem:TStrings;dir:pchar; isOnlyOne:Boolean=false;dbtype:Integer=0):boolean;stdcall;
begin
   Result:=true;
DM_Main:=TDM_Main.Create(Application);
try
try
   SetOracleEnv1(dir,dbtype);
    DM_Main.setDatabaseParam(user,pass,serv,dbtype);

   DM_Main.Query1.Close;
   DM_Main.Query1.SQL.Text:=sqlstr;
   DM_Main.Query1.Open;
   selectItem:=MulSelectForm.StartSelect(DM_Main.Query1,inSelectValues,isOnlyOne);
finally
  DM_Main.FreeDadaBaseMem;
  DM_Main.free;
end;
except on e:Exception do //ShowMessage(e.Message);
      //xxy 2021-12-29 增加错误日志记录
      SaveErrorLog('StartMulSelect,'+e.Message,0,dbtype);

end;
end;

function GetStringsListEx(user,pass,serv,sqlstr:pchar;var l:pchar;dir:pchar;dbtype:Integer=0):boolean ;stdcall;// List
var
s,s1:String;
begin
Result:=true;
s1 := '';
DM_Main:=TDM_Main.Create(Application);
try
try
   SetOracleEnv1(dir,dbtype);
    DM_Main.setDatabaseParam(user,pass,serv,dbtype);
    DM_Main.Query1.SQL.Text:= sqlstr;
    DM_Main.Query1.Open;
    while Not DM_Main.Query1.Eof do
    begin
        s:=DM_Main.Query1.fields[0].AsString;
        S1 := S1 + s+ #13#10;
        DM_Main.Query1.Next;
    end;
finally
  DM_Main.FreeDadaBaseMem;
  DM_Main.free;
end;
except on e:Exception do //ShowMessage(e.Message);
      //xxy 2021-12-29 增加错误日志记录
      SaveErrorLog('GetStringsListEx,'+e.Message,0,dbtype);

end;
  l := strnew(Pchar(s1));
end;

function StartMulSelectEx(user,pass,serv,sqlstr:pchar;var inSelectValues,selectItem:pchar;dir:pchar; isOnlyOne:Boolean=false;dbtype:Integer=0):boolean;stdcall;
var
s,s1:String;
begin
   Result:=true;
DM_Main:=TDM_Main.Create(Application);
try
try
   SetOracleEnv1(dir,dbtype);
    DM_Main.setDatabaseParam(user,pass,serv,dbtype);
   DM_Main.Query1.Close;
   DM_Main.Query1.SQL.Text:=sqlstr;
   DM_Main.Query1.Open;
   s1 := String(inSelectValues);
   s := MulSelectForm.StartSelect(DM_Main.Query1,s1,isOnlyOne);
   selectItem:= strnew(Pchar(s));
   inSelectValues:= strnew(Pchar(s1));
finally
  DM_Main.FreeDadaBaseMem;
  DM_Main.free;
end;
except on e:Exception do //ShowMessage(e.Message);
      //xxy 2021-12-29 增加错误日志记录
      SaveErrorLog('StartMulSelectEx,'+e.Message,0,dbtype);

end;
end;

function TestConnect(user,pass,serv:pchar;dir:pchar;dbtype:Integer=0):boolean;stdcall;
var
  c_dir:String;
begin
   Result:=false;
DM_Main:=TDM_Main.Create(Application);
try
 try
   c_dir := SetOracleEnv1(dir,dbtype);
    DM_Main.Database1.Connected:=false;
    DM_Main.setDatabaseParam(user,pass,serv,dbtype);
    DM_Main.Database1.Connected:=true;
    Result:=DM_Main.Database1.Connected;
    except on e:Exception do //ShowMessage(e.Message);
      //xxy 2021-12-29 增加错误日志记录
      SaveErrorLog('TestConnect,'+e.Message,0,dbtype);

    end;
finally
  DM_Main.FreeDadaBaseMem;
  DM_Main.free;
end;
end;

function RunBack(CMDLine,param:pchar;isShow:Boolean=false):boolean; stdcall;
begin
Result:=true;
if isShow then
    ShellExecute(Application.Handle, 'open',CMDLine,param, nil, SW_NORMAL)
else
    ShellExecute(Application.Handle, 'open',CMDLine,param, nil, SW_HIDE);
end;


{ TDM_Main }

procedure TDM_Main11.setDatabaseParam(u, p, s: String);
begin

end;

procedure TDM_Main11.QueryClose(dataset: TDataset);
begin
    if not dataset.Active then exit;
    try
      dataset.Close;
    except end;
end;

function TDM_Main11.GetADOConnectString(user,pass,serv:String):String;
begin
  Result:='Provider=MSDAORA.1;Persist Security Info=True;'
         +'User ID='+user+';Password='+pass+';Data Source='+serv;
end;

procedure TDM_Main11.FormClose(Sender: TObject; var Action: TCloseAction);
begin
end;

procedure TDM_Main11.FreeDadaBaseMem;
begin
  try
  except end;
  Destroy;
end;

procedure TDM_Main11.FormCreate(Sender: TObject);
begin
DM_Main11:=self;
end;

function SetOracleEnv(dir:pchar;IsOCI:Boolean=true;dbtype:Integer=0):boolean;stdcall;
var
  Ora_dir,s1,s2:String;
begin
  Result:=true;
  if IsOCI then
    SetEnvironmentVariable('IsUseOCI','1')
  else
    SetEnvironmentVariable('IsUseOCI','0');
  SetOracleEnv1(dir,dbtype);
end;

function CompressFiles(SourceFiles:pchar;var TargetFile:pchar;Willcards:pchar;CompressLevel:Integer;
           CompressMode:Integer;CompressType:Integer;Password:pchar;path:pchar;IsSFX:Integer=0
           ;IsAppend: Boolean=true
           ):boolean; stdcall;
var
  s:String;
begin
  Result:=true;
  s := String(TargetFile);
  DM_Main11 := TDM_Main11.Create(Application);
  DM_Main11.DoCompressFiles(String(SourceFiles),s,String(Willcards),CompressLevel,CompressMode,CompressType,Password,path,IsSFX,IsAppend);
  TargetFile := pchar(s + ' ');
  DM_Main11.Release;
end;

procedure TDM_Main11.DoCompressFiles(SourceFiles:String;var TargetFile:String;Willcards:String='*.*';CompressLevel:Integer=4;
           CompressMode:Integer=1;CompressType:Integer=8;Password:String='';path:String='';IsSFX:Integer=0//xxy 2017-08-03 增加 path
           ;IsAppend: Boolean=true
           );
  function getDestName(s,d:String;m:Integer):String;
  begin
    if m = 1 then //解压
    begin
      if d = '' then
        d := ExtractFilePath(s);
    end else begin
      if d = '' then
      begin
        d := s;
      end;
        d := ChangeFileExt(d,'.7z');
    end;
    result := d;
  end;
procedure MyDelimiter(src:String;var dest:TStrings; aChar:Char=';';IsClear:boolean=false;IsLastaAddEmpty:boolean=false);
var
  i, s,  l: Integer;
begin
  s := 1;
  l := Length(src);
  if IsClear then
    dest.Clear;
  for i := 1 to l do
  begin
    if src[i] = aChar then
    begin
      dest.Add(Copy(src, s, i - s));
      s := i + 1;
    end;
  end;
  if s <= l then
    dest.Add(Copy(src, s, l - s + 1));
  if IsLastaAddEmpty and (src[l] = aChar) then
    dest.Add('');
end;

var
  src,dir:String;
  i,c:Integer;
  Files: TStringS;
  b:boolean;
begin

  Files := TStringList.Create;
  try
    b:= false;
  if not b  then
  begin
    SevenZip1.SFXCreate := IsSFX = 1;
    MyDelimiter(SourceFiles,Files,';',true);

    c := Files.Count;
    SevenZip1.Files.Clear;
    if  c > 1 then
    begin
      TargetFile := getDestName(Files[0],TargetFile,CompressType);
      for i := 0 to c - 1 do
      begin
        src := Files.Strings[i];
        if DirectoryExists(src) then
          sevenzip1.Files.AddString(src+'\*.*')
        else
          sevenzip1.Files.AddString(src);
      end;
    end else begin
      TargetFile := getDestName(SourceFiles,TargetFile,CompressType);
      if DirectoryExists(SourceFiles) then
      begin
        SevenZip1.Files.AddString(SourceFiles+'\*.*');
      end else
        SevenZip1.Files.AddString(SourceFiles);
    end;
    Sevenzip1.Password := Password;
    if path = '' then
      path := ExtractFileDir(TargetFile);
    dir := GetCurrentDir;
    sevenzip1.LZMACompressStrength := TCompressStrength(CompressLevel);
    sevenzip1.LZMACompressType := TCompresstype(CompressMode);
    if CompressType = 1 then //解压
    begin
      SetCurrentDir(TargetFile);
      sevenzip1.SZFileName := SourceFiles;
      sevenzip1.ExtractOptions := sevenzip1.ExtractOptions + [ExtractOverwrite];
      sevenzip1.ExtrBaseDir := TargetFile;
      sevenzip1.Files.clear;
      i := sevenzip1.Extract;
      if i < 0 then
        ShowMessage('解压错误:'+c7zipResMsg[sevenzip1.ErrCode])
      else if i > 0 then
        ShowMessage('解压错误,错误码:' + IntToStr(i)+'-'+SysErrorMessage(i));
    end else begin
      SetCurrentDir(path);
      if pos(':',TargetFile) > 0 then
        sevenzip1.SZFileName := TargetFile
      else
      sevenzip1.SZFileName := dir + '\' + TargetFile;
      sevenzip1.AddRootDir := path;
      sevenzip1.IsAppend := IsAppend;
      i := Sevenzip1.Add;
    end;
    SetCurrentDir(dir);
  end;
    Application.ProcessMessages;

  finally
    Files.Free;
  end;
end;

function TestFTP(ftp_host, ftp_user, ftp_pass: pchar; ftp_port: Integer;passive:boolean=false):pchar; stdcall;
  //2020-09-09 增加ftp测试功能
var
  s :String;
begin
  DM_Main11 := TDM_Main11.Create(Application);
  s := DM_Main11.TestFTP(String(ftp_host), String(ftp_user),String(ftp_pass),ftp_port,passive);

  result := pchar(s);
  DM_Main11.Release;
end;

function TDM_Main11.TestFTP(ftp_host, ftp_user, ftp_pass: String; ftp_port: Integer;passive:boolean=false):String;
  //2020-09-09 增加ftp测试功能
begin
  result := 'NO';
  if NMFTP1.Connected then
  begin
    NMFTP1.Disconnect
  end;
  if (ftp_user = '') then
    ftp_user := 'Anonymous';
  if (ftp_host = '') or (ftp_user = '') then exit;
  NMFTP1.Host:=ftp_host;
  NMFTP1.Username:=ftp_user;
  NMFTP1.Password:=ftp_pass;
  NMFTP1.Port:=ftp_port;
  NMFTP1.Passive:=passive;
  try
    NMFTP1.connect;
    if NMFTP1.Connected then
      result := 'OK'
    else
      result := '不能连接';
  except on e:Exception do
    result := e.Message;
  end;
  try
    NMFTP1.Disconnect
  except end;
end;


end.