ver 2,0,1,78 版修正

Hong-Dell\Hong

2024-03-20 40bf1f9cb2685c739e7aa7a56d941f09ca512882

 CB_IMGPSScanImp.pas

@@ -1,5 +1,5 @@
unit CB_IMGPSScanImp;
//Test
//PRO
{$WARN SYMBOL_PLATFORM OFF}

interface
@@ -22,7 +22,9 @@
  Buttons, ImgList, SBSimpleSSL, SBHTTPSClient, SBWinCertStorage, SBX509,
  SBCustomCertStorage, SBUtils,mpsBarco,BarcodesFinder,HTTPApp,ErrList,
  Xmltool,inifiles,printers,IdHashMessageDigest, idHash, LogFile,ShellApi,
  SBSocket;
  SBSocket,IIS_Ftp, SBSimpleFTPS;
Type
  TTransMode =(tsHttp,tsFtp,tsNone);

var
  Ch_WriteNote : Boolean;
@@ -273,6 +275,9 @@
    PrtLb: TLabel;
    CaseHelpBtn: TBitBtn;
    HTTPSClient: TElHTTPSClient;
    Button5: TButton;
    FTPSClient1: TElSimpleFTPSClient;
    Button6: TButton;
    procedure ActiveFormCreate(Sender: TObject);
    procedure Panel9Resize(Sender: TObject);
    procedure ISB1Click(Sender: TObject);
@@ -399,6 +404,8 @@
      Shift: TShiftState; X, Y: Integer);
    procedure HTTPSClientRedirection(Sender: TObject; const OldURL: string;
      var NewURL: string; var AllowRedirection: Boolean);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
  private
    { Private declarations }
    HotKeyId1,HotKeyId2,HotKeyId3,HotKeyId4 :Integer;
@@ -438,9 +445,19 @@
    FWH_category:string;  //Y/N  Y是歸類時有區分入庫非入庫文件  N 是不區分
    ////////傳入參數///////

    TransMode : TTransMode;   //用何種方式上傳檔案
    //********Http參數********
    HttpErrStr : String; //錯誤訊息
    //********Http參數********

    //********Ftp參數*********
    FFtpIP : String;
    FFtpID : String;
    FFtpPwd : String;
    FFtpPath : String;
    FFtpPort : Integer;
    FFtpProtocol : TFtpProtocol;
    //********Ftp參數*********

    //********ini參數********
    DeviceDelete : Boolean;     //空白頁刪除啟動
@@ -548,6 +565,7 @@
    DocNoLength : Integer;  //Docno長度

    PEFileName : String; //掃描時的檔名
    DownFileErrStr : String;  //下載影像時發生的錯誤

    ISB : TImageScrollBox;
    ScanInfo    : TScanInfo;
@@ -611,6 +629,11 @@
    Function GetFindResult(Col:String):String;
    //*********SQL相關************

    //*********FTP相關************
    Function GetFtpinfo(CaseID,Action:String):Boolean;
    Procedure SetFtpInfo;     //餵入FTP資訊
    Function FtpCaseComplete(SendData:String):Boolean;
    //*********FTP相關************

    //*******轉換區*********
    Function FindDivFormCode(FormCode:String):Boolean; //找有沒有分案的條碼
@@ -727,6 +750,7 @@
    Function Node3FormID(Node3:TTreeNode):String;  //MyTreeNode3取FormCode出來
    Function GetNode2Name(Node2:TTreeNode):String;  //取MyTreeNode2的識別字出來(記之前點選用)
    //Function Down_Replace_Img(SPAth,DPath,CaseID:String):Boolean;
    Function DownLoadImage(Path,CaseID:String):Boolean;
    Function Down_Img(Path,CaseID:String):Boolean;
    Function GetNoNameCase(Path:string):String; //取未配號XXXX
    Procedure CaseResort(Path:String); //案件的檔案重新排序(次文件依Docno挑)
@@ -4340,6 +4364,26 @@
//  SampleFormIDList.Add('31A00101031706A');
end;

