BVB Source Codes

Magnificent Delphi implementation interface game Lander Show SecrchInfoMain.pas Source code

Return Download Magnificent Delphi implementation interface game Lander: download SecrchInfoMain.pas Source code - Download Magnificent Delphi implementation interface game Lander Source code - Type:.pas
  1. unit SecrchInfoMain;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7.   Dialogs, StdCtrls, RzLabel, ExtCtrls, RzButton, StrUtils, Share, ShlObj, ActiveX;
  8.  
  9. type
  10.   TSecrchFrm = class(TForm)
  11.     GroupBox1: TGroupBox;
  12.     StopButton: TRzButton;
  13.     GroupBox2: TGroupBox;
  14.     Label1: TLabel;
  15.     Label2: TLabel;
  16.     RzToolButtonSearch: TRzToolButton;
  17.     SecrchInfoLabel: TRzLabel;
  18.     Label3: TLabel;
  19.     Label4: TLabel;
  20.     Label5: TLabel;
  21.     EditPath: TEdit;
  22.     RzButtonSelDir: TRzButton;
  23.     procedure SearchMirClient();
  24.     procedure StopButtonClick(Sender: TObject);
  25.     procedure RzToolButtonSearchClick(Sender: TObject);
  26.     procedure RzButtonSelDirClick(Sender: TObject);
  27.     procedure FormCreate(Sender: TObject);
  28.     procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  29.   private
  30.     { Private declarations }
  31.   public
  32.     { Public declarations }
  33.   end;
  34. function CheckMirDir(DirName: string): Boolean;
  35. var
  36.   SecrchFrm: TSecrchFrm;
  37. implementation
  38. var
  39.   boStopSearch: Boolean = FALSE;
  40.   boSearchFinish: Boolean = FALSE;
  41. {$R *.dfm}
  42. function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer stdcall;
  43. begin
  44.   if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then
  45.     SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpData);
  46.   result := 0;
  47. end;
  48.  
  49. function SelectDirectory(const Caption: string; const Root: WideString;
  50.   var Directory: string; Owner: THandle): Boolean;
  51. var
  52.   WindowList: Pointer;
  53.   BrowseInfo: TBrowseInfo;
  54.   Buffer: PChar;
  55.   RootItemIDList, ItemIDList: PItemIDList;
  56.   ShellMalloc: IMalloc;
  57.   IDesktopFolder: IShellFolder;
  58.   Eaten, Flags: LongWord;
  59. begin
  60.   result := FALSE;
  61.   if not DirectoryExists(Directory) then
  62.     Directory := '';
  63.   FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  64.   if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then begin
  65.     Buffer := ShellMalloc.Alloc(MAX_PATH);
  66.     try
  67.       RootItemIDList := nil;
  68.       if Root <> '' then begin
  69.         SHGetDesktopFolder(IDesktopFolder);
  70.         IDesktopFolder.ParseDisplayName(Application.Handle, nil,
  71.           POleStr(Root), Eaten, RootItemIDList, Flags);
  72.       end;
  73.       with BrowseInfo do begin
  74.         hwndOwner := Owner;
  75.         pidlRoot := RootItemIDList;
  76.         pszDisplayName := Buffer;
  77.         lpszTitle := PChar(Caption);
  78.         ulFlags := BIF_RETURNONLYFSDIRS;
  79.         if Directory <> '' then begin
  80.           lpfn := SelectDirCB;
  81.           lParam := Integer(PChar(Directory));
  82.         end;
  83.       end;
  84.       WindowList := DisableTaskWindows(0);
  85.       try
  86.         ItemIDList := ShBrowseForFolder(BrowseInfo);
  87.       finally
  88.         EnableTaskWindows(WindowList);
  89.       end;
  90.       result := ItemIDList <> nil;
  91.       if result then begin
  92.         ShGetPathFromIDList(ItemIDList, Buffer);
  93.         ShellMalloc.Free(ItemIDList);
  94.         Directory := Buffer;
  95.       end;
  96.     finally
  97.       ShellMalloc.Free(Buffer);
  98.     end;
  99.   end;
  100. end;
  101.  
  102. function AddString(s: string): string;
  103. begin
  104.   result := s;
  105.   if s[Length(s)] <> '\' then result := s + '\';
  106. end;
  107.  
  108. function ReadMessage(MessageText: string; LengCount: Integer): string;
  109. var
  110.   I, CopyCout: Integer;
  111.   Str: string;
  112. begin
  113.   if Length(MessageText) <= LengCount then begin
  114.     result := MessageText;
  115.     exit;
  116.   end;
  117.   if Length(MessageText) > LengCount then begin
  118.     CopyCout := (Length(MessageText) div LengCount) + 1;
  119.     for I := 1 to CopyCout do begin
  120.       if I = 1 then begin
  121.         Str := Str + MidStr(MessageText, 1, LengCount) + #13;
  122.       end else begin
  123.         if I = CopyCout then begin
  124.           Str := Str + MidStr(MessageText, (I * LengCount) + 1, Length(MessageText) - (I * LengCount)) + #13;
  125.           break;
  126.         end;
  127.       end;
  128.       Str := Str + MidStr(MessageText, (I * LengCount) + 1, LengCount) + #13;
  129.     end;
  130.     result := Str;
  131.   end;
  132. end;
  133.  
  134. //获取当前的硬盘所有的盘符
  135. procedure GetdriveName(var sList: TStringList);
  136. var
  137.   I, dtype: Integer;
  138.   c: string;
  139. begin
  140.   for I := 65 to 90 do begin
  141.     c := chr(I) + ':\';
  142.     dtype := getdrivetype(PChar(c));
  143.     if (not ((dtype = 0) or (dtype = 1))) and (dtype = drive_fixed) then {//过滤光驱}  begin
  144.       sList.Add(c);
  145.     end;
  146.   end;
  147. end;
  148.  
  149. function DoSearchFile(path: string; var Files: TStringList): Boolean;
  150. var
  151.   Info: TsearchRec;
  152.   s01: string;
  153.   procedure ProcessAFile(FileName: string);
  154.   begin
  155.    {if Assigned(PnlPanel) then
  156.      PnlPanel.Caption := FileName;
  157.    Label2.Caption := FileName;}
  158.   end;
  159.   function IsDir: Boolean;
  160.   begin
  161.     with Info do
  162.       result := (Name <> '.') and (Name <> '..') and ((Attr and faDirectory) = faDirectory);
  163.   end;
  164.   function IsFile: Boolean;
  165.   begin
  166.     result := not ((Info.Attr and faDirectory) = faDirectory);
  167.   end;
  168. begin
  169.   try
  170.     result := FALSE;
  171.     if findfirst(path + '*.*', faAnyFile, Info) = 0 then begin
  172.       if IsDir then begin
  173.         s01 := path + Info.Name;
  174.         if s01[Length(s01)] <> '\' then s01 := s01 + '\';
  175.         Files.Add(s01);
  176.       end;
  177.       while True do begin
  178.         if m_BoSearchFinish then break;
  179.         if boStopSearch then break;
  180.         s01 := path + Info.Name;
  181.         if s01[Length(s01)] <> '\' then s01 := s01 + '\';
  182.         if IsDir then Files.Add(s01);
  183.         Application.ProcessMessages;
  184.         if findnext(Info) <> 0 then break;
  185.       end;
  186.     end;
  187.     result := True;
  188.   finally
  189.     findclose(Info);
  190.   end;
  191. end;
  192.  
  193. procedure TSecrchFrm.SearchMirClient();
  194. var
  195.   I, II: Integer;
  196.   sList, sTempList, List01, List02: TStringList;
  197. begin
  198.   boSearchFinish:=TRUE;
  199.   sList := TStringList.Create;
  200.   sTempList := TStringList.Create;
  201.   List01 := TStringList.Create;
  202.   List02 := TStringList.Create;
  203.   GetdriveName(sList);
  204.   for I := 0 to sList.Count - 1 do begin
  205.     Application.ProcessMessages;
  206.     if m_BoSearchFinish then break;
  207.     if boStopSearch then break;
  208.     SecrchInfoLabel.Caption := '正在搜索:' + sList.Strings[I];
  209.     if CheckMirDir(sList.Strings[I]) then begin
  210.       m_sMirClient := sList.Strings[I];
  211.       m_BoSearchFinish := True;
  212.       break;
  213.     end;
  214.     if DoSearchFile(sList.Strings[I], sTempList) then begin
  215.       if m_BoSearchFinish then break;
  216.       if boStopSearch then break;    
  217.       for II := 0 to sTempList.Count - 1 do begin
  218.         SecrchInfoLabel.Caption := '正在搜索:' + sTempList.Strings[II];
  219.         if CheckMirDir(sTempList.Strings[II]) then begin
  220.           m_sMirClient := sTempList.Strings[II];
  221.           m_BoSearchFinish := True;
  222.           break;
  223.         end;
  224.       end;
  225.     end;
  226.   end;
  227.   List01.AddStrings(sTempList);
  228.   if (not m_BoSearchFinish) and (not boStopSearch) then begin
  229.     I := 0;
  230.     while True do begin              //从C盘到最后一个盘反复搜索
  231.       if m_BoSearchFinish then break;
  232.       if boStopSearch then break;
  233.       Application.ProcessMessages;
  234.       if List01.Count <=0 then Break;
  235.       sTempList.Clear;
  236.       if DoSearchFile(List01.Strings[I], sTempList) then begin
  237.         if m_BoSearchFinish then break;
  238.         if boStopSearch then break;
  239.         List02.AddStrings(sTempList);
  240.         for II := 0 to sTempList.Count - 1 do begin
  241.           if m_BoSearchFinish then break;
  242.           if boStopSearch then break;
  243.           SecrchInfoLabel.Caption := '正在搜索:' + sTempList.Strings[II];
  244.           if CheckMirDir(sTempList.Strings[II]) then begin
  245.             m_sMirClient := sTempList.Strings[II];
  246.             m_BoSearchFinish := True;
  247.             break;
  248.           end;
  249.         end;
  250.       end;
  251.       Inc(I);
  252.       if I > List01.Count - 1 then begin
  253.         List01.Clear;
  254.         List01.AddStrings(List02);
  255.         List02.Clear;
  256.         I := 0;
  257.       end;
  258.     end;
  259.   end;
  260.   sList.Free;
  261.   sTempList.Free;
  262.   List01.Free;
  263.   List02.Free;
  264.   boSearchFinish:=FALSE;
  265. end;
  266.  
  267. function CheckMirDir(DirName: string): Boolean;
  268. begin
  269.   if (not DirectoryExists(DirName + 'Data')) or
  270.     (not DirectoryExists(DirName + 'Map')) or
  271.     (not DirectoryExists(DirName + 'Wav')) then
  272.     result := FALSE else result := True;
  273. end;
  274.  
  275. procedure TSecrchFrm.StopButtonClick(Sender: TObject);
  276. begin
  277.   boStopSearch := True;
  278.   Sleep(100);
  279.   Close;
  280. end;
  281.  
  282. procedure TSecrchFrm.RzToolButtonSearchClick(Sender: TObject);
  283. begin
  284.   if boSearchFinish then Exit;
  285.   RzButtonSelDir.Enabled:=False;
  286.   SearchMirClient();
  287.   RzButtonSelDir.Enabled:=TRUE;
  288.   Close;
  289. end;
  290.  
  291. procedure TSecrchFrm.RzButtonSelDirClick(Sender: TObject);
  292. var
  293.   sNewDir: string;
  294. begin
  295.   sNewDir := EditPath.Text;
  296.   if SelectDirectory('浏览文件夹', '', sNewDir, Handle) then begin
  297.     EditPath.Text := sNewDir;
  298.     m_sMirClient := sNewDir;
  299.     if m_sMirClient[Length(m_sMirClient)] <> '\' then m_sMirClient := m_sMirClient + '\';
  300.     m_BoSearchFinish := True;
  301.     Close;
  302.   end;
  303. end;
  304.  
  305. procedure TSecrchFrm.FormCreate(Sender: TObject);
  306. begin
  307.   boStopSearch := False;
  308.   m_BoSearchFinish := False;
  309.   //boSearchFinish:=FALSE;
  310. end;
  311.  
  312. procedure TSecrchFrm.FormCloseQuery(Sender: TObject;
  313.   var CanClose: Boolean);
  314. begin
  315.  // boStopSearch := True;
  316. end;
  317.  
  318. end.
  319.  
  320.  
downloadSecrchInfoMain.pas Source code - Download Magnificent Delphi implementation interface game Lander Source code
Related Source Codes/Software:
Image selection/editing plug-in v2.0 Delphi Edition - This is a DELPHI graphics you want to use a plugin... 2012-02-18
Children's mathematical arithmetic software in Delphi source code - The count of pupils is perfect according to the on... 2012-02-18
Delphi screen touch cash register system source program - From the perspective of directory structure, this ... 2012-02-18
Delphi examples of using the Image control to display and draw text - The Delphi examples through the use of an Image co... 2012-02-18
Delphi kanji literacy software full version - Delphi pupils ' Chinese character recognition soft... 2012-02-18
Delphi source code enterprise generic invoicing system - A common IT industry enters sells saves management... 2012-02-18
Stamp making software Delphi source code - The DELPHI software is very clever, you can achiev... 2012-02-18
Features of Delphi good teaching management system - A written in DLEPHI language teaching management ... 2012-02-18
Scheduled reminder alarm clock Delphi source code v1.0 - Often sit beside the computer, long maintained a p... 2012-02-18
Delphi implementation of the PING network command class - It is written by an expert, the main class is the ... 2012-02-18
KesionIMALL v3.7 formal version online mall system - KESIONIMALLV3.7 online shop system, as a new e-com... 2016-08-19
KesionICMS intelligent website system (gm) v3.7 formal version - KESIONICMS intelligent building systems with a fle... 2016-08-19
KesionICMS intelligent website system (government) v3.7 formal version - Government Portal website construction Establish t... 2016-08-19
KesionICMS intelligent website system (enterprise edition) v3.7 formal version - KesionICMS intelligent website (enterprise edition... 2016-08-19
KesionICMS intelligent website system (school) v3.7 formal version - For school management web site, the kesion forward... 2016-08-19
Easy to point the content management system DianCMS v6.0.0 SQL version - Easy content management system (DianCMS) is based ... 2016-08-19
Ray speed v7.0 wage query system - To modify the software to conduct a comprehensive ... 2016-08-19
Address book v1.0 FaLiang three layer - This Demo is a three layer address book source cod... 2016-08-19
Deng Xi v2.4 website help system - Deng Xi website help system is a very useful help ... 2016-08-19
1.0 housing, rental housing sale platform - Rent housing rent out platform is a very typical r... 2016-08-19

 Back to top