Дипломная работа - Электронно-картографическая система SaveNavigation в системе программирования Delphi 7.0 - файл n5.doc

Дипломная работа - Электронно-картографическая система SaveNavigation в системе программирования Delphi 7.0
скачать (580.1 kb.)
Доступные файлы (5):
n1.doc893kb.23.06.2005 11:36скачать
n2.doc288kb.12.06.2005 06:43скачать
n3.db
n4.jpg22kb.12.06.2005 03:32скачать
n5.doc179kb.12.06.2005 08:09скачать

n5.doc

unit Unit1;
interface
uses

Windows, SysUtils, Graphics, Classes, Controls, Forms,

Dialogs, ImgList, IdGlobal, Menus, ComCtrls, StdCtrls, Buttons,

Masks;

type

First_Or_Second = (First, Second);

TwoPanels = record

road : string;

nDir,nfiles : integer;

fkbyte : integer;

numSort : byte

end;
TForm1 = class(TForm)

ListView1: TListView;

Edit1: TEdit;

ListView2: TListView;

ComboBox1: TComboBox;

ComboBox2: TComboBox;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

Label4: TLabel;

StatusBar1: TStatusBar;

ImageList1: TImageList;

OpenDialog1: TOpenDialog;

PopupMenu1: TPopupMenu;

Characteristic: TMenuItem;

PopupRazd: TMenuItem;

GoOut: TMenuItem;

MainMenu1: TMainMenu;

MenuFile: TMenuItem;

MenuAttr: TMenuItem;

Razd1: TMenuItem;

MenuF2: TMenuItem;

MenuF3: TMenuItem;

MenuF4: TMenuItem;

MenuF5: TMenuItem;

MenuF6: TMenuItem;

MenuF7: TMenuItem;

MenuF8: TMenuItem;

Razd2: TMenuItem;

MenuExit: TMenuItem;

MenuSelect: TMenuItem;

MenuSelectAll: TMenuItem;

MenuSelectInvert: TMenuItem;

MenuComand: TMenuItem;

MenuMemory: TMenuItem;

MenuWorkWindows: TMenuItem;

Razd3: TMenuItem;

MenuCascadno: TMenuItem;

MenuSvernutOkna: TMenuItem;

MenuUpdateDesctop: TMenuItem;

MenuRebootExsplorer: TMenuItem;

Razd4: TMenuItem;

MenuControlPanel: TMenuItem;

MenuDisplayProperties: TMenuItem;

Razd5: TMenuItem;

MenuCopyDiskA: TMenuItem;

MenuFormatA: TMenuItem;

Razd6: TMenuItem;

MenuBistroExitWindows: TMenuItem;

MenuCloseSeans: TMenuItem;

MenuPowerOff: TMenuItem;

MenuHelp: TMenuItem;

SpeedButton1: TSpeedButton;

Label5: TLabel;

Label6: TLabel;

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure AddNewFile(F : TSearchRec; var ListView: TListView);

procedure ShowDirectory(road : string; var ListView: TListView);

procedure ListView0Compare(Item1, Item2: TListItem; var Compare: Integer; n : byte);

procedure Edit1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

procedure ListViewKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

procedure ListViewClick(Sender: TObject);

procedure ListView0DblClick(var road : string; var ListView: TListView);

procedure ListViewCompare(Sender: TObject; Item1, Item2: TListItem;

Data: Integer; var Compare: Integer);

procedure ListViewColumnClick(Sender: TObject; Column: TListColumn);

procedure ListViewDblClick(Sender: TObject);

procedure ComboBoxDropDown(Sender: TObject);

procedure ComboBoxCloseUp(Sender: TObject);

procedure FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure CharacteristicClick(Sender: TObject);

procedure GoOutClick(Sender: TObject);

procedure ListViewMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure MenuF2Click(Sender: TObject);

procedure MenuF3Click(Sender: TObject);

procedure MenuF4Click(Sender: TObject);

procedure MenuF5Click(Sender: TObject);

procedure MenuF6Click(Sender: TObject);

procedure MenuF7Click(Sender: TObject);

procedure MenuF8Click(Sender: TObject);

procedure MenuSelectAllClick(Sender: TObject);

procedure MenuSelectInvertClick(Sender: TObject);

procedure MenuMemoryClick(Sender: TObject);

procedure MenuWorkWindowsClick(Sender: TObject);

procedure MenuCascadnoClick(Sender: TObject);

procedure MenuSvernutOknaClick(Sender: TObject);

procedure MenuUpdateDesctopClick(Sender: TObject);

procedure MenuRebootExsplorerClick(Sender: TObject);

procedure MenuControlPanelClick(Sender: TObject);

procedure MenuDisplayPropertiesClick(Sender: TObject);

procedure MenuCopyDiskAClick(Sender: TObject);

procedure MenuFormatAClick(Sender: TObject);

procedure MenuBistroExitWindowsClick(Sender: TObject);

procedure MenuCloseSeansClick(Sender: TObject);

procedure MenuPowerOffClick(Sender: TObject);

procedure MenuHelpClick(Sender: TObject);

procedure SpeedButton1Click(Sender: TObject);

procedure Memo1DblClick(Sender: TObject);

end;

var

Form1: TForm1;

Chesked_1Or2 : First_Or_Second;

FirstP, SecondP : TwoPanels;
implementation
{$R *.dfm}