procedure TCB_IMGPSScanX.Button5Click(Sender: TObject);
begin
  GetftpInfo(NowCaseno,'upload');
  SetFtpInfo;
  IIS_Ftp.FtpsConnect;

  IIS_Ftp.FtpsToMain(FFtpPath,NowCaseno+'.pdf','d:\1.pdf',display1);
end;

procedure TCB_IMGPSScanX.Button6Click(Sender: TObject);
begin
  GetftpInfo(NowCaseno,'download');
  SetFtpInfo;
  IIS_Ftp.FtpsConnect;
  IIS_Ftp.FtpsCWD(IIS_Ftp.FtpPath);
  IIS_Ftp.FtpsReceive(NowCaseNo+'.zip','d:\'+NowCaseNo+'.zip');


end;

procedure TCB_IMGPSScanX.StatrTwainScan;
var ScanInfo    : TScanInfo;
   i : Integer;
@@ -6422,10 +6466,11 @@
  In_Doc1,In_Doc2 : String;
  AttachYN : String; //是否有附件 Y:有 N:沒有

  ST1,ST2:TStringList;
  ST1,ST2,ST3:TStringList;
  str1,str2:String;
  must_formidStr :string;
  last_add_formidstr :string;
  ScanListStr:String;
  casepath:String;
  filesizeInt:integer;
  case_page:string;
@@ -6463,20 +6508,12 @@
  //CaseResort(Path);  //檔名照設定排序
  CreateFormID_FormName(Path,CaseID);  //產生FormID_FormName.dat
  CreateDocNo_DocName(Path,CaseID); //產生DocNo_Name.dat
//ShowMessage('EEEEEEEEEE');
  Doc_Data := CreateDocNo_Info(CaseID);  //產生保管袋文件 Docno,份數,頁數;Docno,份數,頁數 的回傳字串
//ShowMessage('1111111111');
  Doc_Data1 := CreateCustDocNo_Info(CaseID);  //產生自定文件 Docname,份數,頁數;Docno,份數,頁數 的回傳字串
//ShowMessage('2222222222');
  In_Doc1 := CreateDocnoFrom_Info(CaseID); //產生被引進的保管袋文件資訊  Docno[tab]份數[tab]案件編號#13#10Docno[tab]份數[tab]案件編號
//ShowMessage('333333333333333333');
  In_Doc2 := CreateCustDocNoFrom_Info(CaseID);   //產生被引進的自定文件資訊  Docno[tab]份數[tab]案件編號#13#10Docno[tab]份數[tab]案件編號
//ShowMessage('4444444444444');
  AttachYN := CreateAttach_Info(CaseID); //是否還有附件 Y:有 N:沒有
  //self.ReadCaseIndex()
//ShowMessage('555555555555');
  ReadCaseIndex(Path);
//ShowMessage('DDDDDDDDDD');
  //LoanDoc := 'Y';
  //產生遮罩影像
//  if FWork_No = 'CW' then
@@ -6492,6 +6529,7 @@
//ShowMessage(ST1.Text);
//ShowMessage(LastInitFormidList.Text);
  ST2:=TStringList.Create;
  ST3:=TStringlist.Create;

  for I := 0 to ST1.Count - 1 do
  begin
@@ -6505,6 +6543,8 @@
  must_formidStr:=Copy(must_formidStr,1,Length(must_formidStr)-3) ;
//ShowMessage('must_formidStr='+must_formidStr);
//ShowMessage('AST2='+ST2.Text);


  for I := 0 to LastInitFormidList.Count - 1 do
  begin
    if ST2.IndexOf(LastInitFormidList.Strings[i]) <> -1 then
@@ -6518,8 +6558,19 @@
      last_add_formidstr:=last_add_formidstr+ST2.Strings[i]+'@#,';
  end;
  last_add_formidstr:=Copy(last_add_formidstr,1,Length(last_add_formidstr)-3) ;

  ST3.LoadFromFile(path+'scanlist.dat');
  for I := 0 to ST3.Count - 1 do
  begin
    if ScanListStr = '' then
      ScanListStr := FileName2FormCode(ST3.Strings[i])
    else
      ScanListStr := Format('%s,%s',[ScanListStr,FileName2FormCode(ST3.Strings[i])]);
  end;

  ST1.Free;
  ST2.Free;
  ST3.Free;
//ShowMessage('last_add_formidstr='+last_add_formidstr);
  ///////必要formid 20170315 end //////////////////////////

@@ -6569,44 +6620,89 @@
    FindClose(FileRec);
  ///檢查上傳的zip大小////
//ShowMessage('last_add_formidstr='+last_add_formidstr);
  ////上傳/////
  if not GetftpInfo(CaseID,'upload') then   //取案件上傳方式
  begin
    //Showmessage(_Msg()Inttostr(HttpError.HttpErrorCode)+' '+HttpError.HttpReason+'.');
    DownFileErrStr := _Msg('取案件上傳資訊失敗!!')+HttpErrStr;
    Result := False;
    Exit;
  end;
  SendData:='data='+HTTPEncode(UTF8Encode(FData))
  +'&verify='+FVerify
  +'&form_id='+UpformID
  +'&loan_doc='+Case_loandoc
  +'&case_no='+TransName
  +'&doc_data='+HTTPEncode(UTF8Encode(Doc_Data))
  +'&doc_data1='+HTTPEncode(UTF8Encode(Doc_Data1))
  +'&attach='+AttachYN
  +'&case_page='+case_page
  +'&file_size='+IntToStr(filesizeInt)
  +'&must_formid='+must_formidStr  //擁有的 formid
  +'&last_add_formid='+last_add_formidstr   //當次新加的 formid
  +'&in_doc1='+HTTPEncode(UTF8Encode(In_Doc1))
  +'&in_doc2='+HTTPEncode(UTF8Encode(In_Doc2));
//ShowMessage('SendData='+SendData);
//ShowMessage(FData+#10#13+Doc_Data);
  //Showmessage('Wait');
      +'&verify='+FVerify
      +'&form_id='+UpformID
      +'&loan_doc='+Case_loandoc
      +'&case_no='+TransName
      +'&doc_data='+HTTPEncode(UTF8Encode(Doc_Data))
      +'&doc_data1='+HTTPEncode(UTF8Encode(Doc_Data1))
      +'&attach='+AttachYN
      +'&case_page='+case_page
      +'&file_size='+IntToStr(filesizeInt)
      +'&must_formid='+must_formidStr  //擁有的 formid
      +'&last_add_formid='+last_add_formidstr   //當次新加的 formid
      +'&form_code='+ScanListStr      //scanlist.dat 表單代號
      +'&ftp_image_path='+FFtpPath   //加傳FTP目錄  HTTP上傳時會是空白
      +'&in_doc1='+HTTPEncode(UTF8Encode(In_Doc1))
      +'&in_doc2='+HTTPEncode(UTF8Encode(In_Doc2));

  if not upFile(HTTPSClient,FUrl,'service/imgpsc/IMGPSC02/caseupload',SendData,'file',Path+'Img.zip',FReWrite,Memo1,False) then
  begin
    Showmessage(Inttostr(HttpError.HttpErrorCode)+' '+HttpError.HttpReason+'.');
    Result := False;
    Exit;
  case TransMode of
    tsHttp :
    begin
      ////上傳/////
      ShowText := CaseID+_Msg('資料上傳中(Http),請稍候');
      DataLoading(True,True);
      if not upFile(HTTPSClient,FUrl,'service/imgpsc/IMGPSC02/caseupload',SendData,'file',Path+'Img.zip',FReWrite,Memo1,False) then
      begin
        Showmessage(Inttostr(HttpError.HttpErrorCode)+' '+HttpError.HttpReason+'.');
        Result := False;
        Exit;
      end;
      if memo1.Lines.Strings[0] = '1' then
      begin
        Showmessage(Format(_Msg('')+_Msg(''),[CaseID])+memo1.Lines.Strings[1]+'。');
        Result := False;
        Exit;
      end
      Else if Pos('<script type="text/javascript" src="scripts/IMGPS00/login.js"></script>',Memo1.Lines.Text) > 0 then
      begin
        Showmessage(Format(_Msg('')+_Msg('')+_Msg('閒置過久或被登出,請重新登入'),[CaseID]));
        Result := False;
        Exit;
      end;
      ////上傳////
    end;
    tsFtp :
    begin
       ShowText := CaseID+_Msg('資料上傳中(Ftp),請稍候');
       DataLoading(True,True);
       SetFtpInfo;
       try
         if not IIS_Ftp.FtpsConnect then
         begin
           Showmessage(Format('無法連上Ftp主機,錯誤原因:%s',[FtpErrReason]));
           Result := False;
           Exit;
         end;
         if not IIS_Ftp.FtpsToMain(FFtpPath,CaseID+'.zip',Path+'Img.zip',display1) then
         begin
           Showmessage(Format(_msg('上傳案件(%s)時,發生錯誤,錯誤原因:%s'),[CaseID,FtpErrStr]));
           Result := False;
           Exit;
         end;

         if not FtpCaseComplete(SendData) then    //Ftp上傳後通知完成
         begin
           Showmessage(Format(_Msg('通知案件(%s)Ftp上傳完成時,發生錯誤!!'),[CaseID])+HttpErrStr);
           Result := False;
           Exit;
         end;
       finally
       IIS_Ftp.FtpsClose;
       end;
    end;

  end;
  if memo1.Lines.Strings[0] = '1' then
  begin
    Showmessage(Format(_Msg('')+_Msg(''),[CaseID])+memo1.Lines.Strings[1]+'。');
    Result := False;
    Exit;
  end
  Else if Pos('<script type="text/javascript" src="scripts/IMGPS00/login.js"></script>',Memo1.Lines.Text) > 0 then
  begin
    Showmessage(Format(_Msg('')+_Msg('')+_Msg('閒置過久或被登出,請重新登入'),[CaseID]));
    Result := False;
    Exit;
  end;
  ////上傳////


  if FMode = 'ESCAN' then    //上傳舊件引入檔案      //20140616 原本先搬舊件再搬新件,改為先搬新件再搬舊件
  begin
    if not TransOldCaseFile(ImageSavePath+CaseID+'\') then
@@ -6831,6 +6927,52 @@
  if DirectoryExists(SPath+'AttFile\') then
    AttFile_Arrange(SPath+'AttFile\',DPath+'AttFile\');
end;}

Function TCB_IMGPSScanX.DownLoadImage(Path,CaseID:String):Boolean;
begin
  Result := True;
  if not GetftpInfo(CaseID,'download') then   //取案件下載方式
  begin
    DownFileErrStr := _Msg('取案件下載資訊失敗,')+HttpErrStr;
    Result := False;
    Exit;
  end;
  case TransMode of
    tsHttp:
    begin
      ShowText := _Msg('案件下載中(Http),請稍候');
      DataLoading(True,True);
      If not Down_Img(ImageSavePath+FCaseID+'\Download\',FCaseID) then
      begin
        Showmessage(FCaseID+_msg('載入異動影像時,網路發生錯誤')+HttpErrStr);
        DataLoading(False,False);
        Exit;
      end;
    end;
    tsFtp:
    begin
      ShowText := _Msg('案件下載中(Ftp),請稍候');
      DataLoading(True,True);
      SetFtpInfo;

      if not IIS_Ftp.FtpsConnect then
      begin
        DownFileErrStr := Format(_Msg('無法連上Ftp主機,錯誤原因:%s')+#13+'%s',[FtpErrReason,FTPSClient1.LastReceivedReply]);
        Result := False;
        Exit;
      end;
      if not IIS_Ftp.FtpsDownloadFile(IIS_Ftp.FtpPath,CaseID+'.zip',Path+CaseID+'.zip',display1) then
      begin
        DownFileErrStr := Format(_Msg('錯誤原因:%s'),[FtpErrStr]);
        Result := False;
        Exit;
      end;
      ExecuteUnZip(Path+CaseID+'.zip',Path,False);
      DeleteFile(Path+CaseID+'.zip');
    end;
  end;
end;


Function TCB_IMGPSScanX.Down_Img(Path,CaseID:String):Boolean;
var
@@ -8671,7 +8813,6 @@
    if Col =RCol then
      Result := RValue;
  end;

end;

Procedure TCB_IMGPSScanX.DataLoading(Loading:Boolean;UseTimer:Boolean);  //資料載入中要停止點選的動作
@@ -10804,6 +10945,136 @@
    Exit;
  end;
  IF memo1.Lines.Strings[0] = '1' Then
  begin
    HttpErrStr := _Msg('錯誤原因:')+memo1.Lines.Strings[1];
    Result := False;
    Exit;
  end
  Else if Pos('<script type="text/javascript" src="scripts/CW00/login.js"></script>',Memo1.Lines.Text) > 0 then
  begin
    HttpErrStr := _Msg('錯誤原因:')+_Msg('閒置過久或被登出,請重新登入');
    Result := False;
    Exit;
  end;
end;

Function TCB_IMGPSScanX.GetFtpinfo(CaseID,Action:String):Boolean;
var
  SendData : String;

  Procedure DecodeFtpInfo(EncryStr:String);
  var
    FtpStr : String;
    ftpinfoList : TStringlist;
  begin
    if EncryStr = '' then Exit;
    ftpinfoList := TStringlist.Create;
    try
      FtpStr := En_DecryptionStr_Base64('D',EncryStr,MpsKey);
      SplitString('!@!',FtpStr,ftpinfoList);
      if ftpinfoList[0] = 'ftps' then
        FFtpProtocol := fpftps
      else if ftpinfoList[0] = 'ftp' then
        FFtpProtocol := fpftp;
      FFtpIP := ftpinfoList[1];
      FFtpPort := strtoint(ftpinfoList[2]);
      FFtpID := ftpinfoList[3];
      FFtpPwd := ftpinfoList[4];

    finally
    ftpinfoList.Free;
    end;
  end;
begin
  Result := True;
  SendData:='product='+FWork_no+'&case_no='+CaseID+'&department='+FUserUnit+'&action='+Action;
  If not ProcessServlet_FormData(HTTPSClient,FURL+'service/imgpsc/IMGPSC02/ftps',SendData,FReWrite,Memo1,False) Then
  begin
    HttpErrStr := _Msg('錯誤代碼:')+inttostr(HttpError.HttpErrorCode)+','+HttpError.HttpReason;
    Result := False;
    Exit;
  end;
  IF (memo1.Lines.Strings[0] = '1') Then
  begin
    if memo1.Lines.Strings[1]='nodata' then   //nodata 為正常可繼續的判斷
    begin
      TransMode := tsNone;
      Result := True;
      Exit;
    end
    else
    begin
      HttpErrStr := _Msg('錯誤原因:')+memo1.Lines.Strings[1];
      Result := False;
      Exit;
    end;
  end
  Else if Pos('<script type="text/javascript" src="scripts/CW00/login.js"></script>',Memo1.Lines.Text) > 0 then
  begin
    HttpErrStr := _Msg('錯誤原因:')+_Msg('閒置過久或被登出,請重新登入');
    Result := False;
    Exit;
  end
  else if (memo1.Lines.Strings[0] <> '0') then//不認識的字串
  begin
    HttpErrStr := _Msg('錯誤原因:')+memo1.Lines.Strings[0];
    Result := False;
    Exit;
  end;
  TransMode := tsHttp;
  FFtpPath := '';
  if memo1.Lines.Strings[0] = '0' then
  begin
    if memo1.Lines.Strings[2] = 'Y' then
      TransMode := tsFtp;
    if memo1.Lines.Count > 3 then
    begin
      FFtpPath := memo1.Lines.Strings[3];
      DecodeFtpInfo(memo1.Lines.Strings[4]);
    end;
  end;
end;

Procedure TCB_IMGPSScanX.SetFtpInfo;     //餵入FTP資訊
begin
  IIS_Ftp.Display1 := Display1;
  IIS_Ftp.FTPSClient1 := FTPSClient1;
  IIS_Ftp.ElMemoryCertStorage := ElMemoryCertStorage;
  IIS_Ftp.Display1 := Display1;
  IIS_Ftp.Ftpip := FFtpIP;
  IIS_Ftp.Ftpuserid := FFtpID;
  IIS_Ftp.FtpPwd := FFtpPwd;
  IIS_Ftp.FtpPath := FFtpPath;
  IIS_Ftp.FtpPort := FFtpPort;
  IIS_Ftp.FtpSSL := True;
  IIS_Ftp.FtpPassive := True;
  if FFtpProtocol = fpftp then
     IIS_Ftp.FtpSSL := False;
  IIS_Ftp.FtpEncryptDataChannel := true;
  FTPSClient1.OnControlReceiveAsString := IIS_Ftp.EventHandlers.ControlReceiveAsString;
  FTPSClient1.OnControlSendAsString := IIS_Ftp.EventHandlers.ControlSendAsString;
  FTPSClient1.OnSSLError := IIS_Ftp.EventHandlers.SSLError;
  FTPSClient1.OnCertificateValidate := IIS_Ftp.EventHandlers.CertificateValidate;
  FTPSClient1.OnTextDataLine := IIS_Ftp.EventHandlers.TextDataLine;

  {Showmessage(Format('Ftpip:%s'+#13
              +'Ftpid:%s'+#13
              +'Ftppwd:%s'+#13
              +'Ftppath:%s'+#13
              +'Ftpport:%s'+#13
              ,[FFtpIP,FFtpid,FFtpPwd,Ftppath,inttostr(Ftpport)]));}
end;

Function TCB_IMGPSScanX.FtpCaseComplete(SendData:String):Boolean;
begin
  Result := True;
  If not ProcessServlet_FormData(HTTPSClient,FURL+'service/imgpsc/IMGPSC02/caseupload',SendData,FReWrite,Memo1,False) Then
  begin
    HttpErrStr := _Msg('錯誤代碼:')+inttostr(HttpError.HttpErrorCode)+','+HttpError.HttpReason;
    Result := False;
    Exit;
  end;
  IF (memo1.Lines.Strings[0] = '1') or (memo1.Lines.Strings[0] <> '0') Then
  begin
    HttpErrStr := _Msg('錯誤原因:')+memo1.Lines.Strings[1];
    Result := False;
@@ -14934,12 +15205,19 @@
    begin
      ShowText := _Msg('案件下載中,請稍候');
      DataLoading(True,True);
      If not Down_Img(ImageSavePath+FCaseID+'\Download\',FCaseID) then
      If not DownLoadImage(ImageSavePath+FCaseID+'\Download\',FCaseID) Then
      begin
        Showmessage(FCaseID+_msg('載入異動影像時,網路發生錯誤')+DownFileErrStr);
        DataLoading(False,False);
        Exit;
      end;

      {If not Down_Img(ImageSavePath+FCaseID+'\Download\',FCaseID) then
      begin
        Showmessage(FCaseID+_msg('載入異動影像時,網路發生錯誤')+HttpErrStr);
        DataLoading(False,False);
        Exit;
      end;
      end;}
//Showmessage(ImageSavePath+FCaseID+'\Download\'+#10#13+ImageSavePath+FCaseID+'\');
      Download2Case(ImageSavePath+FCaseID+'\Download\',ImageSavePath+FCaseID+'\');
//Showmessage('aaa');
@@ -15145,6 +15423,9 @@
    begin
      /////訊問是否可上傳/////
      CaseTrans := CaseAsk(CaseID);
      //Showmessage('記得改回來');
      //CaseTrans := 0;

      /////訊問是否可上傳////
    end
    Else  ///不是新件、重掃件、異動件的不查