procedure FindFiles(Path, Mask: string; var List: TStrings; IncludeSubDir: Boolean = True);

var

SearchRec: TSearchRec;

FindResult: Integer;

begin

List.BeginUpdate;

try

Path:=IncludeTrailingBackSlash(Path);

FindResult:=FindFirst(Path+'*.*', faAnyFile, SearchRec);

try

while FindResult = 0 do with SearchRec do begin

if (Attr and faDirectory<>0) then begin

if IncludeSubDir and (Name<>'..') and (Name<>'.')

then FindFiles(Path+Name, Mask, List, IncludeSubDir);

end

else begin

if MatchesMask(Name, Mask) then List.Add(Path+Name);

end;

FindResult:=FindNext(SearchRec);

end;

finally

FindClose(SearchRec);

end;

finally

List.EndUpdate;

end;

end;
function MyWinExec(FileName : String; Visibility : integer = SW_SHOWDEFAULT) : boolean;

var

zAppName:array[0..512] of char;

StartupInfo:TStartupInfo;

ProcessInfo:TProcessInformation;

begin

StrPCopy(zAppName,FileName);

FillChar(StartupInfo,Sizeof(StartupInfo),#0);

StartupInfo.cb := Sizeof(StartupInfo);

StartupInfo.dwFlags := STARTF_USESHOWWINDOW;

StartupInfo.wShowWindow := Visibility;

result := CreateProcess(nil,

zAppName, { указатель командной строки }

nil, { указатель на процесс атрибутов безопасности }

nil, { указатель на поток атрибутов безопасности }

false, { флаг родительского обработчика }

CREATE_NEW_CONSOLE or { флаг создания }

NORMAL_PRIORITY_CLASS,

nil, { указатель на новую среду процесса }

nil, { указатель на имя текущей директории }

StartupInfo, { указатель на STARTUPINFO }

ProcessInfo) { указатель на PROCESS_INF }

end;
procedure TForm1.FormCreate(Sender: TObject);

var i : integer;

procedure CreateColumn(var ListView: TListView);

var

NewColumn : TListColumn;

begin

with ListView do begin

ViewStyle := vsReport;

NewColumn := Columns.Add;

NewColumn.Caption := 'Название';

NewColumn := Columns.Add;

NewColumn.Caption := 'Расш.';

NewColumn := Columns.Add;

NewColumn.Caption := 'Размер, б';

NewColumn := Columns.Add;

NewColumn.Caption := 'Дата создания';

NewColumn := Columns.Add;

NewColumn.Caption := 'Скрытый';

NewColumn := Columns.Add;

NewColumn.Caption := 'Сист.';

Columns[0].Width := 120;

Columns[1].Width := 45;

Columns[2].Width := 80;

Columns[3].Width := 100;

Columns[4].Width := 58;

Columns[5].Width := 40;

end

end;

begin

CreateColumn(ListView1);

CreateColumn(ListView2);

SecondP.road := GetCurrentDir;

SecondP.numSort := 0;

Chesked_1Or2 := Second;

ShowDirectory(SecondP.road,ListView2);

ListView2.Items[0].Selected := true;

FirstP.road := 'C:';

FirstP.numSort := 0;

Chesked_1Or2 := First;

ShowDirectory(FirstP.road,ListView1);

ListView1.Items[0].Selected := true;
for i := 0 to 7 do begin

StatusBar1.Panels.Add;

StatusBar1.Panels[i].Width := form1.Width div 8;

StatusBar1.Panels[i].Bevel := pbRaised;

StatusBar1.Panels[i].Alignment := taCenter;

end;

StatusBar1.Panels.Items[0].Text := 'F1 - Помощь';

StatusBar1.Panels.Items[1].Text := 'F2 - Переимен.';

StatusBar1.Panels.Items[2].Text := 'F3 - Найти файл';

StatusBar1.Panels.Items[3].Text := 'F4 - Редактир.';

StatusBar1.Panels.Items[4].Text := 'F5 - Копировать';

StatusBar1.Panels.Items[5].Text := 'F6 - Переместить';

StatusBar1.Panels.Items[6].Text := 'F7 - Созд. кат.';

StatusBar1.Panels.Items[7].Text := 'F8 - Удалить';

end;

procedure TForm1.AddNewFile(F : TSearchRec; var ListView: TListView);

var i : integer;

ext : string;

begin

if F.Name <> '.' then

with ListView.Items.Add, F do begin

if (Attr and faDirectory) <> 0 then begin

Caption := AnsiUpperCase(Name);

SubItems.Add('');

ImageIndex := 0;

SubItems.Add('Папка')

end

else begin

Name := AnsiLowerCase(Name);

ext := ExtractFileExt(Name);

i := pos(ext,Name);

if i = 0 then Caption := Name

else begin

Caption := copy(Name,1,i-1);

ext := copy(ext,2,length(ext)-1)

end;

SubItems.Add(ext);

if (ext = 'bmp')or(ext = 'jpg')or(ext = 'jpeg')or(ext = 'gif') then ImageIndex := 1

else

if (ext = 'txt')or(ext = 'doc')or(ext = 'log') then ImageIndex := 2

else

if (ext = 'exe')or(ext = 'com')or(ext = 'bat') then ImageIndex := 3

else

if (ext = 'ini')or(ext = 'dll')or(ext = 'sys') then ImageIndex := 4

else ImageIndex := 5;

SubItems.Add(IntToStr(Size))

end;

SubItems.Add(DateTimeToStr(FileDateToDateTime(Time)));

if (Attr and faHidden) <> 0 then SubItems.Add('Да')

else SubItems.Add('Нет');

if (Attr and faSysFile) <> 0 then SubItems.Add('Да')

else SubItems.Add('Нет')

end

end;
procedure TForm1.ShowDirectory(road : string; var ListView: TListView);

var

F : TSearchRec;

numD,numF,filesize : integer;

begin

ListView.Clear;

numD := 0;

numF := 0;

filesize := 0;

if FindFirst(road+'\*.*', faAnyFile, F) = 0 then begin

repeat

AddNewFile(F,ListView);

if (F.Attr and faDirectory) <> 0 then begin

if (F.Name<>'..')and(F.Name<>'.') then inc(numD)

end

else begin

inc(numF);

inc(filesize,round(F.Size/1000))

end

until FindNext(F) <> 0;

ListView.AlphaSort;

ListView.ItemIndex := 0

end;

FindClose(F);

if Chesked_1Or2 = First then begin

label3.Caption := road;

label5.Caption := 'Папок '+IntToStr(numD)+' В '+IntToStr(numF)+' файлах - '+IntToStr(filesize)+' Kб'

end

else begin

label4.Caption := road;

label6.Caption := 'Папок '+IntToStr(numD)+' В '+IntToStr(numF)+' файлах - '+IntToStr(filesize)+' Kб'

end

end;
procedure TForm1.ListView0Compare(Item1, Item2: TListItem; var Compare: Integer; n : byte);

label repeatCase;

begin

if ((Item1.ImageIndex=Item2.ImageIndex)and(Item1.ImageIndex=0))or

((Item1.ImageIndex<>0)and(Item2.ImageIndex<>0)) then

repeatCase :

case n of

0 : if Item1.Caption = Item2.Caption then begin

n := 1; goto repeatCase

end

else

if Item1.Caption < Item2.Caption then Compare := -1

{Название} else Compare := +1;

1 : if Item1.SubItems[0] = Item2.SubItems[0] then begin

n := 0; goto repeatCase

end

else

if Item1.SubItems[0] < Item2.SubItems[0] then Compare := -1

{Расш.} else Compare := +1;

2 : if Item1.SubItems[1] = Item2.SubItems[1] then begin

n := 0; goto repeatCase

end

else

if Item1.ImageIndex<>0 then begin

if (StrToInt(Item1.SubItems[1]) < StrToInt(Item2.SubItems[1])) then Compare := -1

{Размер, б} else Compare := +1

end;

3 : if Item1.SubItems[2] = Item2.SubItems[2] then begin

n := 0; goto repeatCase

end

else

if DateTimeToFileDate(StrToDateTime(Item1.SubItems[2])) < DateTimeToFileDate(StrToDateTime(Item2.SubItems[2])) then Compare := -1

{Дата создания} else Compare := +1;

4 : if Item1.SubItems[3] = Item2.SubItems[3] then begin

n := 0; goto repeatCase

end

else

if Item1.SubItems[3] < Item2.SubItems[3] then Compare := -1

{Скрытый} else Compare := +1;

5 : if Item1.SubItems[4] = Item2.SubItems[4] then begin

n := 0; goto repeatCase

end

else

if Item1.SubItems[4] < Item2.SubItems[4] then Compare := -1

{Сист.} else Compare := +1;

end{case}

else

if Item1.ImageIndex
else Compare := +1

end;
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if key = 13 then begin

if FileExists(Edit1.Text) then begin

if not MyWinExec(Edit1.Text) then ShowMessage('Ошибка выполнения программы!')

end

else

if DirectoryExists(Edit1.Text) then

if Chesked_1Or2 = First then begin

FirstP.road := Edit1.Text;

ShowDirectory(FirstP.road,ListView1)

end

else begin

SecondP.road := Edit1.Text;

ShowDirectory(SecondP.road,ListView2)

end

else ShowMessage('Файл или папка не найдены!')

end

end;
function CopyDir(from,into : String) : boolean;

var

F : TSearchRec;

begin

into := into+'\'+ExtractFileName(from);

result := ForceDirectories(into); //MkDir

FindFirst(from+'\*.*',faAnyFile,F);

FindNext(F);

while FindNext(F) = 0 do

if (F.Attr and faDirectory)<>0 then CopyDir(from+'\'+F.Name,into)

else copyFileTo(from+'\'+F.Name,into+'\'+F.Name);

FindClose(F)

end;
function RemoveTree(dir : String) : boolean;

var

F : TSearchRec;

begin

FindFirst(dir+'\*.*',faAnyFile,F);

FindNext(F);

while FindNext(F) = 0 do

if (F.Attr and faDirectory)<>0 then RemoveTree(dir+'\'+F.Name)

else DeleteFile(dir+'\'+F.Name);

FindClose(F);

result := RemoveDir(dir)

end;
procedure TForm1.ListViewKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

var

road,filename,road_2 : string;

ListView: TListView;

Item : TListItem;

List: TStrings;

begin

case Key of

192 : if Chesked_1Or2 = First then begin

ListView2.SetFocus;

ListViewClick(ListView2)

end

else begin

ListView1.SetFocus;

ListViewClick(ListView1)

end;

13 : ListViewDblClick(Sender);

112 : ShowMessage('Программy составили студенты МГСУ'+#13#10+

'факультета АиИТ (АСУ):'+#13#10+

' Рашидов Р.'+#13#10+

' Зотов Т.'+#13#10+

' Троицкий А.'); //F1 - Помощь

46,113..119 : begin

if Chesked_1Or2 = First then begin

road := FirstP.road;

ListView := ListView1

end

else begin

road := SecondP.road;

ListView := ListView2

end;

Item := ListView.Items[ListView.ItemIndex];

case Key of

113 : if Item <> nil then begin //F2 - Переимен.

filename := Item.Caption;

if Item.ImageIndex<>0 then begin

if Item.SubItems[0]<>'' then filename := filename+'.'+Item.SubItems[0];

if RenameFile(road+'\'+filename,road+'\'+InputBox('Переименовать...','Файл '+filename+' в',filename)) then ShowDirectory(road,ListView)

else ShowMessage('Невозможно переименовать файл')

end

else

if Item.Caption<>'..' then

if RenameFile(road+'\'+filename,road+'\'+InputBox('Переименовать...','Директорию '+filename+' в',filename)) then ShowDirectory(road,ListView)

else ShowMessage('Невозможно переименовать каталог')

end;

114 : begin

repeat

if not InputQuery('Найти...','Введите имя или маску икомого файла',filename) then exit//F3 - Найти

until InputQuery('Найти.. .','Введите каталог, где будет вестись поиск',road);

Memo1.Show;

Memo1.ShowHint := true;

List := Memo1.Lines;

FindFiles(road, filename, List);

if List.Count > 1 then List.Delete(0);

end;

115 : while Item <> nil do begin//F4 - Редактир.

if Item.ImageIndex<>0 then

if Item.SubItems[0] = '' then

MyWinExec('C:\WINDOWS\NOTEPAD.EXE '+road+'\'+Item.Caption)

else

MyWinExec('C:\WINDOWS\NOTEPAD.EXE '+road+'\'+Item.Caption+'.'+Item.SubItems[0]);

Item := ListView.GetNextItem(Item, sdAll, [isSelected])

end;

116 : if Item <> nil then begin//F5 - Копировать

if Chesked_1Or2 = First then road_2 := SecondP.road

else road_2 := FirstP.road;

if InputQuery('Копировать...','Куда...',road_2) then

repeat

filename := Item.Caption;

if Item.ImageIndex<>0 then begin

if Item.SubItems[0]<>'' then filename := filename+'.'+Item.SubItems[0];

if not copyFileTo(road+'\'+filename,road_2+'\'+filename) then showMessage('Не удалось скопировать '+filename)

end

else begin

copyDir(road+'\'+filename,road_2)

end;

Item := ListView.GetNextItem(Item, sdAll, [isSelected])

until Item = nil;

if Chesked_1Or2 = First then begin

ListViewClick(ListView2);

ShowDirectory(SecondP.road,ListView2);

ListViewClick(ListView1)

end

else begin

ListViewClick(ListView1);

ShowDirectory(FirstP.road,ListView1);

ListViewClick(ListView2)

end

end;

117 : if ((Item <> nil)and(Item.Caption<>'..'))or(ListView.SelCount>1) then begin

if Chesked_1Or2 = First then road_2 := SecondP.road

else road_2 := FirstP.road;

if InputQuery('Comander','Переместить в ...',road_2) then begin

repeat

if Item.Caption<>'..' then begin

filename := Item.Caption;

if (Item.ImageIndex<>0)and(Item.SubItems[0]<>'') then filename := filename+'.'+Item.SubItems[0];

if road[1]<>road_2[1] then

if Item.ImageIndex=0 then begin

if copyDir(road+'\'+filename,road_2) then

if not RemoveTree(road+'\'+filename) then showMessage('Hе удаётся удалить каталог '+filename)

end

else begin

if CopyFileTo(road+'\'+filename,road_2+'\'+filename) then

if not DeleteFile(road+'\'+filename) then showMessage('Hе удаётся удалить файл '+filename)

end

else

if not RenameFile(road+'\'+filename,road_2+'\'+filename) then ShowMessage('Невозможно переместить файл/каталог: '+filename)

end;

Item := ListView.GetNextItem(Item, sdAll, [isSelected])

until Item = nil;

if Chesked_1Or2 = First then begin

ShowDirectory(FirstP.road,ListView1);

Chesked_1Or2 := Second;

ShowDirectory(SecondP.road,ListView2);

Chesked_1Or2 := First

end

else begin

Chesked_1Or2 := First;

ShowDirectory(FirstP.road,ListView1);

Chesked_1Or2 := Second;

ShowDirectory(SecondP.road,ListView2)

end

end

end;

118 : if InputQuery('Comander','Новая директория',road_2) then//F7 - Созд. кат.

if ForceDirectories(road+'\'+road_2) then ShowDirectory(road,ListView)

else ShowMessage('Невозможно создать каталог(и)');

46,119 : if Item <> nil then begin //F8 - Удалить

if ListView.SelCount = 1 then begin//выделен 1 файл

if Item.Caption<>'..' then

if Item.ImageIndex = 0 then begin//папка

if Application.MessageBox(PChar('Вы Уверены,'+#13#10+'что хотите удалить каталог '+Item.Caption+'?'),'Удаление...',MB_OkCancel)=1 then

if not RemoveTree(road+'\'+Item.Caption) then ShowMessage('Hевозможно удалить каталог '+Item.Caption)

end

else begin//файл

filename := Item.Caption;

if Item.SubItems[0]<>'' then filename := filename+'.'+Item.SubItems[0];

if Application.MessageBox(PChar('Вы Уверены,'+#13#10+'что хотите удалить файл '+filename+'?'),'Удаление...',MB_OkCancel)=1 then

if not DeleteFile(road+'\'+filename) then ShowMessage('невозможно удалить файл '+filename)

end

end

else //выделено несколько файлов

if Application.MessageBox(PChar('Вы Уверены,'+#13#10+'что хотите удалить '+IntToStr(ListView.SelCount)+' файлов(а) ?'),'Удаление...',MB_OkCancel)=1 then

repeat

if Item.Caption<>'..' then

if Item.ImageIndex = 0 then begin//папка

if not RemoveTree(road+'\'+Item.Caption) then ShowMessage('Hевозможно удалить каталог '+Item.Caption)

end

else begin//файл

filename := Item.Caption;

if Item.SubItems[0]<>'' then filename := filename+'.'+Item.SubItems[0];

if not DeleteFile(road+'\'+filename) then ShowMessage('невозможно удалить файл '+filename)

end;

Item := ListView.GetNextItem(Item, sdAll, [isSelected])

until Item = nil;

showDirectory(road,ListView)

end //Удалить заканчивается

end{case}

end

end{case}

end;
procedure TForm1.ListViewClick(Sender: TObject);

begin

if Sender = ListView1 then begin

ListView2.Color := clScrollBar;

ListView1.Color := clWindow;

Chesked_1Or2 := First

end

else begin

ListView1.Color := clScrollBar;

ListView2.Color := clWindow;

Chesked_1Or2 := Second

end

end;
procedure TForm1.ListView0DblClick(var road : string; var ListView: TListView);

var i : integer; Item : TListItem;

begin

if ListView.Items[ListView.ItemIndex].ImageIndex = 0 then {directory}

if ListView.Items[ListView.ItemIndex].Caption = '..' then begin

i := length(road);

while road[i]<>'\' do dec(i);

road := copy(road,1,i-1);

ShowDirectory(road,ListView)

end

else begin

road := road+'\'+ListView.Items[ListView.ItemIndex].Caption;

ShowDirectory(road,ListView)

end

else begin{Любой файл}

Item := ListView.Items[ListView.ItemIndex];

with Item do

while Item<>nil do begin

if (SubItems[0] = 'exe')or(SubItems[0] = 'bat')or(SubItems[0] = 'com') then

MyWinExec(road+'\'+Caption+'.'+SubItems[0])

else

if (SubItems[0] = 'txt')or(SubItems[0] = 'log')or(SubItems[0] = 'ini')or(SubItems[0] = 'doc') then

MyWinExec('C:\WINDOWS\NOTEPAD.EXE '+road+'\'+Caption+'.'+SubItems[0])

else

if (SubItems[0] = 'bmp')or(SubItems[0] = 'jpg') then

MyWinExec('C:\WINDOWS\pbrush.EXE '+road+'\'+Caption+'.'+SubItems[0])

else

if (SubItems[0] = 'gif')or(SubItems[0] = 'jpeg')or(SubItems[0] = 'htm')or(SubItems[0] = 'html') then

MyWinExec('C:\Program Files\Internet Explorer\IEXPLORE.EXE '+road+'\'+Caption+'.'+SubItems[0])

else begin

OpenDialog1.Filter := 'Приложения (*.ехе)|*.exe';

OpenDialog1.InitialDir := 'C:\Windows';

OpenDialog1.Title := 'Файл '+Caption+'.'+SubItems[0]+' открыть с помощью...';

if OpenDialog1.Execute then

if SubItems[0] = '' then

MyWinExec(OpenDialog1.FileName+' '+road+'\'+Caption)

else

MyWinExec(OpenDialog1.FileName+' '+road+'\'+Caption+'.'+SubItems[0])

end;

Item := ListView.GetNextItem(Item, sdAll, [isSelected])

end

end

end;
procedure TForm1.ListViewCompare(Sender: TObject; Item1, Item2: TListItem;

Data: Integer; var Compare: Integer);

begin

if Sender = ListView1 then ListView0Compare(Item1, Item2, Compare, FirstP.numSort)

else ListView0Compare(Item1, Item2, Compare, SecondP.numSort)

end;
procedure TForm1.ListViewColumnClick(Sender: TObject;

Column: TListColumn);

begin

if Sender = ListView1 then begin

if Column.Caption = 'Название' then FirstP.numSort := 0

else

if Column.Caption = 'Расш.' then FirstP.numSort := 1

else

if Column.Caption = 'Размер, б' then FirstP.numSort := 2

else

if Column.Caption = 'Дата создания' then FirstP.numSort := 3

else

if Column.Caption = 'Скрытый' then FirstP.numSort := 4

else FirstP.numSort := 5;

ListView1.AlphaSort

end

else begin

if Column.Caption = 'Название' then SecondP.numSort := 0

else

if Column.Caption = 'Расш.' then SecondP.numSort := 1

else

if Column.Caption = 'Размер, б' then SecondP.numSort := 2

else

if Column.Caption = 'Дата создания' then SecondP.numSort := 3

else

if Column.Caption = 'Скрытый' then SecondP.numSort := 4

else SecondP.numSort := 5;

ListView2.AlphaSort

end

end;
procedure TForm1.ListViewDblClick(Sender: TObject);

begin

if Sender = ListView1 then begin

if ListView1.ItemIndex >= 0 then ListView0DblClick(FirstP.road,ListView1)

end

else begin

if ListView2.ItemIndex >= 0 then ListView0DblClick(SecondP.road,ListView2)

end

end;
procedure TForm1.ComboBoxDropDown(Sender: TObject);

var disk : char;

ComboBox : TComboBox;

begin

if Sender = ComboBox1 then ComboBox := ComboBox1

else ComboBox := ComboBox2;

ComboBox.Clear;

try

if DirectoryExists('A:') then ComboBox.AddItem('A:',nil);

if DirectoryExists('B:') then ComboBox.AddItem('B:',nil);

for disk := 'C' to 'Z' do

if DirectoryExists(disk+':') then ComboBox.AddItem(disk+':',nil)

finally

end

{disk := 'C';

while DirectoryExists(disk+':') do begin

ComboBox.AddItem(disk+':',nil);

inc(Byte(disk))

end}

end;
procedure TForm1.ComboBoxCloseUp(Sender: TObject);

begin

if Sender = ComboBox1 then begin

ListViewClick(ListView1);

if ComboBox1.Items[ComboBox1.Itemindex] <> '' then FirstP.road := ComboBox1.Items[ComboBox1.Itemindex];

ShowDirectory(FirstP.road,ListView1)

end

else begin

ListViewClick(ListView2);

if ComboBox2.Items[ComboBox2.Itemindex] <> '' then SecondP.road := ComboBox2.Items[ComboBox2.Itemindex];

ShowDirectory(SecondP.road,ListView2)

end

end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var p : TPoint;

begin

if Button = mbRight then begin

p := GetClientOrigin;

if Sender is TListView then PopupMenu1.Items[0].Enabled := True

else PopupMenu1.Items[0].Enabled := False;

PopupMenu1.Popup(p.X+X,p.Y+Y)

end;

end;
function InputD(Namef : string) : boolean;

var

Form : TForm;

Prompt: TLabel;

CheckBox : array [0..3] of TCheckBox;

ButtonOk,ButtonCansel : TButton;

i,attr : integer;

begin

result := false;

Form := TForm.Create(Application);

attr := FileGetAttr(Namef);

with Form do

try

Canvas.Font := Font; BorderStyle := bsDialog;

Caption := 'Свойства'; ClientWidth := 250;

ClientHeight := 150; Position := poScreenCenter;

Prompt := TLabel.Create(Form);

with Prompt do begin

Parent := Form;

Constraints.MaxWidth := form.Width;

Caption := ExtractFileName(Namef);

Left := (Form.Width - Prompt.Width) shr 1;

Top := 1

end;

for i := 0 to 3 do begin

CheckBox[i] := TCheckBox.Create(Form);

with CheckBox[i] do begin

Parent := Form; Left := 5; Top := 20+i*20

end

end;

CheckBox[0].Caption := 'Только чтение';

CheckBox[1].Caption := 'Скрытый';

CheckBox[2].Caption := 'Системный';

CheckBox[3].Caption := 'Архивный';

ButtonOk := TButton.Create(Form);

with ButtonOk do begin

Parent := Form;

Caption := 'Ok';

ModalResult := mrOk;

Default := True;

SetBounds(35,form.Height-60,75,25)

end;

ButtonCansel := TButton.Create(Form);

with ButtonCansel do begin

Parent := Form;

Caption := 'Cansel';

ModalResult := mrCancel;

Cancel := True;

SetBounds(form.Width-110,form.Height-60,75,25)

end;

if attr and faReadOnly <> 0 then CheckBox[0].Checked := true;

if attr and faHidden <> 0 then CheckBox[1].Checked := true;

if attr and faSysFile <> 0 then CheckBox[2].Checked := true;

if attr and faArchive <> 0 then CheckBox[3].Checked := true;

if ShowModal = mrOk then begin

if CheckBox[0].Checked then attr := attr or faReadOnly

else attr := attr and not faReadOnly;

if CheckBox[1].Checked then attr := attr or faHidden

else attr := attr and not faHidden;

if CheckBox[2].Checked then attr := attr or faSysFile

else attr := attr and not faSysFile;

if CheckBox[3].Checked then attr := attr or faArchive

else attr := attr and not faArchive;

if FileSetAttr(Namef,attr) = 0 then Result := True

end;

finally

Form.Free

end

end;
procedure TForm1.CharacteristicClick(Sender: TObject);

var ListView : TListView;

filename : string;

begin

if Chesked_1Or2 = First then begin

filename := FirstP.road;

ListView := ListView1

end

else begin

filename := SecondP.road;

ListView := ListView2

end;

if (ListView.SelCount<>0)and(ListView.Items[ListView.ItemIndex].Caption<>'..') then begin

filename := filename+'\'+ListView.Items[ListView.ItemIndex].Caption;

if ListView.Items[ListView.ItemIndex].ImageIndex<>0 then

if ListView.Items[ListView.ItemIndex].SubItems[0]<>'' then filename := filename+'.'+ListView.Items[ListView.ItemIndex].SubItems[0];

InputD(filename)

end

end;
procedure TForm1.GoOutClick(Sender: TObject);

begin

if CloseQuery then Close

end;
procedure TForm1.ListViewMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if Sender = ListView1 then FormMouseUp(Sender,Button,Shift,X,Y+ListView1.Top)

else FormMouseUp(Sender,Button,Shift,X+ListView2.Left,Y+ListView2.Top)

end;
procedure TForm1.MenuF2Click(Sender: TObject);

var Key : word;

begin

Key := 113;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.MenuF3Click(Sender: TObject);

var Key : word;

begin

Key := 114;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.MenuF4Click(Sender: TObject);

var Key : word;

begin

Key := 115;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.MenuF5Click(Sender: TObject);

var Key : word;

begin

Key := 116;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.MenuF6Click(Sender: TObject);

var Key : word;

begin

Key := 117;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.MenuF7Click(Sender: TObject);

var Key : word;

begin

Key := 118;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.MenuF8Click(Sender: TObject);

var Key : word;

begin

Key := 119;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.MenuSelectAllClick(Sender: TObject);

begin

if Chesked_1Or2 = First then ListView1.SelectAll

else ListView2.SelectAll

end;
procedure TForm1.MenuSelectInvertClick(Sender: TObject);

var ListView : TListView;

Item : TListItem;

begin

if Chesked_1Or2 = First then ListView := ListView1

else ListView := ListView2;

Item := ListView.Items[0];

while Item <> nil do begin

Item.Selected := not Item.Selected;

Item := ListView.GetNextItem(Item, sdAll, [isNone])

end

end;
procedure TForm1.MenuMemoryClick(Sender: TObject);

var Status : TMemoryStatus;

Form : TForm;

Labels: array [0..6] of TLabel;

Button : TButton;

i : integer;

begin

Status.dwLength := sizeof(TMemoryStatus);

GlobalMemoryStatus(Status);

Form := TForm.Create(Application);

with Form do

try

Canvas.Font := Font;

BorderStyle := bsDialog;

Caption := 'Вся Память';

ClientWidth := 350;

ClientHeight := 180;

Position := poScreenCenter;

for i := 0 to 6 do begin

Labels[i] := TLabel.Create(Form);

with Labels[i] do begin

Parent := Form;

Top := 5 + i*20

end

end;

labels[0].Caption := 'Количество используемой памяти в процентах (%) '+IntToStr(Status.dwMemoryLoad);

labels[1].Caption := 'Общее количество физической памяти '+IntToStr(Status.dwTotalPhys shr 10)+' Кб';

labels[2].Caption := 'Количество оставшейся физической памяти '+IntToStr(Status.dwAvailPhys shr 10)+' Кб';

labels[3].Caption := 'Объём страничного файла '+IntToStr(Status.dwTotalPageFile shr 10)+' Кб'#13#10;

labels[4].Caption := 'Свободного места в страничном файле '+IntToStr(Status.dwAvailPageFile shr 10)+' Кб';

labels[5].Caption := 'Общий объём виртуальной памяти '+IntToStr(Status.dwTotalVirtual shr 10)+' Кб';

labels[6].Caption := 'Количество свободной виртуальной памяти '+IntToStr(Status.dwAvailVirtual shr 10)+' Кб.';

for i := 0 to 6 do labels[i].Left := (Form.Width - Labels[i].Width) shr 1;

Button := TButton.Create(Form);

with Button do begin

Parent := Form;

Caption := 'Ok';

ModalResult := mrOk;

Default := True;

SetBounds((form.Width-Button.Width) shr 1,form.Height-60,75,25)

end;

ShowModal

finally

Form.Free

end

end;
procedure TForm1.MenuWorkWindowsClick(Sender: TObject);

begin

ShowMessage('Windows уже работает'+ FormatDateTime(' h "ч." n "м." s "с."',GetTickCount/86400000))

end;
procedure TForm1.MenuCascadnoClick(Sender: TObject);

begin

MyWinExec('rundll32 user,cascadechildwindows')

end;
procedure TForm1.MenuSvernutOknaClick(Sender: TObject);

begin

MyWinExec('rundll32 user,tilechildwindows')

end;
procedure TForm1.MenuUpdateDesctopClick(Sender: TObject);

begin

MyWinExec('rundll32 user,repaintscreen')

end;
procedure TForm1.MenuRebootExsplorerClick(Sender: TObject);

begin

MyWinExec('rundll32 shell,shellexecute Explorer')

end;
procedure TForm1.MenuControlPanelClick(Sender: TObject);

begin

MyWinExec('rundll32 shell32,Control_RunDLL')

end;
procedure TForm1.MenuDisplayPropertiesClick(Sender: TObject);

begin

MyWinExec('rundll32 shell32,Control_RunDLL desk.cpl')

end;
procedure TForm1.MenuCopyDiskAClick(Sender: TObject);

begin

MyWinExec('rundll32 diskcopy,DiskCopyRunDll')

end;
procedure TForm1.MenuFormatAClick(Sender: TObject);

begin

MyWinExec('rundll32 shell32,SHFormatDrive')

end;
procedure TForm1.MenuBistroExitWindowsClick(Sender: TObject);

begin

MyWinExec('rundll32 shell32,SHExitWindowsEx 2')

end;
procedure TForm1.MenuCloseSeansClick(Sender: TObject);

begin

MyWinExec('rundll32 shell32,SHExitWindowsEx 0')

end;
procedure TForm1.MenuPowerOffClick(Sender: TObject);

begin

MyWinExec('rundll32 shell32,SHExitWindowsEx 1')

end;
procedure TForm1.MenuHelpClick(Sender: TObject);

var Key : word;

begin

Key := 112;

ListViewKeyDown(Sender,Key,[ssLeft])

end;
procedure TForm1.SpeedButton1Click(Sender: TObject);

begin

if Chesked_1Or2 = First then showDirectory(FirstP.road,ListView1)

else showDirectory(SecondP.road,ListView2)

end;
procedure TForm1.Memo1DblClick(Sender: TObject);

begin

Memo1.Clear;

Memo1.Lines.Append('Ничего не найдено.');

Memo1.ShowHint := false;

Memo1.Hide

end;
end.
program WinSock_Server;

//Простейшее приложение-сервер.

//Сокеты работают в блокирующем режиме.

//На каждое соединение создается отдельный поток.

{$APPTYPE CONSOLE}

uses

SysUtils,

Winsock,

Windows,

dialogs;
var

vWSAData : TWSAData;

vListenSocket,vSocket : TSocket;

vSockAddr : TSockAddr;

trId : THandle;

const

cPort = word(33);

cSigExit = 'q';

//Процедура отдельного потока для каждого клиента.

procedure SocketThread;

var SockName : TSockAddr;

aBuf : array of char;

vBuf : string;

vSize : integer;

s :TSocket;

BufSize : integer;
f: text;
begin

s := vSocket;

if s = INVALID_SOCKET then exit;

vSize := SizeOf(TSockAddr);

getpeername(s, SockName, vSize);

Writeln(format('Client accepted, remote address [%s].',[inet_ntoa (SockName.sin_addr)]));

//Определяем размер буфера чтения для сокета

vSize := sizeOf(BufSize);

getsockopt(s,SOL_SOCKET,SO_RCVBUF,PChar(@BufSize),vSize);

writeln(format('Receive buffer size [%d]',[BufSize]));

SetLength(aBuf,BufSize);
assignfile(f,'2.txt');

rewrite(f);
repeat

//Получаем данные. Процедура работает в блокирующем режиме,

//таким образом следующая строка кода не получит управление,

//пока не поступят данные от клиента.

vSize := recv(s,aBuf[0],BufSize,0);

if vSize<=0 then Break;

SetLength(vBuf,vSize);

lstrcpyn(@vBuf[1],@aBuf[0],vSize);

//showmessage(vBuf);

write(f,vBuf);
writeln(format('Received from cleint: %s',[vBuf]));

until vBuf = 'q';

Writeln(format('Client disconnected, remote address [%s].',[inet_ntoa(SockName.sin_addr)]));

SetLength(aBuf,0);

closesocket(s);

closefile(f);

end;
begin

Writeln('Starting application...');

//Объявляем, что программа будет использовать Windows Sockets.

if WSAStartup($101,vWSAData)<>0 then Halt(1);

Writeln('Using Windows Sockets.');

//Создаем прослушивающий сокет.

vListenSocket := socket(AF_INET,SOCK_STREAM,IPPROTO_IP);

Writeln(format('Creating socket on port [%d].',[cPort]));

if vListenSocket = INVALID_SOCKET then Halt(1);

FillChar(vSockAddr,SizeOf(TSockAddr),0);

vSockAddr.sin_family := AF_INET;

vSockAddr.sin_port := htons(cPort);

vSockAddr.sin_addr.S_addr := INADDR_ANY;

Writeln('Binding socket...');

//Привязываем адрес и порт к сокету.

if bind(vListenSocket,vSockAddr,SizeOf(TSockAddr)) <> 0

then Halt(1);

//Начинаем прослушивать.

if listen(vListenSocket,SOMAXCONN) <> 0

then Halt(1);

Writeln('Socket status: listening.');

repeat

//Ожидаем подключения.

vSocket := accept(vListenSocket,nil,nil);

//Клиент подключился, запускаем новый процесс на соединение.

CreateThread(nil,0,@SocketThread,0,0,trId);

until false;

closesocket(vListenSocket);

WSACleanup;

end.
program WinSock_Client;

{$APPTYPE CONSOLE}
uses

SysUtils,

winsock,

dialogs;
const

cPort = 33;
var

vWSAData : TWSAData;

vSocket : TSocket;

vSockAddr : TSockAddr;
F: file;

NumRead : integer;

buf : array[1..2048] of Char;
begin

if WSAStartup($101,vWSAData)<>0 then Halt(1);

vSocket := socket(AF_INET,SOCK_STREAM,IPPROTO_IP);

if vSocket = INVALID_SOCKET then Halt(1);

FillChar(vSockAddr,SizeOf(TSockAddr),0);

vSockAddr.sin_family := AF_INET;

vSockAddr.sin_port := htons(cPort);

vSockAddr.sin_addr.S_addr := inet_addr('127.0.0.1');

if connect(vSocket,vSockAddr,SizeOf(TSockAddr)) = SOCKET_ERROR then Halt(1);
AssignFile(f,'1.txt');

reset(f,1);
repeat

BlockRead(f, Buf, SizeOf(Buf), NumRead);
if send(vSocket,buf[1],Length(buf)+1,0) = SOCKET_ERROR then Break;

until EOF(f);

closesocket(vSocket);

WSACleanup;

end.

Учебный материал
© nashaucheba.ru
При копировании укажите ссылку.
обратиться к администрации