Программа с многоязычным интерфейсом

Для начала немного теории.
Ваша собственная программа может быть полезна не только вам, но и вашим друзьям, организации, где вы работаете. Если вы работаете не только на себя. Живя в нашем веке компьютерных технологий, информация может распространяться с довольно большой скоростью. Примером тому служат нашумевшие недавно волны интернет-вирусов, за считанные дни облетевшие по многим серверам мира. Так же дело и обстоит с полезными программами. Отличием полезной программы от вредоносной есть сам метод переноса от компьютера к компьютеру. По степени ее уникальности и полезности она может понравиться многим. Я не буду говорить о методах рекламы программных продуктов, они такие же самые, как и реклама обычных продуктов, будь то интернет-ресурс или обычных хозяйственный товар. Дело в том, что ваша программа, выпущенная в свободное распространение (выложенная на сайте, отправленная друзьям по почте и т.п.) абсолютно независимо от вашего желания может попасть любому человеку. Этот человек может быть другой национальности, абсолютно не понимающий русского языка.
Если ваша программа изначально рассчитана на свободное распространение, свободное распространение с ограниченными функциями для последующего приобретения, если ваша программа может оказаться полезной для многих (утилита, игра, экранная заставка), то надо стараться изначально ее оформлять с англоязычным интерфейсом. Все дело в том, что большинство пользователей компьютеров в полной мере или частично знакомы с английским языком. Следовательно, разобраться в такой вашей программе смогут больше человек в мире, чем, скажем в программе с белорусским языковым интерфейсом. Здесь имеется в виду ни что иное, как глобальное внедрение вашего приложения в масштабе целой планеты, а не касательно, скажем, ваших знакомых. Но делая программу, даже с языком, являющимся международным (даже с китайским языком :), трудно рассчитывать на популярность во многих странах.

Большую популярность получили программы с многоязычным интерфейсом. Я имею в виду, что описанные выше программы получают большую популярность, чем аналогичные с однотипным диалоговым языком. К примеру, это некоторые командные оболочки (FAR, Windows Commander), антивирус DrWeb, интернет броузер Opera. В таких программах нужный язык можно выбрать из списка в окнах настройки.

В большинстве случаев, весь языковой интерфейс хранится в отдельном файле. И это правильно. Не стоит загромождать исполняемый EXE файл излишком информации, а настройка и адаптация нового языка, первоначально не включенного в такой программный пакет, происходит быстро и без перекомпиляции всего проекта.

Какой же метод выбрать для хранения и последующего считывания данных из файла языков. В большей степени для этого подходит ini файлы. Такие файлы легко переносятся на другой компьютер вместе с самой программой, возможно редактировать из любого текстового редактора, изменить текст может любой человек.
Различные секции в таком ini-файле будут хранить в себе отдельные языковые интерфейсы. Например, секция

будет озаглавливать русскоязычный внешний вид программы,
[ENGLISH]
- англоязычный, и т.д. Я думаю, что с этим проблем у пользователя не будет.
Названия хранимых параметров состоят из названия окна (формы), в котором находится компонент плюс название самого компонента. Параметр должен состоять из одного слова. Хранимая величина - текст, который отображается на экране на этом компоненте. Это может быть свойство Caption или свойство Text, в зависимости от типа (класс) компонента. Например, для компонента Button1, находящегося в окне Form1 записываемый параметр и значение выглядит:
Form1Button1=Кнопка1
В нашей программе при чтении такого параметра должна произойти замена:


[DELPHI]Form1.Button1.Caption := 'Кнопка1';  

Естественно, это делается автоматически для всех визуальных компонентов, на каких есть текст. Проблема может состоять в том, что таких компонентов на каждой форме может быть, скажем 200. Тогда это очень загромоздит программный код. При оперативном исправлении такой программы (добавление, удаление компонентов), необходимо будет исправлять и эту часть кода. Выходом из создавшейся проблемы может быть свойства для определенного окна ComponentCount и Components. Свойство Components позволяет через массив получить доступ к любому элементу управления формы. Свойтсво ComponentCount показывает, сколько этих элементов управления (компонентов) у нас присутствует в окне. Нам нужно будет просто организовать цикл от 1 до ComponentsCount и для каждого компонента прочитать соответствующее значение Caption или Text из INI файла.
Внутри такого цикла нужно определять тип компонента. Ведь для кнопки (Button, BitBtn, SpeedButton), метки (Label, StaticText), флажка (CheckBox, RadioButton) и пр. свойство Caption определяет текст, который будет виден на этом компоненте. Для Edit, Memo, ComboBox и пр. свойтсво Text. Следовательно, очень важно верно определить тип, выбранного из цикла компонента, чтобы в последствии правильно занести соответствующее значение в соответствующее свойство.
Следующим этапом, когда мы определили тип компонента, следует само чтение данных из ini-файла. Вот примерный кусок кода такой программы:


if ComponentCount<>0 then // если в окне есть хотя бы один элемент управления (компонент)  
   for i:=1 to ComponentCount do // цикл от 1 до кол-ва компонентов  
      if Components[i-1].ClassType = TButton then // если текущий элемент является элементом класса TButton, то  
            (Components[i-1] as TButton).Caption:= ЧТЕНИЕ_ДАННЫХ_ИЗ_INI  

Разъясню последнюю строчку из этого примера. Через


(Components[i-1] as TButton)  

Мы получаем доступ к свойствам компонента, представляя его к классу TButton. Для этого в предпоследней строке примера мы и производим проверку класса выбранного циклом компонента. Если такую проверку не производить, то во время выполнения программы при обращении, скажем к компоненту класса TEdit к свойству Caption, появится сообщение об ошибке (У TEdit свойство Text!).
(i-1) как вы наверное уже догадались, список массива элементов управления формы начинается с нуля. А заканчивается ComponentCount-1.

Еще один нюанс. Если такой многоязычный ini-файл был потерян в процессе эксплуатации, то пользователя рискует остаться вообще без каких либо намеков в вашей программе. Поэтому рекомендую все-таки изначально давать текст вашим компонентам как в обычной программе. В случае невозможности чтения данных из INI файла текст на этих компонентах останется нетронутым.

Теперь я даю вам универсальный модуль, который должен присутствовать в каждом оконном модуле вашей программы, где необходимо менять язык по указанию пользователя. Я являюсь автором этого куска программы, поэтому, возможно, что-то можно и сократить, тем не менее...

В раздел Uses необходимо дописать модуль для работы с ini-файлами:


Uses IniFiles;  

Раздел public дописываем одну строку объявления процедуры:


public  
   { Public declarations }  
   procedure ChangeLang(LangSection:string);  

Сама процедура пишется изначально вручную вместе с заголовком:


procedure TForm1.ChangeLang(LangSection:string);  
Var i:Integer; // временная числовая переменная для выборки всех компонентов  
    LangIniFile:TIniFile;  
    ProgramPath:String; // строковая переменная для получения каталога, где находится запущенный EXE файл  
begin  
if ComponentCount<>0 then // если в окне больше одного компонента  
   begin  
      ProgramPath:=ExtractFileDir(Application.ExeName); // получаем каталог, где лежит запущенный EXE файл  
      if ProgramPath[Length(ProgramPath)]<>'\' then ProgramPath:=ProgramPath+'\'; // гарантированно устанавливаем последний символ '\' в конце строки  
      LangIniFile:=TIniFile.Create(ProgramPath+'lang.ini'); // подготавливаем INI файл. Он должен иметь название lang.ini и должен находиться в каталоге программы  
      Caption:=LangIniFile.ReadString(LangSection,Name,Caption); // читаем заголовок окна  
      for i:=1 to ComponentCount do // перебираем все компоненты в этом окне  
         begin  
            if Components[i-1].ClassType=TButton then // если выбран из массива компонент Button, то изменяем текст на кнопке  
               (Components[i-1] as TButton).Caption := LangIniFile.ReadString(LangSection, Name+Components[i-1].Name, (Components[i-1] as TButton).Caption);  
// Напомню описание функции ReadString:  
// LangIniFile.ReadString( СЕКЦИЯ, ПАРАМЕТР, ЗНАЧЕНИЕ_ПО_УМОЛЧАНИЮ );  
// 1. LangSection - передаваемый параметр в процедуру. В процедуру передается название секции для выбранного языка  
// 2. Name+Components[i-1].Name - Name - название формы, Components[i-1].Name - название компонента  
// 3. (Components[i-1] as TButton).Caption - в случае неудачного чтения этого параметра из ini файла (нет такого параметра), то ничего меняться не будет  
// аналогично для других типов:  
            if Components[i-1].ClassType=TLabel then  
               (Components[i-1] as TLabel).Caption := LangIniFile.ReadString(LangSection, Name+Components[i-1].Name, (Components[i-1] as TLabel).Caption);  
            if Components[i-1].ClassType=TEdit then  
               (Components[i-1] as TEdit).Text := LangIniFile.ReadString(LangSection, Name+Components[i-1].Name, (Components[i-1] as TEdit).Text);  
            // ...  
            // ...  
            // ...  
         end;  
      LangIniFile.Free; // освобождаем ресурс  
   end;  
end;  

Обратите внимание, в программе два окна. В каждом модуле для каждого отдельного окна присутствует эта вышеописанная процедура.

Вместо строк // ... вы можете добавлять другие типы компонентов, например, можете описать тип компонента TCheckBox, если таковой имеет место в вашей программе. В идеале описывайте по шаблону все или большинство типов компонентов, имеющиеся в наличие в delphi. Для этого вам понадобится несколько десятков строк программного кода, но зато вы гарантированно можете применять эту процедуру не только в одной вашей программе, не проверяя наличие всех используемых типов компонентов.

Напомню, аналогичную вышеприведенную процедуру, без изменений, вы должны вписать в каждый модуль вашей программы. При смене языка, например, в программе с тремя окнами (Form1, Form2, Form3) происходит следующим куском программного кода:


Form1.ChangeLang('RUSSIAN');  
Form2.ChangeLang('RUSSIAN');  
Form3.ChangeLang('RUSSIAN');  

Поскольку процедуру смена языка мы объявляем в разделе public, то доступ к этой процедуре мы можем получить из любого места программы. Как вы заметили из примера, для переключения на русский язык указана имя секции RUSSIAN.

Теперь рассмотрим содержание самого INI файла. Его вы должны создавать самостоятельно. Во-первых, нужно помнить правила орфографии windows ini-файла, во-вторых, названия параметров должны соответствовать имени формы плюс названия компонента, хранимое значение следует за знаком равенства. Для примера, ini-файл с двумя языками, с двумя окнами, на каждом окне находится по две кнопки.


; начало файла lang.ini  
[RUSSIAN]  
Form1Button1=Кнопка 1 на форме 1  
Form1Button2=Кнопка 2 на форме 1  
Form2Button1=Кнопка 1 на форме 2  
Form2Button2=Кнопка 2 на форме 2  
  
[ENGLISH]  
Form1Button1=Button 1 on form 1  
Form1Button2=Button 2 on form 1  
Form2Button1=Button 1 on form 2  
Form2Button2=Button 2 on form 2  
; конец файла lang.ini  

Кроме текста на визуальных элементах управления вашей программы, текст содержится еще в заголовке программы, в панели задач. Еще могут присутствовать всплывающие подсказки Hint. Полномасштабный перевод всех компонентов на несколько языков в ini файле может несколько затруднить сам процесс программирования. Но ради гибкости настройки интерфейса программы пожертвовуйте лишним временем. Ведь для изменения текста, добавления нового языка (возможно даже это делаете не вы) не нужно перекомпилировать проект. Это максимально упрощает языковую настройку. Можете вообще сделать ini-файл одноязычным. Перевести его можете после окончания проектирования, или вообще предоставьте это профессиональному переводчику.

Одним из слабых мест в такой программе есть необходимость помещать процедуру смены языка в каждый модуль. Если у вас в программе множество окон, это довольно сильно загромождает программный код, следовательно, увеличивает размер программы, следовательно, замедляет ее работу. Как же сделать так, чтобы весь процесс смены языка во всем приложении умещался с одной процедуре. Очень просто. А может и не просто. А в общем, через компонент Application. Он является по своей сути самой программой, значит, содержит в себе все компоненты форм (уже упоминалось в первых уроках, что сама форма и есть компонент). Таким образом:


if Application.ComponentCount<>0 then // если в приложении есть компоненты форм (не консольное приложение)  
   for i:=1 to Application.ComponentCount do // перебираем все компоненты  
      if Application.Components[i-1].ClassParent=TForm then // если выбранный компонент является подклассом окна, то  
         begin  
            // обработка переключения языка для этого окна  
         end;  

Очень похоже на предыдущий пример...
Извините, что на первый взгляд эта тема урока кажется, немного сложноватой для начинающего, но тут важно разобраться в общих принципах, в нескольких свойствах, внимательно перечитать весь урок снова и все может стать понятным.

Опять ищем слабые места в программе. Для начинающих программистов может быть новостью, что в одной программе не может быть двух и более окон с одинаковыми названиями. А как же дело обстоит с MDI приложениями. Дочернее окно проектируется в единственном варианте, а в внутри родительской формы, во время работы программы, оно может создаваться теоретически в неограниченном количестве. Имена же самой вновь создаваемой дочерней форме присваиваются системой автоматически. Следовательно, читать параметр из ini-файла по свойству Name не подойдет. Таким методом можно максимально прочитать язык для компонентов только для одного дочернего MDI-окна. Отсюда следует, что нужно читать данные согласно свойству ClassName, которое является уникальным для отдельного класса окна. Например, для окна Form1, являющегося главным MDI-окном такой класс TForm1. Для окна Form2, дочернего MDI-окна класс TForm2. Вот, вы наконец и узнали, что же это за такая туква Т, стоящая в начале названия компонента. Это надкласс, объединяющий однотипные компоненты (в том числе и окно программы) в единую группу, с одинаковыми вложенными свойствами. Это краткое описание, можно сказать, своими словами.

Эти все "наваяния" организованы во втором примере. Там смена языка происходит из одной процедуры абсолютно для всех окон. Тем самым мы уменьшили программный код за счет увеличения качества, увеличили количество вложенных циклов. Программа примера номер 2 является незаконченным каркасом MDI-приложения. Не удивляйтесь, почему программа не выполняет функции редактора.

Добавлено: 07 Августа 2018 07:27:48 Добавил: Андрей Ковальчук

Примеры использования Drag and Drop для различных визуальных компонентов

Перетаскивание информации с помощью мыши стало стандартом для программ, работающих в Windows. Часто это бывает удобно и позволяет добиться более быстрой работы. В данной статье я постарался показать максимальное количество примеров использования данной технологии при разработке приложений в среде Delphi. Конечно, результат может быть достигнут различными путями, продемонстрированные приемы не являются единственными и, возможно, не всегда самые оптимальные, но вполне работоспособны, и указывают направление поиска. Надеюсь, что они побудят начинающих программистов к более широкому использованию Drag'n'Drop в своих программах, тем более что пользователи, особенно неопытные, быстро привыкают к перетаскивание и часто его применяют.

Проще всего делать Drag из тех компонентов, для которых однозначно ясно, что именно перетаскивать. Для этого устанавливаем у источника DragMode = dmAutomatic, а у приемника пишем обработчики событий OnDragOver - разрешение на прием, и OnDragDrop - действия, производимые при окончании перетаскивания.


procedure TForm1.StringGrid2DragOver(Sender, Source: TObject; X,  
  Y: Integer; State: TDragState; var Accept: Boolean);  
begin  
  Accept := Source = Edit1;  
  // разрешено перетаскивание только из Edit1,  
  // при работе программы меняется курсор  
end;  
  
procedure TForm1.StringGrid2DragDrop(Sender, Source: TObject; X,  
  Y: Integer);  
var  
  ACol, ARow: Integer;  
begin  
  StringGrid2.MouseToCell( X, Y, ACol, ARow);  
// находим, над какой ячейкой произвели Drop  
  StringGrid2.Cells[ Acol, Arow] := Edit1.Text;  
//  записываем в нее содержимое Edit1  
end;  

Теперь рассмотрим копирование в упорядоченный список ListBox1 из другого списка. В OnDragOver проверяем, выбран ли хоть один элемент в источнике:


Accept := (Source = ListBox2) and (ListBox2.ItemIndex >= 0);  

В OnDragDrop ищем отмеченные в источнике строки (установлен множественный выбор) и добавляем только те, которых еще нет в приемнике:


for i := 0 to ListBox2.Items.Count - 1 do  
  if (ListBox2.Selected[i]) and (ListBox1.Items.IndexOf(ListBox2.Items[i])<0)  
    then  
      ListBox1.Items.Add(ListBox2.Items[i]);  

Для ListBox2 реализуем перенос строк из ListBox1 и перестановку элементов в желаемом порядке. В OnDragOver разрешаем Drag из любого ListBox:


Accept := (Source is TListBox) and ((Source as TListBox).ItemIndex >= 0);  

А OnDragDrop будет выглядеть так:


var  
  s: string;  
begin  
  if Source = ListBox1 then  
  begin  
    ListBox2.Items.Add(ListBox1.Items[ListBox1.ItemIndex]);  
    ListBox1.Items.Delete(ListBox1.ItemIndex);  
  //удаляем перенесенный элемент  
  end  
  else          //внутренняя перестановка  
  begin  
    s := ListBox2.Items[ListBox2.ItemIndex];  
    ListBox2.Items.Delete(ListBox2.ItemIndex);  
    ListBox2.Items.Insert(ListBox2.ItemAtPos(Point(X, Y), False), s);  
  //находим, в какую позицию переносить и вставляем  
  end;  
end;  

Научимся переносить текст в Memo, вставляя его в нужное место. Поскольку я выбрал в качестве источника любой из ListBox, подключим в Инспекторе Объектов для OnDragOver уже написанный ранее обработчик ListBox2DragOver, а в OnDragDrop напишем


if not CheckBox1.Checked then  // при включении добавляется в конец текста  
begin  
 Memo1.SelStart := LoWord(Memo1.Perform(EM_CHARFROMPOS, 0, MakeLParam(X,Y)));  
    // устанавливаем позицию вставки согласно координатам мыши  
 Memo1.SelText := TListBox(Source).Items[TListBox(Source).ItemIndex];  
end  
  else  
    memo1.lines.add(TListBox(Source).Items[TListBox(Source).ItemIndex]);  

Замечу, что для RichEdit EM_CHARFROMPOS работает несколько иначе, что продемонстрировано в следующем примере. Перенос из Memo реализован с помощью правой кнопки мыши, для того, чтобы не изменять стандартное поведение Memo, и поскольку нажатие левой кнопки снимает выделение. Для Memo1 установлено DragMode = dmManual, а перетаскивание инициируется в OnMouseDown


if (Button = mbRight) and (Memo1.SelLength > 0) then  
    Memo1.BeginDrag(True);  

Обработчик RichEdit1DragOver очевиден, а в RichEdit1DragDrop пишем


var  
  p: tpoint;  
begin  
  if not CheckBox1.Checked then  
  begin  
    p := point(x, y);  
    RichEdit1.SelStart := RichEdit1.Perform(EM_CHARFROMPOS, 0, Integer(@P));  
    RichEdit1.SelText := Memo1.SelText;  
  end  
  else  
    RichEdit1.Lines.Add(Memo1.SelText);  
end;  

Рассмотрим теперь перетаскивание в ListView1 (ViewStyle = vsReport). В OnDragOver разрешим прием из ListBox2 и из себя же:


Accept := ((Source = ListBox2) and (ListBox2.ItemIndex >= 0)) or  
  (Source = Sender);  

А вот OnDragDrop теперь будет посложнее


var  
  Item, CurItem: TListItem;  
begin  
  if Source = ListBox2 then  
  begin  
    Item := ListView1.DropTarget;  
    if Item <> nil then  
    //  случай перетаскивания на Caption  
      if Item.SubItems.Count = 0 then  
        Item.SubItems.Add(ListBox2.Items[ListBox2.ItemIndex])  
    //  добавляем SubItem, если их еще нет  
      else  
        Item.SubItems[0]:=ListBox2.Items[ListBox2.ItemIndex]  
    //  иначе заменяем имеющийся SubItem  
    else  
    begin  
   // при перетаскивании на пустое место создаем новый элемент  
      Item := ListView1.Items.Add;  
      Item.Caption := ListBox2.Items[ListBox2.ItemIndex];  
    end;  
  end  
  
  else // случай внутренней перестановки  
  begin  
    CurItem := ListView1.Selected;  
// запомним выбранный элемент  
    Item := ListView1.GetItemAt(x, y);  
// другой метод определения элемента на который делаем Drop  
    if Item <> nil then  
      Item := ListView1.Items.Insert(Item.Index)  
// вставляем новый элемент перед найденным  
    else  
      Item := ListView1.Items.Add;  
// или добавляем новый элемент в конец  
    Item.Assign(CurItem);  
// копируем исходный в новый  
    CurItem.Free;  
// уничтожаем исходный  
  end;  
end;  

Для ListView2 установим ViewStyle = vsSmallIcon и покажем, как вручную расставлять значки. В OnDragOver зададим условие


Accept := (Sender = Source) and  
    ([htOnLabel,htOnItem, htOnIcon] * ListView2.GetHitTestInfoAt(x, y) = []);   
// пересечение множеств должно быть пустым - запрещаем накладывать элементы  

а код в OnDragDrop очень простой:


ListView2.Selected.SetPosition(Point(X,Y));  

Перетаскивание в TreeView - довольно любопытная тема, здесь порой приходится разрабатывать алгоритмы обхода ветвей для достижения желаемого поведения. Для TreeView1 разрешим перестановку своих узлов в другое положение. В OnDragOver проверим, не происходит ли перетаскивание узла на свой же дочерний во избежание бесконечной рекурсии:


var  
  Node, SelNode: TTreeNode;  
begin  
  Node := TreeView1.GetNodeAt(x, y);  
// находим узел-приемник  
  Accept := (Sender = Source) and (Node <> nil);  
  if not Accept then  
    Exit;  
  SelNode := Treeview1.Selected;  
  while (Node.Parent <> nil) and (Node <> SelNode) do  
  begin  
    Node := Node.Parent;  
    if Node = SelNode then  
      Accept := False;  
  end;  

Код OnDragDrop выглядит так:


var  
  Node, SelNode: TTreeNode;  
begin  
  Node := TreeView1.GetNodeAt(X, Y);  
  if Node = nil then  
    Exit;  
  SelNode := TreeView1.Selected;  
  SelNode.MoveTo(Node, naAddChild);  
// все уже встроено в TreeView  
end;  

Теперь разрешим перенос в TreeView2 из TreeView1


Accept := (Source = TreeView1) and (TreeView2.GetNodeAt(x, y) <> nil);  

И в OnDragDrop копируем выбранную в TreeView1 ветвь во всеми подветвями, для чего придется сделать рекурсивный обход:


var  
  Node: TTreeNode;  
  
  procedure CopyNode(FromNode, ToNode: TTreeNode);  
  var  
    TempNode: TTreeNode;  
    i: integer;  
  begin  
    TempNode := TreeView2.Items.AddChild(ToNode, '');  
    TempNode.Assign(FromNode);  
    for i := 0 to FromNode.Count - 1 do  
      CopyNode(FromNode.Item[i], TempNode);  
  end;  
  
begin  
  Node := TreeView2.GetNodeAt(X, Y);  
  if Node = nil then  
    Exit;  
  CopyNode(TreeView1.Selected, Node);  
end;  

Рассмотрим теперь перенос ячеек в StringGrid1. Поскольку, как и в случае с Memo, простое нажатие левой кнопки занято под другие действия, установим DragMode = dmManual и будем запускать Drag при нажатии левой кнопки, удерживая клавиши Alt или Ctrl. Запишем в OnMouseDown:


var  
  Acol, ARow: Integer;  
begin  
  with StringGrid1 do  
    if (ssAlt in Shift) or (ssCtrl in Shift) then  
    begin  
      MouseToCell(X, Y, Acol, Arow);  
      if (Acol >= FixedCols) and (Arow >= FixedRows) then  
// не будем перетаскивать из фиксированных ячеек  
      begin  
        if ssAlt in Shift then  
          Tag := 1  
        else  
          if ssCtrl in Shift then  
            Tag := 2;  
// запомним что нажато - Alt или Ctrl -  в Tag StringGrid1  
        BeginDrag(True)  
      end  
      else  
        Tag := 0;  
    end;  
end;  

Код OnDragOver учитывает также возможность перетаскивания из StringGrid2 (описание ниже)


var  
  Acol, ARow: Integer;  
begin  
  with StringGrid1 do  
  begin  
    MouseToCell(X, Y, Acol, Arow);  
    Accept := (Acol >= FixedCols) and (Arow >= FixedRows)  
      and (((Source = StringGrid1) and (Tag > 0))  
      or (Source = StringGrid2));  
  end;  
Часть OnDragDrop, относящаяся к внутреннему переносу:


var  
  ACol, ARow, c, r: Integer;  
  GR: TGridRect;  
begin  
  StringGrid1.MouseToCell(X, Y, ACol, ARow);  
  if Source = StringGrid1 then  
    with StringGrid1 do  
    begin  
      Cells[Acol, Arow] := Cells[Col,Row];  
//копируем ячейку-источник в приемник  
      if Tag = 1 then  
        Cells[Col,Row] := '';  
// очищаем источник, если было нажато Alt  
      Tag := 0;  
    end;  

А вот из StringGrid2 сделаем перенос выбранного диапазона ячеек с помощью правой кнопки, для этого в OnMouseDown


if Button = mbRight then  
    StringGrid2.BeginDrag(True);  

И теперь часть StringGrid1DragDrop, относящаяся к переносу из StringGrid2:


if Source = StringGrid2 then  
  begin  
    GR := StringGrid2.Selection;  
// Selection - выделенные в StringGrid2 ячейки  
    for r := 0 to GR.Bottom - GR.Top do  
      for c := 0 to GR.Right - GR.Left do  
        if (ACol + c < StringGrid1.ColCount) and  
          (ARow + r < StringGrid1.RowCount) then  
// застрахуемся от записи вне StringGrid1  
          StringGrid1.Cells[ACol + c, ARow + r] :=  
            StringGrid2.Cells[c + GR.Left, r + GR.Top];  
  end;  

Теперь покажем, как этот диапазон ячеек из StringGrid2 перенести в Memo2. Для этого в OnDragOver Memo2 пишем:


Accept := (Source = StringGrid2) or (Source = DBGrid1);  

и в OnDragDrop Memo2:


var  
  c, r: integer;  
  s: string;  
begin  
  Memo2.Clear;  
  if Source = StringGrid2 then  
    with StringGrid2 do  
      for r := Selection.Top to Selection.Bottom do  
      begin  
        s := '';  
        for c := Selection.Left to Selection.Right do  
          s := s + Cells[c, r] + #9;  
// разделим ячейки табуляцией  
        memo2.lines.add(s);  
      end  

Кроме того, в Memo2 можно переносить выбранную запись из DBGrid1, у которого установлено в Options dgRowSelect = True. В сетке отображается таблица из стандартной поставки Delphi DBDEMOS - Animals.dbf. Перетаскивание осуществляется аналогично StringGrid2, правой кнопкой мыши, только по событию OnMouseMove


if ssRight in Shift then  
    DBGrid1.BeginDrag(true);  

Код в Memo2DragDrop, относящийся к переносу из DBGrid1:


else  
    with DBGrid1.DataSource.DataSet do  
    begin  
      s := '';  
      for c := 0 to FieldCount - 1 do  
        s := s + Fields[c].AsString + ' | ';  
      memo2.lines.add(s);  
    end;  
// в случае dgRowSelect = False для переноса одного поля достаточно сд
елать
// memo2.lines.add(DbGrid1.SelectedField.AsString);
Drag из DBGrid1 принимается также на Panel3, условие приема очевидно, а OnDragDrop выглядит так:


  Panel3.Height := 300;  // раскрываем панель  
  Image1.visible := True;  
  OleContainer1.Visible := false;  
  Image1.Picture.Assign(DBGrid1.DataSource.DataSet.FieldByName('BMP'));  
// показываем графическое поле текущей записи таблицы  

Теперь покажу, как можно передвигать мышью визуальные компоненты в Run-Time. Для Panel1 установим DragMode = dmAutomatic, в OnDragOver формы пишем:


var  
  Ct: TControl;  
begin  
  Ct := ControlAtPos(Point(X + Panel1.Width, Y + Panel1.Height), True, True);  
// для упрощения проверяем перекрытие с другими контролами только правого нижнего угла  
  Accept := (Source = Panel1) and ((Ct = nil) or (Ct = Panel1));  

и в OnDragDrop формы очень просто


Panel1.Left := X;  
Panel1.Top := Y;  

Другой метод перетаскивания можно встретить в каждом FAQ по Delphi:


procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton;  
  Shift: TShiftState; X, Y: Integer);  
const  
  SC_DragMove = $F012;  
begin  
  ReleaseCapture;  
  Panel2.Perform(WM_SysCommand, SC_DragMove, 0);  
end;  

И в завершение реализация популярной задачи перетаскивания значков файлов на форму из Проводника. Для этого следует описать обработчик сообщения WM_DROPFILES


private  
 procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;  

В OnCreate формы разрешить прием файлов


DragAcceptFiles(Handle, true);  

и в OnDestroy отключить его


DragAcceptFiles(Handle, False);  

Процедура обработки приема файлов может выглядеть так:


procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);  
const  
  maxlen = 254;  
var  
  h: THandle;  
  //i,num:integer;  
  pchr: array[0..maxlen] of char;  
  fname: string;  
begin  
  h := Msg.Drop;  
  
  // дана реализация для одного файла, а   
  //если предполагается принимать группу файлов, то можно добавить:  
  //num:=DragQueryFile(h,Dword(-1),nil,0);  
  //for i:=0 to num-1 do begin  
  //  DragQueryFile(h,i,pchr,maxlen);  
  //...обработка каждого  
  //end;  
  
  DragQueryFile(h, 0, pchr, maxlen);  
  fname := string(pchr);  
  if lowercase(extractfileext(fname)) = '.bmp' then  
  begin  
    Image1.visible := True;  
    OleContainer1.Visible := false;  
    image1.Picture.LoadFromFile(fname);  
    Panel3.Height := 300;  
  end  
  else if lowercase(extractfileext(fname)) = '.doc' then  
  begin  
    Image1.visible := False;  
    OleContainer1.Visible := True;  
    OleContainer1.CreateObjectFromFile(fname, false);  
    Panel3.Height := 300;  
  end  
  else if lowercase(extractfileext(fname)) = '.htm' then  
    ShellExecute(0, nil, pchr, nil, nil, 0)  
  else if lowercase(extractfileext(fname)) = '.txt' then  
    Memo2.Lines.LoadFromFile(fname)  
  else  
    Memo2.Lines.Add(fname);  
  DragFinish(h);  
end;  

При перетаскивании на форму файла с расширением Bmp он отображается в Image1, находящемся на Panel3, Doc загружается в OleContainer, для Htm запускается Internet Explorer или другой браузер по умолчанию, Txt отображается в Memo2, а для остальных файлов в Memo2 будет просто показано имя.

Полагаю, на основе содержащихся в статье приемов будет нетрудно организовать перетаскивание и для других, не описанных здесь, визуальных компонентов.

В заключение хочу выразить благодарность Игорю Шевченко и Максиму Власову за ценные советы при подготовке примеров.

Добавлено: 07 Августа 2018 07:25:40 Добавил: Андрей Ковальчук

Создание калькулятора с командной строкой в Delphi

Введение
Если Вы хотели написать калькулятор с командной строкой, но не знали, как это сделать, или просто не собрались духом, то эта статья для Вас.

Для начала предлагаю немного теории.

В рамках данной статьи я рассмотрю только написание функции для расчета значения из строки. Я считаю, что написание формы с кнопками доступно для всех, кто взялся читать эту статью.

Для начала представим себе простейший вариант строки:

1*2+3*4

Если быть совсем честным, это нужно делать через стеки, но поскольку не все знают что это такое, я предлагаю сделать через стандартный класс TStringList. Для расчета такой строки нам нужно создать два экземпляра класса TStringList. В одном мы будем хранить числа, а в другом знаки операций.

Вот что у нас получилось. Пройдемся по строке, как только мы нашли число, добавляем его в первый список. А если мы нашли знак операции, добавляем его во второй список.

Далее Вы спросите: «А зачем, собственно, мы это делали?». Так просто очень легко считать.

Привожу алгоритм подсчета значения строки, разделенной таким способом на два списка.

Ищем во втором списке операции, приоритет которых выше. То есть, знаки умножения или деления.
Если нашли, то вынимаем этот знак. Вынимаем из первого списка число с таким же номером, как и у знака, и следующее. Это и будут наши операнды. Выполняем с ними соответствующее действие, и записываем результат в первый список на то место, с которого выдернули первый операнд.
Повторяем пункты 1 и 2 до тех пор, пока во втором списке не останется ни одного такого знака.
Повторяем пункты 1-3 со знаками сложения и вычитания.
А теперь давайте прогоним через этот алгоритм наш пример.

Ищем в правом столбце знак умножения или деления. Нашли – он стоит на первой позиции. Далее нам нужны числа, которые надо умножить. Они стоят во втором списке под номерами 1, и 1+1, то есть 2. В нашем примере это цифры 1 и 2. Вынимаем их из списка и умножаем. Получилась двойка. Записываем её в первый список на то место, откуда выдернули первый операнд, в нашем случае на первое место. И удаляем из второго списка знак умножения. Вот что должно получиться:

2.Далее продолжаем искать знаки умножения или деления. Нашли. Знак умножения стоит на второй позиции. Нам опять же нужны операнды. Они находятся на втором и третьем месте в первом списке. Это цифры 3 и 4. Умножаем их и удаляем из первого списка. Результат, число 12, заносим в первый список под номером 2.

На этом знаки умножения и деления у нас закончились, займемся поисками знаков сложения и вычитания. В нашем случае есть знак умножения, стоящий на первом месте. Выбираем из первого списка то, что будем складывать (это элементы под номерами 1 и два), удаляем их из списка, а результат сложения заносим обратно в список. У нас получилось следующее:



Так как список операций пуст, то мы выполнили все действия, а результатом является число, оставшееся в списке чисел.
Как Вы видите, на данном этапе все довольно легко. Давайте теперь напишем функцию, которая вычисляет значение уже разделенной строки. В качестве параметра у неё будут два списка: список чисел и список операций. Вот полный код этой функции. Я думаю, в ней нет ничего сложного. А если Вы дочитали до этого момента, то алгоритм Вам уже ясен.


function CalculateLists (s1, s2: TStringList): real;  
var  
    i: integer;  
    a,b,r1: real;  
    c: char;  
begin  
 r1 := 0;  
// Ищем знаки  умножения или деления  
i := 0;  
if s2.Count>0 then  
while (s2.Find('*', i)or(s2.Find('/', i))) do  
begin  
  c := s2[i][1];  
  a := strtofloat(s1[i]);  
  b := strtofloat(s1[i+1]);  
  case c of  
   '*': r1 := a*b;  
   '/': r1 := a/b;  
  end;  
  s1.Delete(i);  
  s1.Delete(i);  
  s1.Insert(i, floattostr(r1));  
  s2.Delete(i);  
end;  
// Сложение и вычитание ///  
if s2.Count>0 then  
repeat  
    c := s2[0][1];  
    a := strtofloat(s1[0]);  
    b := strtofloat(s1[1]);  
    case c of  
     '+': r1 := a+b;  
     '-': r1 := a-b;  
    end;  
    s1.Delete(0);  
    s1.Delete(0);  
    s1.Insert(0, floattostr(r1));  
    s2.Delete(0);  
    if s1.Count = 1 then break;  
    if s2.Count = 0 then break;  
until false;  
 result := strtofloat(s1[0]);  
end;  

Сразу хочу заметить, что элементы TStringList имеют строковый тип. Поэтому приходится преобразовывать типы туда сюда.

Ну а теперь давайте займемся самой сложной частью всего задания: разделение строки на два списка. Давайте, прежде чем включать Delphi и начинать лупить клавиатуру, немного разберемся, чего мы от этой функции хотим. Главная её задача состоит в том, чтобы корректно разделить строку на два списка и передать эти списки на вычисление функции CalculateLists, которую мы только что написали. А что, если мы наткнемся на неверный символ? Для того, чтобы в Вашей основной программе Вы смогли верно определить какая произошла ошибка и на каком символе, я предлагаю создать свой класс-исключение. И возбуждать это исключение при каждой ошибке обработки строки. Этот класс самый простой, просто чтобы не загромождать проект. Вы можете изменить его по Вашему желанию.


type ECalcError = class (Exception)  
end;  

Пойдем дальше. Давайте добавим еще возможность написания функций. Для определения функций давайте создадим два массива. В одном мы будем хранить строковые представления функций, а в другом ссылки на реальные функции. Так же для облегчения процесса редактирования предлагаю создать константу, которая будет отвечать за количество поддерживаемых функций. Также, для описания массива реальных функций, нам понадобиться тип-функция. А для облегчения поиска цифр и знаков операций создадим два множества.


const Sign: set of char = ['+', '-', '*', '/'];  
var Digits: set of char = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];  
type TFunc = function (x: real): real;  
const MaxFunctionID = 2; // - Количество обрабатываемых функций  

Так как использовать ссылки на стандартные процедуры нельзя, или я просто не знаю как. Поэтому нам придется переопределить парочку функций.


function _sin(x: real):real;  
begin  
 result := sin(x);  
end;  
function _cos(x: real):real;  
begin  
 result := cos(x);  
end;  

А теперь можно и определять два массива функций:


const sfunc: array [1..MaxFunctionID] of string[7]= ('sin', 'cos');  
const ffunc: array [1..MaxFunctionID] of TFunc = (_sin, _cos);  

А теперь, для правильной работы с такими массивами я предлагаю написать парочку функций:

Для нахождения функции
Для подсчета значения функции.
Напишем функцию, для проверки, есть ли в строке поддерживаемая функция. Я считаю, что она довольно простая, поэтому сразу приведу её код:


function GetFunction (Line: string; index: integer): integer;  
var i: integer;  
begin  
 for i:= 1 to MaxFunctionID do  
  if sfunc[i] = copy(Line, index, length(sfunc[i])) then  
   begin  
    result := i;  
    exit;  
   end;  
 result := 0;  
end;  

Как Вы видите, функция получает строку, и индекс символа, в котором возможно появление функции. Если наша функция определила, что в строке иметься поддерживаемая математическая функция, то она возвращает её номер, а если таковой нет, то возвращает ноль.

Функция для подсчета значения выглядит еще проще:


function CalculateFunction (Fid: integer; x: real): real;  
begin  
 result := ffunc[Fid](x);  
end;  

Я предлагаю написать еще одну простенькую функция, которая после облегчит нам жизнь. Она будет считать длину строкового написания математической функции.


function GetFunctionNameLength (Fid: integer): integer;  
begin  
 result := length (sfunc[Fid]);  
end;  

Вот мы и закончили писать подготовительные функции. Давайте разберем примерный алгоритм функции разбора строки. Мы будем просматривать строку по символам. Если очередной символ есть цифра, то заносим эту цифру в строку-число. Если символ – знак операции, то записываем в список операций эту операцию, и записываем строку-число в список чисел. Если нам попалась открывающая скобка, то мы должны найти её закрывающую, независимо есть ли в этих скобках вложенные скобки и передать строку, которая находиться в этих скобках функции разделения строк, и записать в массив чисел то, что она вернет. Этот пример называется рекурсией. Идем дальше, если мы нашли символ, не являющийся скобкой, цифрой или знаком операции. Это должно быть функция. Вот здесь нам и пригодится функция для проверки, начинается ли с этой позиции поддерживаемая функция. Если да, то ищем после записи этой функции открывающую скобку, так как параметр любой функции должен идти в скобках. Если скобки нет, то можно вызвать ошибку. Если скобка есть, то действуем по намеченному алгоритму обработки скобки, только в список чисел надо вносить не результат выполнения функции разбиения, а значение функции с этим результатом.

Если Вы досюда дочитали, то я готов Вас поздравить, потому что дальше я предлагаю полный код функции разделения строки на два списка и подсчета значений этого списка.


function Calculate (Line1: string): real;  
var z, d: TStringList;            // - z –список знаков; d – список чисел  
    i, j, c: integer;                //  счетчики  
    w, l, Line: string;                     // begw – переменная, отвечающая за начало числа  
    begw, ok: boolean;  
    res: real;                       // - результат  
    e: ECalcError;                // - ошибка  
    id : integer;                    // - номер функции  
begin  
 w := '';  
 Line := Line1;  
 begw := FALSE;  
 ok := false;  
 z := TStringList.Create;  
 d := TStringList.Create;  
//// Разбиение строки на два списка  ////  
 i := 1;  
 repeat  
 ////  Если знак операции ////  
  if Line[i] in Sign then  
   begin  
    z.Add(Line[i]);  
    if begw then d.Add(w);  
    w := '';  
    begw := TRUE;  
   end  
 ////  Если цифра ////  
  else if Line[i] in digits then  
   begin  
    begw := true;  
    w := w + Line[i];  
   end  
 //// Если скобка ////  
  else if Line[i]='(' then  
   begin  
    c := 1;  
    for j := i+1 to length (Line) do  
     begin  
      if Line[j]='(' then c := c + 1;  
     if Line[j]=')' then c := c - 1;  
      if c=0 then  
       begin  
        ok := true;  
        break;  
       end;  
     end;  
    if not ok then  
     begin  
      e := ECalcError.Create('Не найдена закрывающая скобка к символу ' + inttostr(i));  
      raise e;  
      e.Free;  
     end;  
    l := copy (Line, i+1, j-i-1);  
    d.Add(floattostr(Calculate(l)));  
    delete (Line, i, j-i+1);  
    i := i - 1;  
   end  
 /// Проверка на функцию  
  else if (GetFunction (Line, i)<>0) then  
   begin  
    id := GetFunction (Line, i);  
    if Line[i+GetFunctionNameLength(id)]<>'(' then  {Если после функции нет скобки}  
     begin  
      e := ECalcError.Create('Не найдена скобка после функции в символе  '+ inttostr(i));  
      raise e;  
      e.Free;  
     end;  
{----Если есть скобка----------}  
    c := 1;  
    for j := i+GetFunctionNameLength(id)+1 to length (Line) do  
     begin  
      if Line[j]='(' then c := c + 1;  
      if Line[j]=')' then c := c - 1;  
      if c=0 then  
       begin  
        ok := true;  
        break;  
       end;  
     end;  
    if not ok then  
     begin  
      e := ECalcError.Create('Не найдена закрывающая скобка к символу' + inttostr(i));  
      raise e;  
      e.Free;  
     end;  
    l := copy (Line, i+GetFunctionNameLength(id)+1, j-i-GetFunctionNameLength(id)-1);  
    d.Add(floattostr(CalculateFunction(id, Calculate(l))));  
    delete (Line, i, j-i+1);  
    i := i - 1;  
   end  
 ////  Если неизвестный символ ////  
  else  
   begin  
    e := ECalcError.Create('Неизвестный символ : '+inttostr(i));  
    raise e;  
    e.Free;  
   end;  
  i := i + 1;  
  j := Length (Line);  
  if i>J then break;  
 until false;  
 if w<>'' then d.Add(w);  
 res := (CalculateLists(d, z));  
 z.Free;  
 d.Free;  
 result := res;  
end;  

Вот и все. Надеюсь, Вы быстро разобрались в этой функции.

Добавлено: 07 Августа 2018 07:22:34 Добавил: Андрей Ковальчук

Создание рамки для перемещения Image

При создании одной из своих программ, мне потребовалось организовать возможность перемещения элементов Image внутри формы и возможность изменять их размеры. Сама по себе задача не сложная, сложность заключалась в том, как все это делать при помощи мышки, в лучших традициях фотошопа и еже с ним. Как и любой другой начинающий программист, я полез в Интернет. Там я нашел, по меньшей мере, четыре способа решения моей проблемы, но все они обладали различными недостатками, в результате чего пришлось писать свой собственный код. Получился достаточно длинный код, но зато сама рамка не хуже, чем у профессионалов.

Создадим новый проект. Название формы делаем MainForm. Кидаем на форму один Image и восемь Shape. В раздел uses добавляем модуль jpeg. Это необходимо, что бы наше приложение понимало данный формат. Загружаем в Image любую картинку. Элементы Shape будут играть роль флажков, при помощи которых мы будем изменять размер нашей картинки. Первоначально элемент Shape представляет собой белый квадрат с черной рамкой. Лично я предпочитаю оставить данное сочетание цветов как есть. А вот размеры всех Shape (свойства Width и Height) сделаем 8 на 8 пикселей.

Саму рамку мы будем рисовать на канве формы. Но, прежде всего, нам нужны переменные, куда мы будем сохранять ее размеры. Для этой цели мы воспользуемся записью (представление). В раздел type, перед строкой TMainForm = class(TForm) записываем соответствующий код. Должно получиться вот так:


type  
 TRamka = record  
  Top: integer;  
  Left: integer;  
  Width: integer;  
  Height: integer;  
 end;  
TMainForm = class(TForm)  

В данной программе нам не обойтись без своих собственных подпрограмм. Давайте напишем их. В раздел private пишем:


private  
 { Private declarations }  
 Procedure PaintFlagi;  
 Procedure FlagVisible;  
 Procedure FlagNoVisible;  
Public  

А вот и сами подпрограммы:


procedure TMainForm.PaintFlagi;  
begin  
Shape1.Top := Image1.Top - 8;  
Shape1.Left := Image1.Width div 2 - 4 + Image1.Left;  
  
Shape2.Top := Image1.Top - 8;  
Shape2.Left := Image1.Left + Image1.Width;  
  
Shape3.Top := Image1.Top + Image1.Height div 2 - 4;  
Shape3.Left := Image1.Left + Image1.Width;  
  
Shape4.Top := Image1.Top + Image1.Height;  
Shape4.Left := Image1.Left + Image1.Width;  
  
Shape5.Top := Image1.Top + Image1.Height;  
Shape5.Left := Image1.Left + Image1.Width div 2 - 4;  
  
Shape6.Top := Image1.Top + Image1.Height ;  
Shape6.Left := Image1.Left - 8;  
  
Shape7.Top := Image1.Top + Image1.Height div 2 - 4;  
Shape7.Left := Image1.Left - 8;  
  
Shape8.Top := Image1.Top - 8;  
Shape8.Left := Image1.Left - 8;  
end;  
  
procedure TMainForm.FlagNoVisible;  
begin  
Shape1.Visible := False;  
Shape2.Visible := False;  
Shape3.Visible := False;  
Shape4.Visible := False;  
Shape5.Visible := False;  
Shape6.Visible := False;  
Shape7.Visible := False;  
Shape8.Visible := False;  
end;  
  
procedure TMainForm.FlagVisible;  
begin  
Shape1.Visible := True;  
Shape2.Visible := True;  
Shape3.Visible := True;  
Shape4.Visible := True;  
Shape5.Visible := True;  
Shape6.Visible := True;  
Shape7.Visible := True;  
Shape8.Visible := True;  
end;  

Подпрограмма PaintFlagi выстраивает элементы Shape по периметру Image вне зависимости от его расположения на форме и размеров. По ходу выполнения программы будет необходимость делать Shape видимыми или невидимыми, и этим займутся подпрограммы FlagNoVisible и FlagVisible.

Нам также понадобятся переменные. Опишем их:


{$R *.dfm}  
  
Var  
 X0, Y0: integer;  
 Ramka: TRamka;  

Как я уже писал, саму рамку мы будем рисовать на канве. Но для этого необходима предварительная подготовка. В событие Activate нашей формы пишем код:


procedure TMainForm.FormActivate(Sender: TObject);  
begin  
FlagNoVisible;  
MainForm.Canvas.Pen.Mode := pmNotXor;  
MainForm.Canvas.Brush.Style := bsClear;  
end;  

Первая строка делает невидимыми Shape. Вторая строка устанавливает такой режим карандаша, что при первой прорисовки рамки она будет рисоваться, а при повторной прорисовки рамка будет удаляться, восстанавливая первоначальную картинку. Третья строка делает заливку рамки бесцветной. При желании сюда же можно прописать код ширины рамки и ее цвета:

MainForm.Canvas.Pen.Color := цвет.
MainForm.Canvas.Pen.Width := ширина.

А теперь заставим Image перемещаться по форме. В событие MouseDown элемента Image пишем такой код:

procedure TMainForm.Image1MouseDown(Sender: TObject;  
  
        Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
// В начале мы проверяем, была ли нажата именно левая кнопка мыши  
IF button = mbLeft then begin  
  
// делаем невидимыми наши флажки  
FlagNoVisible;  
  
// передаём координаты и размеры картинки в элемент записи Ramka  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width;  
Ramka.Height := Image1.Height;  
  
// запоминаем начальные координаты мыши  
X0 := X;  
Y0 := Y;  
  
// рисуем рамку  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  

В событие MouseMove мы пишем:

procedure TMainForm.Image1MouseMove(Sender: TObject; Shift:  
  
                                 TShiftState; X,Y: Integer);  
begin  
  
// если нажата левая кнопка мыши  
IF ssLeft in Shift then begin  
  
// стираем рамку на старом месте  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
  
// вычисляем новые координаты рамки  
Ramka.Left := Ramka.Left + X - X0;  
Ramka.Top := Ramka.Top + Y - Y0;  
  
// запоминаем новые координаты мыши  
X0 := x;  
Y0 := y;  
  
// рисуем рамку на новом месте  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  

В событие MouseUp пишем:

procedure TMainForm.Image1MouseUp(Sender: TObject;  
  
        Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
  
// проверяем левую кнопку мыши  
if button = mbLeft then begin  
  
// определяем новые координаты Image  
Image1.Top := Ramka.Top;  
Image1.Left := Ramka.Left;  
  
// стираем рамку  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
  
// ставим флаги на новое место  
PaintFlagi;  
  
// делаем флаги видимыми  
FlagVisible;  
end;  
end;  

Хотелось бы обратить внимание на две вещи: программа реагирует только на нажатие левой кнопки мыши, и при нажатии левой кнопки мыши рамка появляется, а при отжатии (без перемещения) исчезает. Весьма полезные свойства. Дело в том, что вторым свойством не обладает ни один из четырёх примеров, которые я нашёл в Интернете. А что касается первого свойства, то у одного примера есть такой недостаток: перенесешь картинку из одного места в другое, нажмешь на картинку правой кнопкой мыши или колёсиком, и картинка перемещается на своё старое место. Весьма удручающая картина.

А теперь заставим картинку менять свои размеры. Так как этот код ну очень похож на тот код, который я уже описал, я не буду его объяснять так же подробно.

Верхний флаг:


procedure TMainForm.Shape1MouseDown(Sender: TObject;  
  
       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width;  
Ramka.Height := Image1.Height + Ramka.Top;  
  
Y0 := Y;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                                    Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape1MouseMove(Sender: TObject; Shift:  
  
 TShiftState; X,  
Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
 Ramka.Height);  
Ramka.Top := Ramka.Top + Y - Y0;  
Y0 := y;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                                   Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape1MouseUp(Sender: TObject;  
  
       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
Image1.Top := Ramka.Top;  
Image1.Height := Ramka.Height - Ramka.Top;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                                    Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

Здесь мы изменяем высоту Image по верхнему флажку. Но следует отметить, что у прямоугольника, нарисованного на канве, в отличие от Image нет таких свойств как высота и ширина. Есть ближние точки и дальние точки. И что бы иметь возможность изменять координату ближней точки, не изменяя координаты дальней точки, мы пользуемся кодом:


Ramka.Height := Image1.Height + Ramka.Top;  

А что бы вычислить новую высоту картинки, мы используем код:


Image1.Height := Ramka.Height - Ramka.Top;  

Что бы изменять ширину картинки левым флагом, мы проделываем тот же самый фокус.

Левый флаг:


procedure TMainForm.Shape7MouseDown(Sender: TObject;  
  
         Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width + Image1.Left;  
Ramka.Height := Image1.Height;  
  
X0 := X;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                                 Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape7MouseMove(Sender: TObject; Shift:  
  
                                  TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                                   Ramka.Top + Ramka.Height);  
Ramka.Left := Ramka.Left + X - X0;  
X0 := x;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                                   Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape7MouseUp(Sender: TObject;  
  
                                        Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
Image1.Left := Ramka.Left;  
Image1.Width := Ramka.Width - Ramka.Left;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                                  Ramka.Top + Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

Совмещаем код левого и верхнего флагов, и получаем код верхнего левого флага.

Верхний левый флаг:


procedure TMainForm.Shape8MouseDown(Sender: TObject;  
  
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width + Image1.Left;  
Ramka.Height := Image1.Height + Image1.Top;  
  
X0 := X;  
Y0 := Y;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                                                  Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape8MouseMove(Sender: TObject;  
  
                                Shift: TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
 Ramka.Height);  
Ramka.Left := Ramka.Left + X - X0;  
Ramka.Top := Ramka.Top + Y - Y0;  
  
X0 := x;  
Y0 := y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                                                  Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape8MouseUp(Sender: TObject;  
  
        Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
Image1.Top := Ramka.Top;  
Image1.Left := Ramka.Left;  
Image1.Width := Ramka.Width - Ramka.Left;  
Image1.Height := Ramka.Height - Ramka.Top;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                                                  Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

Для изменения ширины картинки правым флагом, необходимо просто изменять ширину.

Правый флаг:


procedure TMainForm.Shape3MouseDown(Sender: TObject;  
  
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width;  
Ramka.Height := Image1.Height;  
  
X0 := X;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape3MouseMove(Sender: TObject;  
  
                                Shift: TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
Ramka.Width := Ramka.Width + X - X0;  
X0 := x;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape3MouseUp(Sender: TObject;  
  
 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
  
Image1.Width := Ramka.Width;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

С остальными флагами, я думаю, вопросов не будет, по этому даю код без объяснений.

Нижний флаг:


procedure TMainForm.Shape5MouseDown(Sender: TObject;  
  
           Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width;  
Ramka.Height := Image1.Height;  
  
Y0 := Y;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape5MouseMove(Sender: TObject;  
  
                            Shift: TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
Ramka.Height := Ramka.Height + Y - Y0;  
Y0 := y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape5MouseUp(Sender: TObject;  
  
         Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
Image1.Height := Ramka.Height;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                       Ramka.Top + Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

Нижний правый флаг:


procedure TMainForm.Shape4MouseDown(Sender: TObject;  
  
         Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width;  
Ramka.Height := Image1.Height;  
  
X0 := X;  
Y0 := Y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape4MouseMove(Sender: TObject;  
  
                                Shift: TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
Ramka.Width := Ramka.Width + X - X0;  
Ramka.Height := Ramka.Height + Y - Y0;  
X0 := x;  
Y0 := y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape4MouseUp(Sender: TObject;  
  
         Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
Image1.Height := Ramka.Height;  
Image1.Width := Ramka.Width;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Image1.Left + Ramka.Width,  
  
                                       Ramka.Top + Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

Верхний правый флаг:


procedure TMainForm.Shape2MouseDown(Sender: TObject;  
  
    Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width;  
Ramka.Height := Image1.Height + Ramka.Top;  
  
X0 := X;  
Y0 := Y;  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                                    Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape2MouseMove(Sender: TObject;  
  
                                Shift: TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                                    Ramka.Height);  
Ramka.Width := Ramka.Width + X - X0;  
Ramka.Top := Ramka.Top + Y - Y0;  
  
X0 := x;  
Y0 := y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                                    Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape2MouseUp(Sender: TObject;  
  
         Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
  
Image1.Top := Ramka.Top;  
Image1.Height := Ramka.Height - Ramka.Top;  
Image1.Width := Ramka.Width;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                                   Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

Нижний левый флаг:


procedure TMainForm.Shape6MouseDown(Sender: TObject;  
  
     Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width + Image1.Left;  
Ramka.Height := Image1.Height;  
  
X0 := X;  
Y0 := Y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                             Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape6MouseMove(Sender: TObject;  
  
                     Shift: TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                             Ramka.Top + Ramka.Height);  
Ramka.Left := Ramka.Left + X - X0;  
Ramka.Height := Ramka.Height + Y - Y0;  
  
X0 := x;  
Y0 := y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                             Ramka.Top + Ramka.Height);  
end;  
end;  
  
procedure TMainForm.Shape6MouseUp(Sender: TObject;  
  
    Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
if button = mbLeft then begin  
Image1.Left := Ramka.Left;  
Image1.Width := Ramka.Width - Ramka.Left;  
Image1.Height := Ramka.Height;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Width,  
  
                             Ramka.Top + Ramka.Height);  
  
PaintFlagi;  
  
FlagVisible;  
end;  
end;  

И в заключении я хотел бы сказать про эффект, который я назвал "ломаная рамка". Визуально это выглядит так. При нажатии кнопки на картинке, рамка вырисовывается частично: в тех местах, где рамка пересекает флажки, линия рамки отсутствует. В том примере, который я написал, данный эффект отсутствует вследствие того, что я вынес флажки за пределы рамки. Но если флажки расставить так, что бы линия рамки пересекала их по середине, как это реализовано в Delphi, то мы обязательно столкнёмся с данным эффектом. А дело вот в чем. Посмотрим код, который реализовывается при нажатии левой кнопки мыши на Image:


procedure TMainForm.Image1MouseDown(Sender: TObject;  
  
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
begin  
IF button = mbLeft then begin  
FlagNoVisible;  
  
Ramka.Top := Image1.Top;  
Ramka.Left := Image1.Left;  
Ramka.Width := Image1.Width;  
Ramka.Height := Image1.Height;  
  
X0 := X;  
Y0 := Y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
                                        Ramka.Top + Ramka.Height);  
end;  
end;  

Как видно из кода, команда, которая делает элементы Shape невидимыми, выполняется раньше, чем команда, которая рисует рамку. Но в реальности в начале рисуется рамка, а только потом элементы Shape становятся невидимыми вместе с той частью рамки, где линия рамки проходит через флаги. Почему происходит так, я могу только догадываться. Этого эффекта можно избежать, если при помощи таймера искусственно отстрочить выполнение команды:


Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
                                        Ramka.Top + Ramka.Height);  

на одну миллисекунду (минимальное значение таймера). Но тогда вылезет другая проблема. Если слишком резко переместить картинку, то первой уже выполниться команда, которая должна состирать рамку. Вот тот код:


procedure TMainForm.Image1MouseMove(Sender: TObject;  
  
                             Shift: TShiftState; X,Y: Integer);  
begin  
IF ssLeft in Shift then begin  
Canvas.Rectangle(Ramka.Left, Ramka.Top,  
  
  Ramka.Left + Ramka.Width,  
  
    Ramka.Top + Ramka.Height);  
  
     // рисуем рамку вместо того, что бы её стереть.  
Ramka.Left := Ramka.Left + X - X0;  
Ramka.Top := Ramka.Top + Y - Y0;  
X0 := x;  
Y0 := y;  
  
Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
  
Ramka.Top + Ramka.Height);  
end;  
end;  

Визуально это будет выглядеть так: рамка не будет стираться в том месте, откуда началось перемещение Image. Возможное решение данной проблемы: все команды, которые рисуют рамку:


Canvas.Rectangle(Ramka.Left, Ramka.Top, Ramka.Left + Ramka.Width,  
                                        Ramka.Top + Ramka.Height);  

и при нажатии левой кнопки мыши, и при перемещении картинки, и при отжатии кнопки, должны выполняться через один и тот же таймер. Но не известно, к каким другим проблемам это может привести. Если кто хочет, можете экспериментировать.

Добавлено: 06 Августа 2018 20:57:55 Добавил: Андрей Ковальчук

Синхронизация процессов при работе с Windows. Waitable timer (таймер ожидания)

waitable timer (таймер ожидания)
Таймер ожидания отсутствует в windows 95, и для его использования необходимы windows 98 или windows nt 4.0 и выше.

Таймер ожидания переходит в сигнальное состояние по завершении заданного интервала времени.
Для его создания используется функция createwaitabletimer:


function createwaitabletimer(  
lptimerattributes: psecurityattributes; // Адрес структуры  
// tsecurityattributes  
bmanualreset: bool; // Задает, будет ли таймер переходить в  
// сигнальное состояние по завершении функции  
// ожидания  
lptimername: pchar // Имя объекта  
): thandle; stdcall;   

Когда параметр bmanualreset равен true, то таймер после срабатывания функции ожидания остается в сигнальном состоянии до явного вызова setwaitabletimer, если false-таймер автоматически переходит в несигнальное состояние.

Если lptimername совпадает с именем уже существующего в системе таймера, то функция возвращает его идентификатор, позволяя использовать объект для синхронизации между процессами. Имя таймера не должно совпадать с именем уже существующих объектов типов event, semaphore, mutex, job или file-mapping.

Идентификатор уже существующего таймера можно получить функцией:


function openwaitabletimer(  
dwdesiredaccess: dword; // Задает права доступа к объекту  
binherithandle: bool; // Задает, может ли объект наследоваться  
// дочерними процессами  
lptimername: pchar // Имя объекта  
): thandle; stdcall;   

Параметр dwdesiredaccess может принимать следующие значения:

timer_all_access 

Разрешает полный доступ к объекту

timer_modify_state 

Разрешает изменять состояние таймера функциями setwaitabletimer и cancelwaitabletimer

synchronize 

Только для windows nt — разрешает использовать таймер в функциях ожидания
После получения идентификатора таймера поток может задать время его срабатывания функцией setwaitabletimer:


function setwaitabletimer(  
htimer: thandle; // Идентификатор таймера  
const lpduetime: tlargeinteger; // Время срабатывания  
lperiod: longint; // Период повторения срабатывания  
pfncompletionroutine: tfntimerapcroutine; // Процедура-обработчик  
lpargtocompletionroutine: pointer;// Параметр процедуры-обработчика  
fresume: bool // Задает, будет ли операционная  
// система «пробуждаться»  
): bool; stdcall;   

Рассмотрим параметры подробнее.

lpduetime 

Задает время срабатывания таймера. Время задается в формате tfiletime и базируется на coordinated universal time (utc), то есть должно указываться по Гринвичу. Для преобразования системного времени в tfiletime используется функция systemtimetofiletime. Если время имеет положительный знак, оно трактуется как абсолютное, если отрицательный — как относительное от момента запуска таймера.

lperiod 

Задает срок между повторными срабатываниями таймера. Если lperiod равен 0, то таймер сработает один раз.

pfncompletionroutine 

Адрес функции, объявленной как:


procedure timerapcproc(  
lpargtocompletionroutine: pointer; // данные  
dwtimerlowvalue: dword; // младшие 32 разряда значения таймера  
dwtimerhighvalue: dword; // старшие 32 разряда значения таймера  
); stdcall;   

Эта функция вызывается, когда срабатывает таймер, если поток, ожидающий его срабатывания, использует функцию ожидания, поддерживающую асинхронный вызов процедур. В функцию передаются три параметра:

lpargtocompletionroutine — значение, переданное в качестве одноименного параметра в функцию setwaitabletimer. Приложение может использовать его для передачи в процедуру обработки адреса блока данных, необходимых для ее работы
dwtimerlowvalue и dwtimerhighvalue – соответственно члены dwlowdatetime и dwhighdatetime структуры tfiletime. Они описывают время срабатывания таймера. Время задается в utc-формате (по Гринвичу).
Если дополнительная функция обработки не нужна, в качестве этого параметра можно передать nil.

lpargtocompletionroutine 

Это значение передается в функцию pfncompletionroutine при ее вызове.

fresume 

Определяет необходимость «пробуждения» системы, если на момент срабатывания таймера она находится в режиме экономии электроэнергии (suspended). Если операционная система не поддерживает пробуждение и fresume равно true, то функция setwaitabletimer выполнится успешно, однако последующий вызов getlasterror вернет результат error_not_supported.

Если необходимо перевести таймер в неактивное состояние, это можно сделать функцией:


function cancelwaitabletimer(htimer: thandle): bool; stdcall;   

Эта функция не изменяет состояния таймера и не приводит к срабатыванию функций ожидания и вызову процедур-обработчиков.

По завершении работы объект должен быть уничтожен функцией closehandle.

Создадим класс, который ожидает в отдельном потоке наступления заданного времени, а затем вызывает процедуру главного потока приложения. Такой класс может использоваться, например, в планировщике заданий (поскольку таймер ожидания позволяет задавать время срабатывания в абсолютных величинах, отпадает необходимость постоянно анализировать текущее время, используя обычный таймер windows):


unit waitthread;  
  
interface  
  
uses classes, windows;  
  
type  
twaitthread = class(tthread)  
waituntil: tdatetime;  
procedure execute; override;  
end;  
  
implementation  
  
uses sysutils;  
  
procedure twaitthread.execute;  
var  
timer: thandle;  
systemtime: tsystemtime;  
filetime, localfiletime: tfiletime;  
begin  
timer := createwaitabletimer(nil, false, nil);  
try  
datetimetosystemtime(waituntil, systemtime);  
systemtimetofiletime(systemtime, localfiletime);  
localfiletimetofiletime(localfiletime, filetime);  
setwaitabletimer(timer, tlargeinteger(filetime), 0,  
nil, nil, false);  
waitforsingleobject(timer, infinite);  
finally  
closehandle(timer);  
end;  
end;  
  
end.  

Использовать этот класс можно, например, следующим образом:


type  
tform1 = class(tform)  
button1: tbutton;  
procedure button1click(sender: tobject);  
private  
procedure timerfired(sender: tobject);  
end;  
  
...  
  
implementation  
  
uses waitthread;  
  
procedure tform1.button1click(sender: tobject);  
var  
t: tdatetime;  
begin  
with twaitthread.create(true) do  
begin  
onterminate := timerfired;  
freeonterminate := true;  
// Срок ожидания закончится через 5 секунд  
waituntil := now + 1 / 24 / 60 / 60 * 5;  
resume;  
end;  
end;  
  
procedure tform1.timerfired(sender: tobject);  
begin  
showmessage('timer fired !');  
end;   

Дополнительные объекты синхронизации
Некоторые объекты win32 api не предназначены исключительно для целей синхронизации, однако могут использоваться с функциями синхронизации.
Такими объектами являются:

Сообщение об изменении папки (change notification)
windows позволяет организовать слежение за изменениями объектов файловой системы. Для этого служит функция findfirstchangenotification:


function findfirstchangenotification(  
lppathname: pchar; // Путь к папке, изменения в которой нас  
// интересуют  
bwatchsubtree: bool; // Задает необходимость слежения за  
// изменениями во вложенных папках  
dwnotifyfilter: dword // Фильтр событий  
): thandle; stdcall;   

Параметр dwnotifyfilter — это битовая маска из одного или нескольких следующих значений:

file_notify_change_file_name 

Слежение ведется за любым изменением имени файла, в том числе за созданием и удалением файлов
file_notify_change_dir_name 

Слежение ведется за любым изменением имени папки, в том числе за созданием и удалением папок
file_notify_change_attributes 

Слежение ведется за любым изменением атрибутов
file_notify_change_size 

Слежение ведется за изменением размера файлов. Изменение размера происходит при записи в файл. Функция ожидания срабатывает только после успешного сброса дискового кэша
file_notify_change_last_write 

Слежение ведется за изменением времени последней записи в файл, то есть фактически за любой записью в файл. Функция ожидания срабатывает только после успешного сброса дискового кэша
file_notify_change_security 

Слежение ведется за любыми изменениями дескрипторов защиты

Идентификатор, возвращенный этой функцией, может использоваться в любой функции ожидания.
Он переходит в сигнальное состояние, когда в папке происходят изменения, запрошенные для слежения.
Можно продолжить слежение, используя функцию findnextchangenotification:


function findnextchangenotification(  
hchangehandle: thandle  
): bool; stdcall;   

По завершении работы идентификатор должен быть закрыт при помощи функции findclosechangenotification:


function findclosechangenotification(  
hchangehandle: thandle  
): bool; stdcall;   

Чтобы не блокировать исполнение основного потока программы функцией ожидания, удобно реализовать ожидание изменений в отдельном потоке. Реализуем поток на базе класса tthread. Для того чтобы можно было прервать исполнение потока методом terminate, необходимо, чтобы функция ожидания, реализованная в методе execute, также прерывалась при вызове terminate. Для этого будем использовать вместо waitforsingleobject функцию waitformultipleobjects и прерывать ожидание по событию (event), устанавливаемому в terminate:


type  
tcheckfolder = class(tthread)  
private  
fonchange: tnotifyevent;  
handles: array[0..1] of thandle; // Идентификаторы объектов  
// синхронизации  
procedure doonchange;  
protected  
procedure execute; override;  
public  
constructor create(createsuspended: boolean;  
pathtomonitor: string; waitsubtree: boolean;  
onchange: tnotifyevent; notifyfilter: dword);  
destructor destroy; override;  
procedure terminate;  
end;  
  
procedure tcheckfolder.doonchange;  
// Эта процедура вызывается в контексте главного потока приложения  
// В ней можно использовать вызовы vcl, изменять состояние формы,  
// например перечитать содержимое tlistbox, отображающего файлы  
begin  
if assigned(fonchange) then  
fonchange(self);  
end;  
  
procedure tcheckfolder.terminate;  
begin  
inherited; // Вызываем tthread.terminate, устанавливаем  
// terminated = true  
setevent(handles[1]); // Сигнализируем о необходимости  
// прервать ожидание  
end;  
  
constructor tcheckfolder.create(createsuspended: boolean;  
pathtomonitor: string; waitsubtree: boolean;  
onchange: tnotifyevent; notifyfilter: dword);  
var  
boolforwin95: integer;  
begin  
// Создаем поток остановленным  
inherited create(true);  
// windows 95 содержит не очень корректную реализацию функции  
// findfirstchangenotification. Для корректной работы необходимо,  
// чтобы:  
// - lppathname - не содержал завершающего слэша "" для  
// некорневого каталога  
// - bwatchsubtree - true должен передаваться как bool(1)  
if waitsubtree then  
boolforwin95 := 1  
else  
boolforwin95 := 0;  
if (length(pathtomonitor) > 1) and  
(pathtomonitor[length(pathtomonitor)] = ‘’) and  
(pathtomonitor[length(pathtomonitor)-1] <> ‘:’) then  
delete(pathtomonitor, length(pathtomonitor), 1);  
handles[0] := findfirstchangenotification(  
pchar(pathtomonitor), bool(boolforwin95), notifyfilter);  
handles[1] := createevent(nil, true, false, nil);  
fonchange := onchange;  
// И, при необходимости, запускаем  
if not createsuspended then  
resume;  
end;  
  
destructor tcheckfolder.destroy;  
begin  
findclosechangenotification(handles[0]);  
closehandle(handles[1]);  
inherited;  
end;  
  
procedure tcheckfolder.execute;  
var  
reason: integer;  
dummy: integer;  
begin  
repeat  
// Ожидаем изменения в папке либо сигнала о завершении  
// потока  
reason := waitformultipleobjects(2, @handles, false, infinite);  
if reason = wait_object_0 then begin  
// Изменилась папка, вызываем обработчик в контексте  
// главного потока приложения  
synchronize(doonchange);  
// И продолжаем поиск  
findnextchangenotification(handles[0]);  
end;  
until terminated;  
end;  

Поскольку метод tthread.terminate не виртуальный, этот класс нельзя использовать с переменной типа tthread, так как в этом случае будет вызываться метод terminate класса tthread, который не может прервать ожидания, и поток будет выполняться до изменения в папке, за которой ведется слежение.

Устройство стандартного ввода с консоли (console input)
Идентификатор стандартного устройства ввода с консоли, полученный при помощи вызова функции getstdhandle(std_input_handle), можно использовать в функциях ожидания. Он находится в сигнальном состоянии, если очередь ввода консоли не пустая, и в несигнальном — если пустая. Это позволяет организовать ожидание ввода символов или при помощи функции waitformultipleobjects совместить его с ожиданием каких-либо других событий.

Задание (job)
job — это новый механизм windows 2000, позволяющий объединить группу процессов в одно задание и манипулировать ими одновременно. Идентификатор задания находится в сигнальном состоянии, если все процессы, ассоциированные с ним, завершились по причине истечения лимита времени на выполнение задания.

Процесс (process)
Идентификатор процесса, полученный при помощи функции createprocess, переходит в сигнальное состояние по завершении процесса, что позволяет организовать ожидание завершения процесса, например, при запуске из приложения внешней программы:


var  
pi: tprocessinformation;  
si: tstartupinfo;  
...  
fillchar(si, sizeof(si), 0);  
si.cb := sizeof(si);  
win32check(createprocess(nil, 'command.com', nil,  
nil, false, 0, nil, nil, si, pi));  
// Задерживаем исполнение программы до завершения процесса  
waitforsingleobject(pi.hprocess, infinite);  
closehandle(pi.hprocess);  
closehandle(pi.hthread);   

Следует понимать, что в этом случае вызывающий процесс будет заморожен полностью и не сможет обрабатывать сообщения. Поэтому, если дочерний процесс может выполняться в течение длительного времени, лучше использовать более корректный вариант ожидания, описанный в разделе, посвященном функции msgwaitformultipleobjects.

Поток (thread)
Идентификатор потока находится в несигнальном состоянии до тех пор, пока поток выполняется. По его завершении идентификатор переходит в сигнальное состояние. Это позволяет легко узнать, завершился ли поток, либо при помощи функции, ожидающей несколько объектов, организовать ожидание завершения одного или всех интересующих потоков.

Дополнительные механизмы синхронизации
Критические секции
Критические секции — это механизм, предназначенный для синхронизации потоков внутри одного процесса. Как и мьютекс, критическая секция может в один момент времени принадлежать только одному потоку, однако она предоставляет более быстрый и эффективный механизм, чем мьютексы. Перед использованием критической секции необходимо инициализировать ее функцией:


procedure entercriticalsection(  
var lpcriticalsection: trtlcriticalsection  
); stdcall;   

После создания объекта поток, перед доступом к защищаемому ресурсу, должен вызвать функцию:


procedure leavecriticalsection(  
var lpcriticalsection: trtlcriticalsection  
); stdcall;   

Если в этот момент ни один из потоков в процессе не владеет объектом, то поток становится владельцем критической секции и продолжает выполнение. Если секция уже захвачена другим потоком, то выполнение потока, вызвавшего функцию, приостанавливается до ее освобождения.

Поток, владеющий критической секцией, может повторно вызывать функцию entercriticalsection без блокирования своего исполнения. По завершении работы с защищаемым ресурсом поток должен вызвать функцию leavecriticalsection:


function tryentercriticalsection(  
var lpcriticalsection: trtlcriticalsection  
): bool; stdcall;   

Эта функция освобождает объект независимо от количества предыдущих вызовов потоком функции entercriticalsection. Если имеются другие потоки, ожидающие освобождения секции, один из них становится ее владельцем и продолжает исполнение. Если поток завершился, не освободив критическую секцию, то ее состояние становится неопределенным, что может вызвать блокировку работы программы.

Имеется возможность попытаться захватить объект без замораживания потока. Для этого служит функция tryentercriticalsection:


procedure deletecriticalsection(  
var lpcriticalsection: trtlcriticalsection  
); stdcall;    

Она проверяет, захвачена ли секция в момент ее вызова. Если да — функция возвращает false, в противном случае — захватывает секцию и возвращает true.

По завершении работы с критической секцией она должна быть уничтожена вызовом функции deletecriticalsection:

Рассмотрим пример приложения, осуществляющего в нескольких потоках загрузку данных по сети. Глобальные переменные bytessummary и timesummary хранят общее количество загруженных байтов и время загрузки. Эти переменные каждый поток обновляет по мере считывания данных; для предотвращения конфликтов приложение должно защитить общий ресурс при помощи критической секции:


var  
// Глобальные переменные  
criticalsection: trtlcriticalsection;  
bytessummary: cardinal;  
timesummary: tdatetime;  
averagespeed: float;  
...  
// При инициализации приложения  
initializecriticalsection(criticalsection);  
bytessummary := 0;  
timesummary := 0;  
averagespeed := 0;  
  
//В методе execute потока, загружающего данные.  
repeat  
bytesread := readdatablockfromnetwork;  
entercriticalsection(criticalsection);  
try  
bytessummary := bytessummary + bytesread;  
timesummary := timesummary + (now - threadstarttime);  
if timesummary > 0 then  
averagespeed := bytessummary / (timesummary/24/60/60);  
finally  
leavecriticalsection(criticalsection)  
end;  
until loadcomplete;  
  
// При завершении приложения  
deletecriticalsection(criticalsection);   
delphi предоставляет класс, инкапсулирующий функциональность критической секции. Класс объявлен в модуле syncobjs.pas:


type  
tcriticalsection = class(tsynchroobject)  
public  
constructor create;  
destructor destroy; override;  
procedure acquire; override;  
procedure release; override;  
procedure enter;  
procedure leave;  
end;   

Методы enter и leave являются синонимами методов acquire и release соответственно и добавлены для лучшей читаемости исходного кода:


procedure tcriticalsection.enter;  
begin  
acquire;  
end;  
  
procedure tcriticalsection.leave;  
begin  
release;  
end;  

Защищенный доступ к переменным (interlocked variable access)
Часто возникает необходимость в совершении операций над разделяемыми между потоками 32-разрядными переменными. В целях упрощения решения этой задачи windows api предоставляет функции для защищенного доступа к ним, не требующие использования дополнительных (и более сложных) механизмов синхронизации. Переменные, используемые в этих функциях, должны быть выровнены на границу 32-разрядного слова. Применительно к delphi это означает, что если переменная объявлена внутри записи (record), то эта запись не должна быть упакованной (packed) и при ее объявлении должна быть активна директива компилятора {$a+}. Несоблюдение данного требования может привести к возникновению ошибок на многопроцессорных конфигурациях.


type  
tpackedrecord = packed record  
a: byte;  
b: integer;  
end;  
// tpackedrecord.b нельзя использовать в функциях interlockedxxx  
  
tnotpackedrecord = record  
a: byte;  
b: integer;  
end;  
  
{$a-}  
var  
a1: tnotpackedrecord;  
// a1.b нельзя использовать в функциях interlockedxxx  
i: integer  
// i можно использовать в функциях interlockedxxx, так как переменные в  
// delphi всегда выравниваются на границу слова безотносительно  
// к состоянию директивы компилятора $a  
  
{$a+}  
var  
a2: tnotpackedrecord;  
// a2.b можно использовать в функциях interlockedxxx  
  
function interlockedincrement(  
var addend: integer  
): integer; stdcall;   

Функция увеличивает переменную addend на 1. Возвращаемое значение зависит от операционной системы:

windows 98, windows nt 4.0 и старше — возвращается новое значение переменной addend;
windows 95, windows nt 3.51:

если после изменения addend < 0, то возвращается отрицательное число, не обязательно равное addend;
если addend = 0, то возвращается 0;
если после изменения addend > 0, то возвращается положительное число, не обязательно равное addend.


function interlockeddecrement(  
var addend: integer  
): integer; stdcall;   

Функция уменьшает переменную addend на 1. Возвращаемое значение аналогично функции interlockedincrement.


function interlockedexchange(  
var target: integer;  
value: integer  
): integer; stdcall;   

Функция записывает в переменную target значение value и возвращает предыдущее значение target.

Следующие функции для выполнения требуют windows 98 или windows nt 4.0 и старше.


function interlockedcompareexchange(  
var destination: pointer;  
exchange: pointer;  
comperand: pointer  
): pointer; stdcall;   

Функция сравнивает значения destination и comperand. Если они совпадают, значение exchange записывается в destination. Функция возвращает начальное значение destination.


function interlockedexchangeadd(  
addend: plongint;  
value: longint  
): longint; stdcall;  

Функция добавляет к переменной, на которую указывает addend, значение value и возвращает начальное значение addend.

Резюме
Многозадачная и многопоточная среда win32 предоставляет широкие возможности для написания высокоэффективных приложений. Однако написание приложений, использующих многопоточность и взаимодействующих друг с другом, при неаккуратном программировании может привести к их неверной работе, неоправданной загрузке и даже к блокировке всей операционной системы. Во избежание этого следуйте нижеприведенным рекомендациям:

Если приложения или потоки одного процесса изменяют общий ресурс — защищайте доступ к нему при помощи критических секций или мьютексов.
Если доступ осуществляется только на чтение — защищать ресурс не обязательно
Критические секции более эффективны, но применимы только внутри одного процесса; мьютексы могут использоваться для синхронизации между процессами.
Используйте семафоры для ограничения количества обращений к одному ресурсу.
Используйте события (event) для информирования потока о наступлении какого-либо события.
Если разделяемый ресурс — 32-битная переменная, то для синхронизации доступа к нему можно использовать функции, обеспечивающие разделяемый доступ к переменным.
Многие объекты win32 позволяют организовать эффективное слежение за своим состоянием при помощи функций ожидания. Это наиболее эффективный с точки зрения расхода системных ресурсов метод.
Если ваш поток создает (даже неявно, при помощи coinitialize или функций dde) окна, то он должен обрабатывать сообщения. Не используйте в таком потоке функции, не позволяющие прервать ожидание по приходу сообщения с большим или неограниченным периодом ожидания. Используйте функции msgwaitforxxx.

Анатолий Тенцер

Добавлено: 04 Августа 2018 14:53:18 Добавил: Андрей Ковальчук

Работа с файлами

Решил открыть эту тему и постепенно собрать воедино основные приемы работы с файлами.

Сегодня текстовые файлы.
Текстовый файл отличается тем что он разбит на разные по длине строки, отделенные символами #13#10. Есть 2 основных метода работы с текстовыми файлами - старый паскалевский способ и через файловые потоки. У обоих есть преимущества и недостатки. Через потоки способ проще поэтому начнем с него.

Итак у всех потомков класса TStrings (TStringList, memo.Lines и т.п. ) есть методы записи и чтения в файл - SaveToFile, LoadFromFile. Преимущество - простота использования и довольно высокая скорость, недостаток - читать и писать файл можно только целиком.

Примеры.
1) Загрузка текста из файла в Memo:

Исходный код:

Memo1.lines.loadfromfile('c:\\MyFile.txt');  

2) Сохранение в файл:

Исходный код:

Memo1.lines.savetoFile('c:\\MyFile.txt');  

3) А вот так можно прочитать весь файл в строку:

Исходный код:

Function ReadFromFile(FileName:string):string;  
begin  
 With TStringList.create do  
   try  
     LoadFromFile(FileName);  
     result:=text;  
   finally  
     Free;  
   end;  
end;  

Часть II

Для более тонких операций над текстовыми файлами прийдется освоить очень древний паскалевский способ.

Итак, для доступа к текстовым файлам используется переменная типа TextFile. До сих пор не совсем понимаю что это такое физически - что-то типа "внутреннего" паскалевского Handle на файл.

Итак чтобы ассоциировать файл на диске с переменной надо проделать следующие опрерации:

1) Определяем файловую переменную:

Исходный код:

var f:TextFile;  

2) Ассоциируем ее:

Исходный код:

AssignFile(F, 'c:\\MyFile.txt');  

3) Теперь надо этот файл открыть, есть 3 варианта:
- файла нет или он должен быть перезаписан, открытие для записи:

Исходный код

Rewrite(f);  

- файл есть и его надо открыть для чтения (с первой строки)

Исходный код

Reset(f);  

- файл есть и его надо открыть для дописования строк в конец

Исходный код

Append(f);  

Как видите не хватает очень полезных функций таких как открытия файла для чтения с произвольной строки и для записи в файл произвольной строки. Но надо учесть, что так как длины строк разные, не существует никакого способа узнать физическое место начала например 1000 строки, не прочитав всю тысячу строк. Для записи ситуация еще сложнее - вставить строку означает перезаписать всю информацию после этой строки заново. Таким образом варианты только следующие:
- Перезаписать весть файл
- Читать с первой строки
- Дописать что-то в конец
- Читать и писать файл целиком (см. выше работу через TStrings)

В конце работы открытый файл нужно закрыть:

Исходный код

CloseFile(f);  

Теперь пусть у нас есть строковая переменная s для чтения строки из файла

Чтение предварительно открытого файла:

Исходный код

ReadLn(f,s)  

- будет прочитанна текущая строка и позиция чтения переведена на следующую позицию.

А как прочитать весь файл?

Исходный код:

While not eof(f) do  
 begin  
   ReadLn(f, s);  
   {здесь делаем ÷то-то с про÷итанной строкой}  
 end;  

Хорошо, а если файл несколько метров есть ли способ поставить какой-нибудь ProgressBar или Gauge чтобы показывал сколько считанно? Есть, но не совсем прямой - не забыли, сколько строк в файле заранее мы не знаем, узнать можно только прочитав его весь, но показометер мы все-таки сделаем:

Исходный код:

var  Canceled:Boolean;  
  
Function GetFileSize(FIleName:String):integer;  
 var f: File of Byte;  
begin  
 try  
   AssignFile(f, FileName);  
   Reset(f);  
   result:=filesize(F);  
   CloseFile(f);  
 except  
   result:=-1;  
 end;  
end;  
  
  
Procedure ReadMyFile;  
Var i,j:integer;  
Begin  
  ProgressBar1.Max:=GetFileSize('c:\\MyFile.txt');  
  ProgressBar1.position:=0;  
  assignfile(f,'c:\\MyFile.txt');  
  Canceled:=False;  
  reset(f);  
     i:=0;j:=0;  
     while not eof(f) do  
       begin  
         inc(j);  
         readln(f,s);  
         i:=i+length(s)+2;  
         if (j mod 1000)=0 then  
           begin  
             ProgressBar1.position:=i;  
             Application.ProcessMessages;  
             if canceled then break;  
           end;  
         {здесь мы ÷то-то делаем с про÷итанной строкой}  
       end;  
     CloseFile(f);  
End;  

Теперь комментарии к коду.
1) Функию GetFileSize я рсссмотрю после, она немного по другому подходит к чтению файла (кстати я знаю еще по крайней мере 3 способа ее реализации, поэтому не нужно указывать что это можно сделать легче, быстрее или просто по другому - просто давайте разберем это позже)
2) Переменная i - все время указывает на количество байт которое мы считали - мы определяем длину каждой строки и прибавляем 2 (символы конца строки). Зная длину файла в байтах и сколько байт прочитано можно оценить и прогресс, но
3) Если ставить изменение прогресса после каждой строки, то это очень сильно тормознет процесс. Поэтому вводим переменную j и обновляем прогресс например 1 раз на 1000 прочитанных строк
4) Переменная Canceled - глобальная переменная. Поставьте на форму кнопку, в обработчике нажатия поставьте Canceled:=True; и нажатие кнопки прервет чтение файла.

Часть III

Приведенные выше механизмы будут работать с любым файлом, так как любой файл можно считать файлом байтов. Теперь где это можно использовать? В принципе везде, но в подавляющем большинстве случаев это будет очень неудобно, ведь скорость считывания при чтении по байтам будет на порядки более низкой чем другими способами. Однако в некоторых случаях этот способ может быть очень полезен. Например в программе вам надо заменить 100й байт файла на другой, или прочитать 100й байт файла, например во всяких читерских программах, при взломе и т.п. Здесь такой доступ будет весьма удобен. Гораздо более интересным представляется дальнейшее развитие технологии типизированных файлов (их еще лет 15 назад называли "Файлы прямого доступа"). Представим себе, что файл состоит не из байт а из более сложных структур. Например мы имеем некоторую информацию в виде:


Type MyRec=Record  
          Name:string[100];  
          Age:byte;  
          Membership:Boolean;  
          Accounts:array[1..10] of integer;  
       End;  

Обратите внимание, что все элементы записи точно типизированны, нет ни длинных строк, ни открытых массивов, ни объектов, другими словами, заранее точно известно сколько именно байт будет занимать переменная этого типа. Объявим переменную этого типа:


Var MyVar:MyRec;  

и файл этого типа:


Var f:File of MyRec;  

Теперь мы можем читать и писать сразу целую структуру, абсолютно так же как и если бы это был один байт:


AssignFile(f,'c:\\MyFile.rec');  
Rewrite(f);  
MyVar.Name:='Vitaly';  
MyVar.Age:=33;  
MyVar.Membership:=True;  
MyVar.Accounts[1]:=12345;  
MyVar.Accounts[2]:=34985;  
Write(f,MyVar);  
Closefile(f);  

Все остальные функции приведенные в предыдущей статье будут работать так же, только одно отличие - Seek и Size оперируют не с количеством байт, а с количеством записей.

Идем дальше. Есть такое понятие как нетипизированный файл. Это такой файл который содержит разнородные элементы. Например файл EXE - вначале он имеет заголовок, затем двоичный код, в конце какие-то ресурсы. Все части файла имеют разную длину и разную структуру. Тут уже обратится к произвольному элементу сложно, обычно надо вначале узнать где этот элемент находится, подчас это записано в предыдущем куске информации. Работа с такими файлами достаточно сложна и требует вручную разработки алгоритмов его чтения, но в связи гибкостью структуры и компактностью такие файлы составляют большинство. Для работы с нетипизированными файлами используют процедуры BlockRead и BlockWrite, которые позволяют читать/писать произвольное количество байт. Привожу пример пользования этими функциями из справки по Дельфи:

Исходный код:

var  
 FromF, ToF: file;  
 NumRead, NumWritten: Integer;  
 Buf: array[1..2048] of Char;  
begin  
 if OpenDialog1.Execute then                               { Display Open dialog box }  
 begin  
   AssignFile(FromF, OpenDialog1.FileName);  
   Reset(FromF, 1); { Record size = 1 }  
   if SaveDialog1.Execute then                              { Display Save dialog box}  
   begin  
     AssignFile(ToF, SaveDialog1.FileName); { Open output file }  
     Rewrite(ToF, 1); { Record size = 1 }  
     Canvas.TextOut(10, 10, 'Copying ' + IntToStr(FileSize(FromF))  
       + ' bytes...');  
     repeat  
       BlockRead(FromF, Buf, SizeOf(Buf), NumRead);  
       BlockWrite(ToF, Buf, NumRead, NumWritten);  
     until (NumRead = 0) or (NumWritten <> NumRead);  
       CloseFile(FromF);  
       CloseFile(ToF);  
   end;  
 end;  
end;  

Этот код копирует из одного файла в другой. Замечания по поводу этого метода работы с файлами - плюсы - очень высокая скорость, особенно если размер буффера увеличить до 64kb-512kb, что позволит считывать файл достаточно большими кусками, чтобы обеспечить отсутствие простоев винчестера, к тому же обеспечивается очень высокая гибкость в работе. Минусы - сложность разработки, необходимость вручную писать все детали механизма чтения/записи и интерпретации данных.

Пожалуй на этом можно было бы и завершить описание работы с файлами средствами Паскаля и файловых переменных, но заглянув в Help Дельфей я обнаружил еще несколько функций достойных упоминания.

Erase(f) - удаляет файл
FilePos(f) - возвращает текущую позицию чтения/записи в файл
Flush(f) - сбрасывает кэшированные файловые операции на диск
Rename(f, 'MyNewFileName.txt') - переименование файлов
Truncate(f) - файл обрезается до текущей позиции чтения/записи
Теперь разберем возможности работы потомка TStream - TFileStream - файловый поток. Этот класс был специально введен для работы с файлами. Для работы с файловым потоком Вам надо записать в Uses модули classes, Sysutils (classes - включает в себя собственно определение класса, Sysutils - некоторые константы необходимые для работы).

Вот пример записи/перезаписи файла:

Исходный код:

Procedure WriteFileUsingStream(s, FileName:string);  
begin  
 with TFileStream.create(FileName, fmCreate or fmOpenWrite) do  
   try  
     write(pointer(s)^,length(s));  
   finally  
     free;  
   end;  
end;  

Теперь небольшой разбор:

TFileStream.create - конструктор класса, его вызов требует указания имени файла и опций его открытия, следующие опции определены:


fmCreate = $FFFF;  
fmOpenRead       = $0000;  
fmOpenWrite      = $0001;  
fmOpenReadWrite  = $0002;  
fmShareCompat    = $0000;  
fmShareExclusive = $0010;  
fmShareDenyWrite = $0020;  
fmShareDenyRead  = $0030;  
fmShareDenyNone  = $0040;  

Теперь метод Write - этим методом в файл пишется любая информация из буфера любого типа, Вам надо указать только буффер и количество записываемых байтов. В данном случае используется переменная типа String в качестве буффера, но так как для длинных строк она представляет собой лишь указатель, то конструкция "pointer(s)^" заставляет обращаться именно к ее содержимому.

Продолжение следует.
А вот этот код демонстрирует чтение файла с использованием файлового потока:

Исходный код:

 var p:PChar;  
begin  
 GetMem(p, 255);  
 with TFileStream.create('c:\\myText.txt', fmOpenReadWrite) do  
   try  
     Seek(10,soFromBeginning);  
     read(p^, 254);  
   finally  
     free;  
   end;  
 showmessage(p);  
 FreeMem(p);  
end;  

И пояснения к коду:
1) Никаких проверок длину файла и его наличие здесь не делается - это демонстрационный код, а не готовая процедура чтения.
2) Файл мы считываем в буффер типа PChar (с тем же успехом можно использовать массив или любой другой контейнер). Для тех кто не помнит - процедуры GetMem(p, 255) и FreeMem(p) - распределение памяти для строки и освобождение памяти.
3) Метод потока Seek позволяет установить текущую позицию считывания/записи файла. Первый параметер - номер байта, второй - это от чего считать этот байт (у нас считать от начала файла), возможны варианты:
soFromBeginning - от начала файла
soFromCurrent - от текущей позиции считывания
soFromEnd - от конца файла (в этом случае номер байта должен быть отрицательным или равным нулю)
4) Собственно считывание из потока осуществляется методом read, в котором указывается в качестве параметров буфер в который мы читаем и желаемое количество байт для чтения. Метод read является функцией, которая возвращает количество байт реально прочитанных из потока.

Заканчивая о файловых потоках хочу упомянуть о методе
CopyFrom который позволяет перекачивать информацию из одного потока в другой и о свойствах:

Size - размер файла
Position - текущая позиция чтения/записи потока

Работа с файловыми потоками весьма быстра, этот класс, являсь классом VCL, в то же время базируется на низкоуровневых функциях Windows, что обеспечивает очень высокую скорость работы и стабильность операций. К тому же многие компоненты и классы VCL поддерживаю прямое чтение и запись с файловыми потоками, что занчительно упрощает работу - например TStringList, TBlobField, TMemoField и другие.
Файловые потоки могут быть рекомендованы к использованию в большинстве случаев для чтения и записи файлов (за исключением специфических ситуаций, требующих каких-то других подходов), другими словами если вам надо просто записать или считать файл, используйте файловые потоки.

Еще один способ работы с файлами - это открытие Handle на файл и работу через него. Тут есть 2 варианта - можно использовать функции Дельфи или использовать WinAPI напрямую.

При использовании функций Дельфи можно применять следующие функции:

FileOpen(FileName, fmOpenWrite or fmShareDenyNone) - функция открывает файл и возвращает целое цисло - Handle на файл. Параметры функции - имя файла и тип доступа (все типы доступа я перечислил ранее). Если файл успешно открыт то Handle должен быть положительным цислом, отрицательное число - это код ошибки.

Во всех остальных функциях используется именно значение Handle, возвращаемое этой функцией.

FileClose(Handle: Integer) - закрывает файл


FileRead(Handle: Integer; var Buffer; Count: Integer): Integer;  
  
FileWrite(Handle: Integer; const Buffer; Count: Integer):   
                Integer;  

Эти функции для чтения/записи файла, где Buffer любая переменная достаточного размера для чтения/записи куска информации (обычно типа PChar или массив), Count-количество байт, которое Вы желаете записать/прочитать. Функции возвращают количество байт которые реально были прочитанны или записаны.

Этот тип доступа к файлам применяется весьма редко. Дело в том что он практически дублирует соответствующие функции WinAPI и к тому же обычно работает несколько медленнее, чем например потоки. И все же использование функций FileOpen и FileClose не лишено привлекательности. Наряду с тем что эти функции намного легче в использовании соответствующих функций WinAPI (можете сравнить - FileOpen имеет 2 параметра, cooтветствующая функция WinAPI - CreateFile имеет 7 параметров, большая часть из которых реально требуется лишь в ограниченном числе случаев) этот путь доступа открывает возможность прямого использования всех функций WinAPI про работе с файлами, которые требуют Handle на открытый файл.

Дельфи предоставляет довольно широкие возможности по файловым операциям без использования механизмов открытия/закрытия файлов.

Вот список наиболее употребимых функций, большинство из которых в фачкстве параметров нуждаются только в имени файла:

ChDir(NewCurrentPath: string); - изменяет текущий каталог (в среде Windows сие конечно не так актуально как в ДОС, но все же), прочитать же текущий каталог можно функцией GetCurrentDir, а текущий каталог для определенного драйва - GetDir.

CreateDir(const Dir: string): Boolean; - создает каталог. При этом предыдущий уровень должен присутствовать. Если вы хотите сразу создать всю вложенность каталогов используйте функцию ForceDirectories(Dir: string): Boolean; Обе функции возвращают True если каталог создан

DiskFree(Drive: Byte): Int64; - дает свободное место на диске. Параметер - номер диска 0 = текущий, 1 = A, 2 = B, и так далее

DiskSize(Drive: Byte): Int64; - размер винта. Обратите внимание на то что для результата этой и предыдущей функций абсолютно необходимо использовать переменную типа Int64, иначе макимум того что вы сможете прочитать правильно будет ограничен 2Gb

FileExists(const FileName: string) - применяется для проверки наличия файла

FileGetAttr(const FileName: string): Integer;
FileSetAttr(const FileName: string; Attr: Integer): Integer; - функции для работы с атрибутами файлов. Вот список возможных атрибутов:
faReadOnly $00000001 Read-only files
faHidden $00000002 Hidden files
faSysFile $00000004 System files
faVolumeID $00000008 Volume ID files
faDirectory $00000010 Directory files
faArchive $00000020 Archive files
faAnyFile $0000003F Any file
(Естественно не все атрибуты применимы во всех случаях)

RemoveDir(const Dir: string): Boolean; - удаляет папку(пустую)
DeleteFile(const FileName: string): Boolean; - удаляет файл
RenameFile(const OldName, NewName: string) - переименовывает файл

Привожу пример функции которая собирает довольно большое количество информации о выбранном файле:

Исходный код:

Type TFileInfo=record  
                Exists:boolean;//true если файл найден  
                Name:String; //имя файла с расширением  
                ShortName:String;//DOS 8.3 имя файла  
                NameNoExt:String;//имя файла без расширения  
                Extension:string;//расширение файла  
                AssociatedFile:string;//программа с которой ассоциирован файл  
                Path:string;// путь к файлу  
                ShortPath:string;// DOS 8.3 путь файла  
                Drive:string;// дисковод на котором находится файл  
                CreateDate:TDateTime; //время когда файл создан  
                Size:Int64;// размер файла (работает для файлов и больше 2Gb)  
                Attributes:record //нали÷ие/отсутствие системных атрибутов  
                             ReadOnly:boolean;  
                             Hidden:boolean;  
                             System:boolean;  
                             Archive:boolean;  
                           end;  
                ModifyDate:TDateTime; //время последнего изменения файла  
                LastAccessDate:TDateTime; //дата последнего открытия  
              end;  
  
  
Function ReadFileInfo(FileName:string):TFileInfo;  
var ts:TSearchRec;  
  
  Function FileTime2DateTime(FT:_FileTime):TDateTime;  
  var FileTime:_SystemTime;  
  begin  
     FileTimeToLocalFileTime(FT, FT);  
     FileTimeToSystemTime(FT,FileTime);  
     Result:=EncodeDate(FileTime.wYear, FileTime.wMonth, FileTime.wDay)+  
             EncodeTime(FileTime.wHour, FileTime.wMinute, FileTime.wSecond, FileTime.wMilliseconds);  
  end;  
  
  Function AssociatedFile(FileExt:string):string;  
    var key:string;  
  begin  
    With TRegistry.create do  
      try  
        RootKey:=HKEY_CLASSES_ROOT;  
        OpenKey(FileExt, false);  
        Key:=ReadString('');  
        CloseKey;  
        OpenKey(key+'\\Shell\\open\\command', false);  
        result:=ReadString('');  
        Closekey;  
      finally  
        free;  
      end  
  end;  
  
begin  
 Result.Name:=ExtractFileName(FileName);  
 Result.Extension:=ExtractFileExt(FileName);  
 Result.NameNoExt:=Copy(Result.Name,1,length(Result.Name)-length(Result.Extension));  
 Result.Path:=ExtractFilePath(FileName);  
 Result.Drive:=ExtractFileDrive(FileName);  
 Result.ShortPath:=ExtractShortPathName(ExtractFilePath(FileName));  
 if lowercase(Result.Extension)<>'.exe' then Result.AssociatedFile:=AssociatedFile(Result.Extension);  
 if FindFirst(FileName, faAnyFile, ts)=0 then  
   begin  
 Result.Exists:=true;  
     Result.CreateDate:=FileDateToDateTime(ts.Time);  
  
Result.Size:=ts.FindData.nFileSizeHigh*4294967296+ts.FindData.nFileSizeLow;  
     Result.Attributes.ReadOnly:=(faReadOnly and ts.Attr)>0;  
     Result.Attributes.Hidden:=(faHidden and ts.Attr)>0;  
     Result.Attributes.System:=(faSysFile and ts.Attr)>0;  
     Result.Attributes.Archive:=(faArchive and ts.Attr)>0;  
     Result.ModifyDate:=FileTime2DateTime(ts.FindData.ftLastWriteTime);  
     Result.LastAccessDate:=FileTime2DateTime(ts.FindData.ftLastAccessTime);  
     Result.ShortName:=ts.FindData.cAlternateFileName;  
     Findclose(ts);  
   end  
 else Result.Exists:=false;  
end;  

Скорее всего эта функция как есть вряд ли понадобится, так как наверняка бОльшее количество определяемых параметров избыточно, тем ни менее может кому пригодится как пример выяснения информации о файле.

Теперь поговорим о поиске файлов. Для этой цели могут использоваться процедуры FindFirst, FindNext, FindClose, при участии переменной типа TSearchRec которая хранит информацию о текущем статусе поиска и характеристики последнего найденного файла.

Пример иллюстрирующий поиск всех файлов и каталогов в определенном каталоге:

Исходный код:

Var SearchRec:TSearchRec;  
...  
  If FindFirst('c:\\Windows\\*.*', faAnyFile, SearchRec)=0 then  
     repeat  
        {Вот здесь мы можем делать с найденным файлом ÷то угодно 
         SearchRec.name - имя файла 
         ExpandFileName(SearchRec.name) - имя файла с полным путем}  
     until FindNext(SearchRec) <> 0;  
     FindClose(SearchRec);  

Примечания по приведенному коду:
1) Первыми в список могут попадать файлы с именами "." и ".." - это ДОСовские имена для переходов на "родительский уровень", иногда нужна обработка для их игнорирования.
2) FindFirst в качестве первого параметра принимает шаблон для поиска, так как он был принят для ДОС. Если шаблон не включает путь то файлы будут искаться в текущем каталоге.
3) FindFirst требует задания атрибута для файла - здесь мы искали все файлы, если надо какие-то определенные (например только скрытые, или только каталоги) то надо это указать, список всех атрибутов я уже приводил выше.
4) SearchRec переменная связывает во едино FindFirst и FindNext, но требует ресурсов для своей работы, поэтому желательно ее освободить после поиска процедурой FindClose(SearchRec) - на самом деле утечки памяти небольшие, но если программа работает в цикле и долгое время пожирание ресурсов будет значительным.
5)FindFirst/FindNext - работают не открывая файлы, поэтому они корректно находят даже Swap файлы Windows...

Добавлено: 04 Августа 2018 14:42:37 Добавил: Андрей Ковальчук

Работа со строками и символами

Введение
Обработка текста - одна из часто встречающихся задач программирования. Если требуется обработать какие-либо текстовые данные, то без знаний того материала, что будет изложен ниже, просто не обойтись. Особенно, если данные сформированы не лично вами, а какой-либо сторонней программой или другим человеком.

Символы
Символ - это одна единица текста. Это буква, цифра, какой-либо знак. Кодовая таблица символов состоит из 256 позиций, т.е. каждый символ имеет свой уникальный код от 0 до 255. Символ с некоторым кодом N записывают так: #N. Прямо так символы и указываются в коде программы. Так как код символа представляет собой число не более 255, то очевидно, что в памяти символ занимает 1 байт. Как известно, менее байта размерности нет. Точнее, она есть - это бит, но работать с битами в программе мы не можем: байт - минимальная единица. Просмотреть таблицу символов и их коды можно с помощью стандартной утилиты "Таблица символов", входящей в Windows (ярлык расположен в меню Пуск - Программы - Стандартные - Служебные). Но совсем скоро мы и сами напишем нечто подобное.

Строки
Строка, она же текст - это набор символов, любая их последовательность. Соответственно, один символ - это тоже строка, тоже текст. Текстовая строка имеет определённую длину. Длина строки - это количество символов, которые она содержит. Если один символ занимает 1 байт, то строка из N символов занимает соответственно N байт.
Есть и другие кодовые таблицы, в которых 1 символ представлен не одним байтом, а двумя. Это Юникод (Unicode). В таблице Юникода есть символы всех языков мира. К сожалению, работа с Юникодом довольно затруднена и его поддержка пока что носит лишь локальный характер. Delphi не предоставляет возможностей для работы с Юникодом. Программная часть есть, но вот визуальные элементы - формы, кнопки и т.д. не умеют отображать текст в формате Юникода. Будем надеяться, в ближайшем будущем такая поддержка появится. 2 байта также называют словом (word). Отсюда и название соответствующего числового типа данных - Word (число, занимающее в памяти 2 байта, значения от 0 до 65535). Количество "ячеек" в таблице Юникода составляет 65536 и этого вполне достаточно для хранения всех языков мира. Если вы решили, что "1 байт - 256 значений, значит 2 байта - 2*256 = 512 значений", советую вспомнить двоичную систему и принцип хранения данных в компьютере.

Типы данных
Перейдём непосредственно к программированию. Для работы с символами и строками существуют соответствующие типы данных:

Char - один символ (т.е. 1 байт);
String - строка символов, текст (N байт).

Официально строки вмещают лишь 255 символов, однако в Delphi в строку можно записать гораздо больше. Для хранения больших текстов и текстов со специальными символами существуют специальные типы данных AnsiString и WideString (последний, кстати, двухбайтовый, т.е. для Юникода).

Для задания текстовых значений в Pascal используются одинарные кавычки (не двойные!). Т.е. когда вы хотите присвоить строковой переменной какое-либо значение, следует сделать это так:


s:='text';  

Символы указываются аналогично, только в кавычках присутствует один-единственный символ.

Если вы хотите жёстко ограничить длину текста, хранимого в строковой переменной, можно сделать это следующим образом:


var s: string[10];  

В скобках указывается максимальная длина строки.

Операции со строками
Основной операцией со строками является сложение. Подобно числам, строки можно складывать. И если в числах стулья с апельсинами складывать нельзя, то в строках - можно. Сложение строк - это просто их объединение. Пример:


var s: string;  
...  
s:='123'+'456';  
//s = "123456"  

Поскольку каждая строка - это последовательность символов, каждый символ имеет свой порядковый номер. В Pascal нумерация символов в строках начинается с 1. Т.е. в строке "ABC" символ "A" - первый, "B" - второй и т.д.
Порядковый номер символа в строке придуман не случайно, ведь именно по этим номерам, индексам, осуществляются действия над строками. Получить любой символ из строки можно указанием его номера в квадратных скобках рядом с именем переменной. Например:


var s: string; c: char;   
...  
s:='Hello!';  
c:=s[2];  
//c = "e"  

Чуть позже, когда мы будем изучать массивы, станет понятно, что строка - это массив символов. Отсюда следует и форма обращения к отдельным символам.

Обработка строк
Перейдём к функциям и процедурам обработки строк.

Длина строки

Длину строки можно узнать с помощью функции Length(). Функция принимает единственный параметр - строку, а возвращает её длину. Пример:


var Str: String; L: Integer;   
{ ... }   
Str:='Hello!';   
L:=Length(Str);  
//L = 6  

Нахождение подстроки в строке

Неотъемлемой задачей является нахождение подстроки в строке. Т.е. задача формулируется так: есть строка S1. Определить, начиная с какой позиции в неё входит строка S2. Без выполнения этой операции ни одну обработку представить невозможно.
Итак, для такого нахождения существует функция Pos(). Функция принимает два параметра: первый - подстроку, которую нужно найти, второй - строку, в которой нужно выполнить поиск. Поиск осуществляется с учётом регистра символов. Если функция нашла вхождение подстроки в строку, возвращается номер позиции её первого вхождения. Если вхождение не найдено, функция даёт результат 0. Пример:


var Str1, Str2: String; P: Integer;   
{ ... }   
Str1:='Hi! How do you do?';   
Str2:='do';   
P:=Pos(Str2, Str1);  
//P = 9  

Удаление части строки

Удалить часть строки можно процедурой Delete(). Следует обратить внимание, что это именно процедура, а не функция - она производит действия непосредственно над той переменной, которая ей передана. Итак, первый параметр - переменная строкового типа, из которой удаляется фрагмент (именно переменная! конкретное значение не задаётся, т.к. процедура не возвращает результат), второй параметр - номер символа, начиная с которого нужно удалить фрагмент, третий параметр - количество символов для удаления. Пример:


var Str1: String;   
{ ... }   
Str1:='Hello, world!';   
Delete(Str1, 6, 7);  
// Str1 = "Hello!"  

Следует отметить, что если длина удаляемого фрагмента окажется больше количества символов в строке, начиная с указанной позиции (т.е. "вылезем за край"), функция нормально отработает. Поэтому, если нужно удалить фрагмент из строки с какого-то символа до конца, не нужно вычислять количество этих символов. Лучшим способом будет задать длину самой этой строки.

Вот пример. Допустим, требуется найти в строке первую букву "a" и удалить следующую за ней часть строки. Сделаем следующим образом: позицию буквы в строке найдём функцией Pos(), а фрагмент удалим функцией Delete().


var Str: String;   
{ ... }   
Str:='This is a test.';  
Delete(Str,Pos('a',Str),Length(Str));  

Попробуем подставить значения и посмотреть, что передаётся функции Delete. Первая буква "a" в строке стоит на позиции 9. Длина всей строки - 15 символов. Значит вызов функции происходит такой: Delete(Str,9,15). Видно, что от буквы "a" до конца строки всего 7 символов... Но функция сделает своё дело, не смотря на эту разницу. Результатом, конечно, будет строка "This is ". Данный пример одновременно показал и комбинирование нескольких функций.

Копирование (извлечение) части строки

Ещё одной важной задачей является копирование части строки. Например, извлечение из текста отдельных слов. Выделить фрагмент строки можно удалением лишних частей, но этот способ неудобен. Функция Copy() позволяет скопировать из строки указанную часть. Функция принимает 3 параметра: текст (строку), откуда копировать, номер символа, начиная с которого скопировать и количество символов для копирования. Результатом работы функции и будет фрагмент строки.

Пример: пусть требуется выделить из предложения первое слово (слова разделены пробелом). На форме разместим Edit1 (TEdit), в который будет введено предложение. Операцию будет выполнять по нажатию на кнопку. Имеем:


procedure TForm1.Button1Click(Sender: TObject);  
var s,word: string;  
begin  
  s:=Edit1.Text;  
  word:=Copy(s,1,Pos(' ',s)-1);  
  ShowMessage('Первое слово: '+word);  
end;  

В данном случае из строки копируется фрагмент от начала до первого пробела. Число символов берётся на единицу меньше, т.к. в противном случае пробел также будет скопирован.

Вставка подстроки в строку

Если требуется в имеющуюся строку вставить другую строку, можно использовать процедуру Insert(). Первый параметр - строка для вставки, второй - переменная, содержащая строку, куда нужно вставить, третий - позиция (номер символа), начиная с которого будет вставлена строка. Пример:


procedure TForm2.Button1Click(Sender: TObject);  
var S: String;  
begin  
  S:='1234567890';  
  Insert('000',S,3);  
  ShowMessage(S)  
  
end;  

В данном случае результатом будет строка "1200034567890".

Пример "посерьёзнее"
Примеры, приведённые выше, лишь демонстрируют принцип работы со строками с помощью функций Length(), Pos(), Delete() и Copy(). Теперь решим задачу посложнее, которая потребует комбинированного применения этих функций.

Задача: текст, введённый в поле Memo, разбить на слова и вывести их в ListBox по одному на строке. Слова отделяются друг от друга пробелами, точками, запятыми, восклицательными и вопросительными знаками. Помимо этого вывести общее количество слов в тексте и самое длинное из этих слов.

Вот уж да... Задача вовсе не простая. Во-первых, вы сразу должны догадаться, что нужно использовать циклы. Без них никак, ведь мы не знаем, какой текст будет передан программе для обработки. Во-вторых, слова отделяются разными символами - это создаёт дополнительные трудности. Что ж, пойдём по порядку.

Интерфейс: Memo1 (TMemo), Button1 (TButton), ListBox1 (TListBox), Label1, Label2 (TLabel).

Сначала перенесём введённый текст в переменную. Для того, чтобы разом взять весь текст из Memo, обратимся к свойству Lines.Text:


procedure TForm1.Button1Click(Sender: TObject);  
var Text: string;  
begin  
  Text:=Memo1.Lines.Text;  
end;  

Теперь перейдём к обработке. Первое, что нужно сделать - разобраться с символами-разделителями. Дело в том, что такие символы могут запросто идти подряд, ведь после запятых, точек и других знаков ставится пробел. Обойти эту трудность можно таким простым способом: все разделяющие символы заменим на какой-то один, например на запятую. Для этого пройдём все символы и сделаем необходимые замены. Чтобы определить, является ли символ разделителем, запишем все разделители в отдельную строковую переменную (константу), а затем будем искать в этой строке каждый символ функцией Pos(). Все эти замены будут производиться в переменной, чтобы оригинальный текст в Memo (т.е. на экране) не был затронут. Тем не менее, для проверки промежуточных результатов работы имеет смысл выводить обработанный текст куда-либо. Например, в другое поле Memo. Чтобы пройти все символы, воспользуемся циклом FOR, где переменная пройдёт порядковые номера всех символов, т.е. от 1 до длины строки текста:


procedure TForm1.Button1Click(Sender: TObject);  
const DelSym = ' .,!?';  
var Text: string; i: integer;  
begin  
  Text:=Memo1.Lines.Text;  
  for i := 1 to Length(Text) do  
    if Pos(Text[i],DelSym) > 0 then  
      Text[i]:=',';  
   
  Memo2.Text:=Text;  
end;  

Теперь нужно устранить помехи. Во-первых, первый символ не должен быть разделителем, т.е. если первый символ - запятая, его нужно удалить. Далее, если подряд идут несколько запятых, их нужно заменить на одну. И наконец, чтобы корректно обработать весь текст, последним символом должна быть запятая.


if Text[1] = ',' then  
    Delete(Text,1,1);  
while Pos(',,',Text) > 0 do  
  Delete(Text,Pos(',,',Text),1);  
if Text[Length(Text)] <> ',' then  
  Text:=Text+',';  

Здесь замена произведена следующим образом: организован цикл, в котором одна из запятых удаляется, но происходит это до тех пор, пока в тексте есть две идущие подряд запятые.

Ну вот, теперь в тексте не осталось ничего лишнего - только слова, разделённые запятыми. Сначала добьёмся того, чтобы программа извлекла из текста первое слово. Для этого найдём первую запятую, скопируем слово от начала текста до этой запятой, после чего удалим это слово из текста вместе с запятой. Удаление делается для того, чтобы далее можно было, проделав ту же самую операцию, вырезать следующее слово.


var Word: string;  
{...}  
Word:=Copy(Text,1,Pos(',',Text)-1);  
Delete(Text,1,Length(Word)+1);  

Теперь в переменной Word у нас слово из текста, а в переменной Text вся остальная часть текста. Вырезанное слово теперь добавляем в ListBox, вызывая ListBox.Items.Add(строка_для_добавления).

Теперь нам нужно организовать такой цикл, который позволил бы вырезать из текста все слова, а не только первое. В данном случае подойдёт скорее REPEAT, чем WHILE. В качестве условия следует указать Length(Text) = 0, т.е. завершить цикл тогда, когда текст станет пустым, т.е. когда мы вырежем из него все слова.


repeat  
  Word:=Copy(Text,1,Pos(',',Text)-1);  
  Delete(Text,1,Length(Word)+1);  
  ListBox1.Items.Add(Word);  
until Length(Text) = 0;  

Итак, на данный момент имеем:


procedure TForm1.Button1Click(Sender: TObject);  
const DelSym = ' .,!?';  
var Text,Word: string; i: integer;  
begin  
  Text:=Memo1.Lines.Text;  
  for i := 1 to Length(Text) do  
    if Pos(Text[i],DelSym) > 0 then  
      Text[i]:=',';  
   
  if Text[1] = ',' then  
    Delete(Text,1,1);  
  while Pos(',,',Text) > 0 do  
    Delete(Text,Pos(',,',Text),1);  
      
  repeat  
    Word:=Copy(Text,1,Pos(',',Text)-1);  
    Delete(Text,1,Length(Word)+1);  
    ListBox1.Items.Add(Word);  
  until Length(Text) = 0;  
end;  

Если вы сейчас запустите программу, то увидите, что всё отлично работает. За исключением одного момента - в ListBox в конце появились какие-то пустые строки... Возникает вопрос: откуда же они взялись? Об этом вы узнаете в следующем разделе урока, а пока давайте реализуем требуемое до конца.

Количество слов в тексте определить очень просто - не нужно заново ничего писать. Т.к. слова у нас занесены в ListBox, достаточно просто узнать, сколько там строк - ListBox.Items.Count.


Label1.Caption:='Количество слов в тексте: '+IntToStr(ListBox1.Items.Count);  

Теперь нужно найти самое длинное из всех слов. Алгоритм нахождения максимального числа таков: принимаем в качестве максимального первое из чисел. Затем проверяем все остальные числа таким образом: если число больше того, которое сейчас записано как максимальное, делаем максимальным это число. В нашем случае нужно искать максимальную длину слова. Для этого можно добавить код в цикл вырезания слов из текста или произвести поиск после добавления всех слов в ListBox. Сделаем вторым способом: организуем цикл по строкам ListBox. Следует отметить, что строки нумеруются с нуля, а не с единицы! В отдельной переменной будем хранить самое длинное слово. Казалось бы, нужно ведь ещё хранить максимальную длину слова, чтобы было с чем сравнивать... Но не нужно заводить для этого отдельную переменную, ведь мы всегда можем узнать длину слова функцией Length(). Итак, предположим, что первое слово самое длинное...


var LongestWord: string;  
{...}  
  LongestWord:=ListBox1.Items[0];  
  for i := 1 to ListBox1.Items.Count-1 do  
    if Length(ListBox1.Items[i]) > Length(LongestWord) then  
      LongestWord:=ListBox1.Items[i];  
   
  Label2.Caption:='Самое длинное слово: '+LongestWord+' ('+IntToStr(Length(LongestWord))+' букв)';  

Почему цикл до ListBox.Items.Count-1, а не просто до Count, разберитесь самостоятельно :-)

Вот теперь всё готово!


procedure TForm1.Button1Click(Sender: TObject);  
const DelSym = ' .,!?';  
var Text,Word,LongestWord: string; i: integer;  
begin  
  Text:=Memo1.Lines.Text;  
  for i := 1 to Length(Text) do  
    if Pos(Text[i],DelSym) > 0 then  
      Text[i]:=',';  
   
  if Text[1] = ',' then  
    Delete(Text,1,1);  
  while Pos(',,',Text) > 0 do  
    Delete(Text,Pos(',,',Text),1);  
   
  Text:=AnsiReplaceText(Text,Chr(13),'');  
  Text:=AnsiReplaceText(Text,Chr(10),'');  
   
  repeat  
    Word:=Copy(Text,1,Pos(',',Text)-1);  
    Delete(Text,1,Length(Word)+1);  
    ListBox1.Items.Add(Word);  
  until Length(Text) = 0;  
   
  Label1.Caption:='Количество слов в тексте: '+IntToStr(ListBox1.Items.Count);  
   
  LongestWord:=ListBox1.Items[0];  
  for i := 1 to ListBox1.Items.Count-1 do  
    if Length(ListBox1.Items[i]) > Length(LongestWord) then  
      LongestWord:=ListBox1.Items[i];  
   
  Label2.Caption:='Самое длинное слово: '+LongestWord+' ('+IntToStr(Length(LongestWord))+' букв)';  
end;  

Работа с символами
Собственно, работа с символами сводится к использованию двух основных функций - Ord() и Chr(). С ними мы уже встречались. Функция Ord() возвращает код указанного символа, а функция Chr() - наоборот, возвращает символ с указанным кодом.

Помните "Таблицу символов"? Давайте сделаем её сами!

Вывод осуществим в TStringGrid. Этот компонент представляет собой таблицу, где в каждой ячейке записано текстовое значение. Компонент расположен на вкладке Additional (по умолчанию следует прямо за Standard). Перво-наперво настроим нашу табличку. Нам нужны всего две колонки: в одной будем отображать код символа, а в другой - сам символ. Количество колонок задаётся в свойстве с логичным названием ColCount. Устанавливаем его равным 2. По умолчанию у StringGrid задан один фиксированный столбец и одна фиксированная строка (они отображаются серым цветом). Столбец нам не нужен, а вот строка очень кстати, поэтому ставим FixedCols = 0, а FixedRows оставляем = 1.

Заполнение осуществим прямо при запуске программы, т.е. не будем ставить никаких кнопок. Итак, создаём обработчик события OnCreate() формы.

Количество символов в кодовой таблице 256, плюс заголовок - итого 257. Зададим число строк программно (хотя можно задать и в Инспекторе Объекта):


procedure TForm1.FormCreate(Sender: TObject);  
begin  
  StringGrid1.RowCount:=257;  
end;  

Вывод делается крайне просто - с помощью цикла. Просто проходим числа от 0 до 255 и выводим соответствующий символ. Также выводим надписи в заголовок. Доступ к ячейкам StringGrid осуществляется с помощью свойства Cells: Cells[номер_столбца,номер_строки]. В квадратных скобках указываются номера столбца и строки (начинаются с нуля). Значения текстовые.


procedure TForm1.FormCreate(Sender: TObject);  
var  
  i: Integer;  
begin  
  StringGrid1.RowCount:=257;  
  StringGrid1.Cells[0,0]:='Код';  
  StringGrid1.Cells[1,0]:='Символ';  
  for i := 0 to 255 do  
  begin  
    StringGrid1.Cells[0,i+1]:=IntToStr(i);  
    StringGrid1.Cells[1,i+1]:=Chr(i);  
  end;  
end;  

Запускаем, смотрим.

Специальные символы

Если вы внимательно посмотрите на нашу таблицу, то увидите, что многие символы отображаются в виде квадратиков. Нет, это не значки. Так отображаются символы, не имеющие визуального отображения. Т.е. символ, например, с кодом 13 существует, но он невидим. Эти символы используются в дополнительных целях. К примеру, символ #0 (т.е. символ с кодом 0) часто применяется для указания отсутствия символа. Существуют также строки, называемые null-terminated - это строки, заканчивающиеся символом #0. Такие строки используются в языке Си.
По кодам можно опознавать нажатия клавиш. К примеру, клавиша Enter имеет код 13, Escape - 27, пробел - 32, Tab - 9 и т.д.
Давайте добавим в нашу программу возможность узнать код любой клавиши. Для этого обработаем событие формы OnKeyPress(). Чтобы этот механизм работал, необходимо установить у формы KeyPreview = True.


procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);  
begin  
  ShowMessage('Код нажатой клавиши: '+IntToStr(Ord(Key)));  
end;  

Здесь мы выводим окошко с текстом. У события есть переменная Key, в которой хранится символ, соответствующий нажатой клавише. С помощью функции Ord() узнаём код этого символа, а затем функцией IntToStr() преобразуем это число в строку.

Пример "посерьёзнее" - продолжение
Вернёмся к нашему примеру. Пришло время выяснить, откуда в ListBox берутся пустые строки. Дело в том, что они не совсем пустые. Да, визуально они пусты, но на самом деле в каждой из них по 2 специальных символа. Это символы с кодами 13 и 10 (т.е. строка #13#10). В Windows такая последовательность этих двух невизуальных символов означает конец текущей строки и начало новой строки. Т.е. в любом файле и вообще где угодно переносы строк - это два символа. А весь текст, соответственно, остаётся непрерывной последовательностью символов. Эти символы можно (и даже нужно) использовать в случаях, когда требуется вставить перенос строки.

Доведём нашу программу по поиску слов до логического конца. Итак, чтобы избавиться от пустых строк, нам нужно удалить из текста символы #13 и #10. Сделать это можно с помощью цикла, по аналогии с тем, как мы делали замену двух запятых на одну:


while Pos(Chr(13),Text) > 0 do  
  Delete(Text,Pos(Chr(13),Text),1);  
   
while Pos(Chr(10),Text) > 0 do  
  Delete(Text,Pos(Chr(10),Text),1);  

Ну вот - теперь программа полностью работоспособна!

Дополнительные функции для работы со строками - модуль StrUtils
Дополнительный модуль StrUtils.pas содержит дополнительные функции для работы со строками. Среди этих функций множество полезных. А вот краткое описание часто используемых функций:

PosEx(подстрока, строка, отступ) - функция, аналогичная функции Pos(), но выполняющая поиск с указанной позиции (т.е. с отступом от начала строки). К примеру, если вы хотите найти в строке второй пробел, а не первый, без этой функции вам не обойтись. Чтобы сделать поиск второго пробела вручную, нужно предварительно вырезать часть из исходной строки.

AnsiReplaceStr, AnsiReplaceText (строка, текст_1, текст_2) - функции выполняют замену в строке строка строки текст_1 на текст_2. Функции отличаются только тем, что первая ведёт замену с учётом регистра символов, а вторая - без него.
В нашей программе можно использовать эти функции для вырезания из строки символов #13 и #10 - для этого в качестве текста для замены следует указать пустую строку. Вот решение в одну строку кода:


Text:=AnsiReplaceText(AnsiReplaceText(Text,Chr(13),''),Chr(10),'');  

DupeString(строка, число_повторений) - формирует строку, состоящую из строки строка путём повторения её заданное количество раз.

ReverseString(строка) - инвертирует строку ("123" -> "321").

Также следует упомянуть у функциях преобразования регистра.

UpperCase(строка) - преобразует строку в верхний регистр; LowerCase(строка) - преобразует строку в нижний регистр.

Для преобразования отдельных символов следует использовать эти же функции.

Подробную информацию о каждой функции можно получить, введя её название в любом месте редактора кода, установив курсор на это название (или выделив его) и нажав F1.

Скриншоты программ, описанных в статье

Программа извлечения слов из текста


Таблица символов

Заключение
Длинный получился урок... И как раз афоризм оказался в тему. Что удивительно, афоризм был подобран мной в самом начале, а сам урок написан позже :-)

Итак, сегодня мы познакомились со строками и символами и научились с ними работать. Изученные приёмы используются практически повсеместно. Не бойтесь экспериментировать - самостоятельно повышайте свой уровень навыков программирования!

Автор: © Ерёмин А.А., 2008

Добавлено: 04 Августа 2018 14:39:32 Добавил: Андрей Ковальчук

Процедуры и функции RX_lib

AppUtils unit:

AppBroadcast - Функция посылает сообщение Msg всем формам приложения.
FindForm - Функция перебирает формы приложения, проверяя для каждой из них, является ли она экземпляром класса FormClass
FindShowForm - Функция перебирает формы приложения, проверяя для каждой из них, является ли она экземпляром класса FormClass
GetDefaultIniName - Функция возвращает имя INI-файла "по умолчанию" для приложения.
GetDefaultIniRegKey - Функция возвращает имя ключа регистрационной базы данных Windows (Registry) "по умолчанию" для приложения
GetDefaultSection - Функция возвращает строку для указанной компоненты Component,
GetUniqueFileNameInDir - Возвращает уникальное для заданного каталога имя файла, InstantiateForm - функция создает экземпляр формы типа FormClass
ReadFormPlacement - Процедура ReadFormPlacement используется для восстановления формы
RestoreFormPlacement - Процедура RestoreFormPlacement используется для восстановл. формы
RestoreGridLayout - Восстанавливает из INI-файла ширины колонок компонент TCustomGrid
RestoreMDIChildren - Создает и показывает MDIChild-формы
SaveFormPlacement - Процедура используется для сохранения состояния формы
SaveGridLayout
SaveMDIChildren
ShowDialog - Создание и модальное исполнение диалога
WriteFormPlacement - Процедура используется для сохранения состояния формы,
BdeUtils unit:

AsyncQrySupported - Функция возвращает True, если драйвер специфицированной базы данных Database поддерживает асинхронное выполнение запросов
CheckOpen - Функция служит для обрамления вызовов функций BDE API, открыв. курсоры
ConvertStringToLogicType - Процедура предназначена для конвертации строки Value в BDE,
CurrentRecordDeleted - Функция определяет, является ли текущая запись набора данных удаленной (помеченной как удаленная) или нет
DataSetFindValue - Функция пытается установить набор данных, переданный в качестве параметра DataSet, на первую от начала запись, удовлетворяющую заданному условию
DataSetPositionStr - Для драйверов DBase и Paradox функция возвращает строку, содержащую текущий номер записи и полное число записей в DataSet
DataSetRecNo - Функция возвращает номер текущей записи в DataSet.
DataSetShowDeleted - Процедура устанавливает режим показа удаленных записей в таблицах формата DBase.
DeleteRange - Удаление диапазона записей из таблицы.
ExecuteQuery - Процедура предназначена для выполнения SQL-запросов
ExportDataSet - Процедура служит для экспорта данных из таблицы БД или результата запроса Source в выходную таблицу DestTable.
FetchAllRecords
FieldLogicMap - Функция возвращает для конкретного значения FldType получить для целочисленное значение, идентифицирующее логический тип данных BDE.
GetAliasPath - Функция возвращает физический путь для алиаса (псевдонима) BDE
GetBDEDirectory - Функция возвращает имя каталога, в котором установлены библиотеки BDE InitRSRun - Инициализация RUNTIME ReportSmith.
IsBookmarkStable - Return True, if specified DataSet supports stable bookmarks
PackTable - Процедура предназначена для "упаковки" таблиц формата DBase и Paradox
RestoreIndex - Восстанавливает свойство IndexFieldNames у Table
SetIndex -Устанавливает свойство IndexFieldNames у Table
SetToBookmark - Функция устанавливает ADataSet в позицию, соответствующую переданному значению ABookmark
TransActive - Функция определяет, имеет ли база данных Database активную транзакцию и в этом случае возвращает True, в противном случае результат - False.
BoxProcs unit:

BoxDragOver - Предполагается вызывать из обработчика события OnDragOver.
BoxMoveAllItems - Копирует все элементы SrcList в DstList, затем очищает SrcList.
BoxMoveFocusedItem - Предполагается использовать в обработчике события OnDragDrop.
BoxMoveSelectedItems - Перемещает выделенные элементы из SrcList в DstList
ClipIcon unit:

AssignClipboardIcon - Процедура заполняет иконку Icon данными из буфера обмена (Clipboard)
CopyIconToClipboard
CreateIconFromClipboard - Функция создает объект класса TIcon, если буфер обмена (Clipboard) содержит данные в формате CF_ICON.
CreateRealSizeIcon - Функция создает иконку из объекта Icon класса TIcon
DrawRealSizeIcon - Функция рисует иконку Icon на устройстве Canvas,
GetIconSize - Процедура возвращает ширину и высоту иконки,
DateUtil unit:

CutTime - Устанавливает время в переданном аргументе ADate в значение 00:00:00:00.
DateDiff - Определяет разницу между датами, заданными Date1 и Date2 в днях, месяцах и годах.
DaysBetween - Вычисляет число дней между датами Date1 и Date2,
DaysInPeriod - Вычисляет число дней между датами Date1 и Date2
DaysPerMonth
DefDateFormat - Функция возвращает строку формата даты по ShortDateFormat,
DefDateMask - Функция возвращает строку маски для ввода даты
FirstDayOfNextMonth
FirstDayOfPrevMonth
GetDateOrder - Функция возвращает порядок расположения дня, месяца и года в формате даты,
IncDate - Увеличивает дату ADate на заданное количество дней, месяцев и лет, возвращая полученную дату как результат.
IncDay - Увеличивает дату на заданное количество дней, возвращая полученную датуIncHour
IncMinute - Увеличивает время на заданное количество минут, возвращая полученное время IncMonth
IncMSec
IncSecond
IncTime - Увеличивает время на заданное количество часов, минут, секи мс, возвращая время IncYear
IsLeapYear- Проверяет является ли заданный параметром AYear год високосным.
LastDayOfPrevMonth
MonthsBetween
StrToDateDef - Функция преобразует строку в дату в соответствии с форматом ShortDateFormat
StrToDateFmt
StrToDateFmtDef
ValidDate - Функция определяет, представляет ли собой аргумент ADate действительное значение существующей даты.
DBFilter unit

DropAllFilters - Процедура деактивирует все фильтры, установленные ранее на набор данных DataSet, и освобождает захваченные ими ресурсы.
DBUtils unit:

AssignRecord - Процедура предназначена для копирования значений полей из текущей записи набора данных Source в поля текущей записи набора данных Dest,
CheckRequiredField - Процедура проверяет заполнение поля Field значением, отличным от NULL
ConfirmDataSetCancel - Процедура проверяет, находится ли переданный набор данных DataSet в режиме вставки или замены, модифицированы ли данные текущей записи, и если да, то запрашивает, надо ли сохранять сделанные изменения.
ConfirmDelete - Функция вызывает появление диалога с запросом подтверждения на удаление записи, аналогичного диалогу, появляющемуся у TDBGrid.
DataSetSortedSearch - Функция пытается установить набор данных, переданный в качестве параметра , на первую от начала запись, удовлетворяющую заданному условию
FormatAnsiSQLCondition - Функция сходна по назначению и результатам с FormatSQLCondition
FormatSQLCondition - Функция возвращает строковое выражение, соответствующее записи логического условия на языке SQL. Используется, в основном, для подстановки параметров (макросов) TRxQuery.
FormatSQLDateRange - Возвращает логическое условие для языка SQL нахождения значения поля, заданного FieldName в интервале, заданном Date1 и Date2. Учитываются особые случаи:
RefreshQuery - Процедура "обновляет" данные для набора данных
RestoreFields - Процедура восстанавливает из INI-файла IniFile аттрибуты полей набора данных, заданного в DataSet.
SaveFields
FileUtil unit:

BrowseComputer - BrowseComputer brings up a dialog to allow the user to select a network computer
BrowseDirectory
ClearDir
CopyFile
DeleteFiles
DeleteFilesEx
DirExists - The DirExists function determines whether the directory specified as the value of the Name parameter exists.
FileDateTime
FileLock - he FileLock function locks a region in an open file
FileUnlock
GetFileSize - Функция возвращает размер в байтах файла, заданного параметром FileName.
GetSystemDir - The GetSystemDir function retrieves the path of the Windows system directory
GetTempDir
GetWindowsDir
HasAttr - Функция возвращает True, если файл FileName имеет аттрибут Attr.
LongToShortFileName
LongToShortPath
MoveFile - Процедура перемещает или переименовывает FileName в файл с именем DestName.
NormalDir - Функция служит для нормализации имени каталога
ShortToLongFileName
ShortToLongPath
ValidFileName - Функция определяет, является ли имя, переданное как параметр FileName, допустимым именем файла.
MaxMin unit:

Max
MaxFloat - Функция MaxFloat возвращает наибольшее число из массива действительных чисел .
MaxInteger - Функция MaxInteger возвращает наибольшее число из массива целых чисел
MaxOf - Функция MaxOf возвращает наибольшее значение из массива значений Values
Min
MinFloat
MinInteger
MinOf
SwapInt - Процедура взаимно заменяет значения двух аргументов Int1 и Int2 между собой.
SwapLong
Parsing unit:

GetFormulaValue - Функция вычисляет результат математического выражения, заданного параметром Formula. Для вычислений используется объект типа TRxMathParser.
PickDate unit:

PopupDate - Функция PopupDate вызывает появление диалога выбора даты
SelectDate - Функция SelectDate позволяет пользователю выбрать дату, используя диалог выбора даты с календарем и кнопками навигации
SelectDateStr - Функция полностью аналогична функции SelectDate, за исключением того, что значение даты передается в нее в виде строки.
RxGraph unit:

BitmapToMemory
GetBitmapPixelFormat
GrayscaleBitmap - This procedure transforms a color bitmap image into grayscale
SaveBitmapToFile
SetBitmapPixelFormat - Процедура позволяет изменить число цветов (бит на пиксель), используемое для отрисовки битового изображения ABitmap
RxHook unit

FindVirtualMethodIndex - Функция находит индекс виртуального метода объекта класса AClass по адресу метода MethodAddr.
GetVirtualMethodAddress
SetVirtualMethodAddress
RxMenus Unit

procedure SetDefaultMenuFont(AFont: TFont);
RxShell unit

FileExecute
FileExecuteWait - Функция полностью аналогична функции FileExecute, но в отличие от нее приостанавливает выполнение вызвавшего ее потока до завершения запущенного приложения.
IconExtract - Функция создает объект класса TIcon из ресурсов исполнимого файла FileName
WinAbout - Процедура вызывает стандартное диалоговое окно "About" системы MSWindows.
Speedbar Unit

function FindSpeedBar(const Pos: TPoint): TSpeedBar;
SplshWnd Unit

ShowSplashWindow - Функция создает и отображает форму без заголовка с установленным стилем fsStayOnTop, которую можно использовать как заставку при загрузке приложения или при выполнении длительных операций
StrUtils unit:

AddChar - Добавляет слева к стpоке S символы C до длины S=N.
AddCharR - Добавляет справа к стpоке S символы C до длины S=N.
AnsiProperCase - Returns string, with the first letter of each word in uppercase, all other letters in lowercase.
CenterStr
CompStr - Сравнивает строки S1 и S2 (с учетом регистра)
CompText - Сравнивает строки S1 и S2 (без учета регистра)
Copy2Space - Копирует с начала строки до первого пробела.
Copy2SpaceDel - Копирует с начала строки до первого пробела и удаляет эту часть
Copy2Symb - Копирует с начала строки S до первого символа Symb и возвращает эту часть исходной строки.
Copy2SymbDel
Dec2Hex - Пpеобpазует целое число N в шестнадцатеричное число, дополняя слева нулями до длины A.
Dec2Numb - Пpеобpазует целое число N в число по основанию B, дополняя слева нулями до длины A.
DelBSpace - Функция удаляет ведущие пpобелы из стpоки S.
DelChars - Функция даляет все символы Сhr из строки S.
DelESpace - Функция удаляет конечные пpобелы из стpоки S.
DelRSpace - Функция удаляет начальные и конечные пpобелы из стpоки S.
DelSpace - Функция удаляет все пробелы из строки.
DelSpace1 - Функция удаляет все, кpоме одного, пpобелы из стpоки S.
ExtractDelimited - Функция аналогична функции ExtractWord
ExtractQuotedString - ExtractQuotedString removes the Quote characters from the beginning and end of a quoted string
ExtractSubstr - Функция предназначена для выделения подстроки из строки S, если подстроки разделены символами из набора Delims.
ExtractWord - Выделяет N-ое слово из строки S, используя WordDelims (типа TCharSet) как разделитель между словами.
ExtractWordPos - Выделяет N-ое слово из строки S, используя WordDelims (типа TCharSet) как разделитель между словами
FindCmdLineSwitch
FindPart - FindCmdLineSwitch determines whether a string was passed as a command line argument to the application.
GetCmdLineArg - GetCmdLineArg определяет, имеется ли параметр Switch среди параметров командной строки, переданных в приложение, и возвращает значение этого параметра
Hex2Dec - Пpеобpазует шестнадцатеpичное число в стpоке S в целое десятичное.
IntToRoman - IntToRoman converts the given value to a roman numeric string representation.
IsEmptyStr - Функция возвращает True, если строка S содержит только символы из EmptyChars.
IsWild - Функция IsWild сравнивает строку InputString со строкой WildCard, содержащей символы маски, и возвращает True, если строка InputStr соответствует маске.
IsWordPresent - Определяет, присутствует ли слово W в строке S, используя символы
WordDelims как возможные разделители между словами. LeftStr - Добавляет строку S до длины N справа.
MakeStr - Фоpмиpует стpоку из N символов C.
MS - Фоpмиpует стpоку из N символов C.
Npos - Ищет позицию N-го вхождения подстроки C в стpоке S.
Numb2Dec - Пpеобpазует число по основанию B в стpоке S в целое десятичное.
Numb2USA - Пpеобpазует числовую стpоку S к фоpмату США. Напpимеp: Входная стpока: '12365412'; Выходная стpока: '12,365,412'.
OemToAnsiStr - OemToAnsiStr translates a string from the OEM character set into the Windows character set.
QuotedString - QuotedString returns the given string as a quoted string, using the provided
Quote character.
ReplaceStr - Функция заменяет в строке S все вхождения подстроки Srch на подстроку, переданную в качестве аргумента Replace.
RightStr - Добавляет строку S до длины N слева.
RomanToInt - RomanToInt converts the given string to an integer value.
StrToOem - Конвертирует переданную в качестве аргумента AnsiStr строку (в ANSI-кодировке Windows) в кодировку OEM.
Tab2Space - Преобразует знаки табуляции в строке S в Numb пробелов.
WordCount - Считает число слов в строке S, используя параметр WordDelims (типа TCharSet) как разделитель между словами.
WordPosition - Возвращает позицию первого символа N-го слова в строке S, используя параметр WordDelims (типа TCharSet) как разделитель между словами.
VCLUtils unit:

ActivatePrevInstance - Функция ActivatePrevInstance предназначена для активизации предыдущей копии приложения
ActivateWindow - Процедура ActivateWindow активизирует окно Windows, обработчик которого специфицируется параметром Wnd.
AllocMemo - Функция предназначена для динамического выделения блока памяти размером Size.
AnsiUpperFirstChar - Функция приводит к верхнему регистру первый символ в переданной строке S, используя набор символов ANSI.
AssignBitmapCell - Процедура копирует прямоугольную область из картинки Source в битовое изображение Dest,
CenterControl - Процедура центрирует элемент управления Control относительно "родителя"
CenterWindow - Процедура центрирует окно Wnd на экране дисплея.
ChangeBitmapColor - создает новое графическое изображение, являющееся копией переданного, однако заменяя цвет всех точек изображения,
CompareMem - Функция CompareMem сравнивает содержимое двух блоков памяти
CopyParentImage - Процедура копирует в заданный контекст устройства Dest изображение,
CreateBitmapFromIcon
CreateIconFromBitmap
CreateRotatedFont - Создает "наклонный" шрифт
CreateTwoColorsBrushPattern - Функция создает битовое изображение, состоящее из точек двух цветов: Color1 и Color2, чередующихся в шахматном порядке.
DefineCursor - Загружает курсор из ресурса исполняемого модуля и определяет его уникальный индекс в массиве курсоров Screen.Cursors.
Delay - Процедура вызывает задержку выполнения программы на заданное параметром MSecs число миллисекунд.
DialogUnitsToPixelsX - Функция преобраз. диалоговые единицы в пиксели по горизонтали.
DialogUnitsToPixelsY
DrawBitmapRectTransparent - Процедура DrawBitmapRectTransparent рисует на устройстве Dest прямоугольный участок графического изображения
DrawBitmapTransparent - Процедура DrawBitmapTransparent рисует на устройстве Dest графическое изображение Bitmap
DrawCellBitmap - Процедура DrawCellBitmap предназначена для отрисовки битового изображения Bmp
DrawCellText - для отрисовки строки текста S в ячейке объекта - наследника TCustomGrid.
DrawInvertFrame - Процедура рисует на экране инвертированную рамку, определяемую координатами ScreenRect
FreeMemo - Процедура освобождает память, выделенную функцией AllocMemo.
FreeUnusedOLE
GetEnvVar - Возвращает значение переменной окружения DOS, заданной параметром VarName.
GetMemoSize - Функция GetMemoSize возвращает размер блока памяти, выделенного функцией
AllocMemo.
GetWindowsVersion - Функция возвращает версию Windows в виде строки, содержащей название платформы и номер версии операционной системы.
GradientFillRect - Процедура GradientFillRect рисует прямоугольник Rect на устройстве Canvas, цвет которого плавно изменяется от BeginColor до EndColor в направлении Direction.
HeightOf - Функция возвращает высоту (в пикселях) переданного прямоугольника R.
HugeDec - Decrement a huge pointer.
HugeInc
HugeMove
HugeOffset
ImageListDrawDisabled - Процедура рисует изображение из списка Images, заданное индексом Index, на устройстве Canvas с координатами X, Y
IsForegroundTask - Функция проверяет, является ли приложение, вызвавшее эту функцию, текущей активной (foreground) задачей Windows.
KillMessage - KillMessage deletes the requested message Msg from the window message queue
LoadAniCursor - The LoadAniCursor function loads the specified animated cursor resource from the executable (.EXE or .DLL) file associated with the specified application instance.
LoadDLL - Функция загружает динамическую библиотеку или модуль, заданный именем
LibName.
MakeBitmap - Функция создает объект класса TBitmap из ресурса вашего приложения.
MakeBitmapID - Функция создает объект класса TBitmap из ресурса вашего приложения.
MakeIcon - Функция создает объект класса TIcon из ресурса вашего приложения.
MakeIconID
MakeModuleBitmap - Функция создает объект класса TBitmap из ресурса любого загруженного модуля (исполняемого файла или DLL)
MakeModuleIcon - Функция создает объект класса TIcon из ресурса любого загруженного модуля (исполняемого файла или DLL).
MergeForm - Процедура предназначена для вставки обычной формы AForm (например, созданной в дизайнере и загруженной из DFM-файла) в элемент управления AControl.
MinimizeText - Эта функция может быть использована для того, чтобы сократить текстовую строку Text до длины, позволяющей отобразить ее целиком на устройстве Canvas на участке длиной MaxWidth.
MsgBox - Функция представляет собой оболочку стандартной функции Windows API MessageBox, только в качестве параметров принимает не PChar, а строки в формате языка Pascal.
NotImplemented - Процедура вызывает появление диалогового окна с сообщением "Функция не реализована" ("Function not yet implemented"), PaintInverseRect
PixelsToDialogUnitsX - Функция преобр пиксели в диалоговые единицы по горизонтали.
PixelsToDialogUnitsY
PointInPolyRgn - Функция возвращает True, если точка с координатами P расположена внутри региона, ограниченного фигурой с вершинами, заданными набором точек Points.
PointInRect - Функция возвращает True, если точка с координатами P расположена внутри прямоугольника R.
RegisterServer - Функция предназначена для регистрации в Windows элементов управления OLE (OCX, ActiveX)
ResourceNotFound - Процедура предназначена для вывода сообщения об ошибке (с генерацией исключения EResNotFound) при ошибке загрузки ресурса из исполняемого файла.
ShadeRect - Процедура служит для "штриховки" прямоугольника Rect
SplitCommandLine - Процедура SplitCommandLine разделяет командную строку запуска любой программы на имя исполняемого файла и строку параметров.
StartWait - Процедура StartWait меняет изображение курсора мыши на экране на то, которое определено типизированной константой WaitCursor (по умолчанию crHourGlass), и увеличивает счетчик вызовов StartWait на 1.
StopWait - Процедура StopWait восстанавливает изображение курсора мыши на экране по умолчанию, если оно было изменено процедурой StartWait.
WidthOf - Функция возвращает ширину (в пикселях) переданного прямоугольника R.
Win32Check - Процедура предназначена для использования при вызове функций Win32 API, возвращающих значение типа BOOL, которое определяет, успешно ли выполнилась функция Win32 API.

Добавлено: 04 Августа 2018 13:04:41 Добавил: Андрей Ковальчук

Работа с MS WORD

Предположим, у нас уже открыт файл. Вопросы открытия и сохранения документов уже были в других статьях, так что подробно на этом останавливаться не будем. Просто по ходу дела будет приведено то, чего раньше не встречалось - выход из документа без сохрания изменений. Как-то забыл, извините:)

Текст
Сначала о самом простом - добавлении в документ Word нужной строки текста. Поместим на форму компоненты WordDocument, WordApplicationи WordParagraphFormat с палитры Servers. Нас интересуют в первую очередь свойство Range компонента WordDocument и свойство Selection компонента WordApplication. Классики утверждают, что они являются ссылкой на объекты Range и Selection. Range представляет из себя, проще говоря, кусок текста, это может быть как весь текст документа, так и любая его часть. Его пределы задаются двумя (или меньше) параметрами типа OleVariant. Например:


var range1, range2, range3, a, b : OleVariant;  
...  
range1:=WordDocument1.Range;  
a:=5;  
b:=15;  
range2:=WordDocument1.Range(a,b);  
range3:=WordDocument1.Range(a);  

Первый наш объект включает в себя весь текст документа, у второго мы ограничили пределы 5-м и 15-м символами, третий представляет из себя весь последующий текст документа, начиная с 5-го символа. Объект имеет несколько полезных методов, например, с его помощью можем добавить текст в документ:


range2.InsertAfter('MS Word');  

Это мы вставили текст после выделенного Range. Точно также можем вставить текст и перед ним, для этого служит метод InsertBefore(). Текст, заключенный в объекте Range, можем получить так: WordDocument1.Range(a,b).Text; Кроме того, с помощью Range можем изменить шрифт в пределах объекта. Пример:


a:=5;  
b:=15;  
WordDocument1.Range(a,b).Font.Bold:=1;  
WordDocument1.Range(a,b).Font.Size:=14;  
WordDocument1.Range(a,b).Font.Color:=clRed;  

Если хотим отменить выделение жирным шрифтом, присваиваем 0. Аналогично можно сделать шрифт курсивом, подчеркнутым - наберите WordDocument1.Range.Font., и среда сама подскажет, какие могут быть варианты. Методы Select, Cut, Copy и Paste работают как в обычном тексте. С помощью Paste можем на место выбранного Range вставить не только строки, но и рисунок, находящийся в буфере обмена.


WordDocument1.Range(a,b).Select;  
WordDocument1.Range(a,b).Cut;  
WordDocument1.Range(a,b).Copy;  
WordDocument1.Range(a,b).Paste;  

С помощью Range можем найти в документе нужную строку. Пусть в тексте содержится слово "picture". Например, нам на его место надо будет вставить рисунок.


var a, b, vstart, vend: OleVariant;  
      j, ilengy: Integer;  
...  
ilengy:=Length(WordDocument1.Range.Text);  
for j:=0 to ilengy-8 do begin  
  a:=j;  
  b:=j+7;  
  if WordDocument1.Range(a,b).Text='picture' then begin  
   vstart:=j;  
   vend:=j+7;  
  end;  
end;  
WordDocument1.Range(vstart,vend).Select;  

Такая процедура находит и выделяет нужный кусок текста.Теперь про Selection, представляющий из себя выделенный фрагмент документа. Если выделения нет, это текущая позиция курсора в документе. С его помощью можем вставить что-либо на место выделенного фрагмента, сделать выравнивание, изменить шрифт. Он также имеет методы InsertAfter() и InsertBefore():


WordApplication1.Selection.InsertAfter("text1");  
WordApplication1.Selection.InsertBefore("text2");  

Форматирование выделенного текста происходит аналогично Range, например:


WordApplication1.Selection.Font.Bold:=1;  
WordApplication1.Selection.Font.Size:=16;  
WordApplication1.Selection.Font.Color:=clGreen;  

Для выравнивания проще воспользоваться компонентом WordParagraphFormat. Сначала только нужно "подключить" его к выделенному фрагменту текста:


WordParagraphFormat1.ConnectTo(WordApplication1.Selection.ParagraphFormat);  
WordParagraphFormat1.Alignment:=wdAlignParagraphCenter;  

Значения его свойства Alignment может принимать значения wdAlignParagraphCenter, wdAlignParagraphLeft, wdAlignParagraphRight, смысл которых очевиден. Имеются и методы Cut, Copy и Paste, которые в пояснениях вряд ли нуждаются:


WordApplication1.Selection.Cut;  
WordApplication1.Selection.Copy;  
WordApplication1.Selection.Paste;  

Убираем выделение с помощью метода Collapse. При этом необходимо указать, в какую сторону сместится курсор, будет ли он до ранее выделенного фрагмента или после:


var vcol: OleVariant;  
...  
vcol:=wdCollapseStart;  
WordApplication1.Selection.Collapse(vcol);  

При этом выделение пропадет, а курсор займет позицию перед фрагментом текста. Если присвоить переменной значение wdCollapseEnd, то курсор переместится назад. Можно просто поставить в скобках "пустышку":


WordApplication1.Selection.Collapse(EmptyParam);  

Тогда свертывание выделения производится по умолчанию, к началу выделенного текста. РисункиЛогично было бы предположить, что рисунки документа будут представлять из себя коллекцию, аналогичную таблицам, и мы, обратившись к конкретной картинке, сможем менять ее свойства - обтекание, размер и т.д. Однако ничего подобного в WordDocument не обнаруживается. Потому возможности управления встраиваемыми в документ изображениями сильно ограничены. Простейший метод вставить в документ рисунок - по упомянутым причинам он же и единственный - скопировать его в Word из буфера обмена. Предположим, рисунок у нас находится в компоненте DBImage. Сначала нужно загнать его в буфер обмена:


Clipboard.Assign(DBImage1.Picture);  

Теперь для его вставки следует воспользоваться методом Paste объектов Range или Selection: WordApplication1.Selection.Paste или WordDocument1.Range(a,b).Paste. Оставить для рисунка достаточное количество пустых строк и попасть в нужное место - это уже наша забота. Если он попадет посреди текста, вид будет довольно противный - при такой вставке обтекание текстом рисунка происходит как-то странно. Можно приготовить для отчета шаблон, где заменяем рисунком какое-либо ключевое слово. О том, как найти в документе нужный текст, см. выше. А теперь о несколько ином способе вставки рисунка, который устраняет проблемы с обтеканием и дает нам возможность перемещать его по документу, масштабировать и задавать отступы между рисунком и текстом. Способ, собственно, тот же - копируем из буфера обмена, но не прямо в документ, а в "рамку" - текстовую вставку. В ней может находиться не только текст, но и картинка, чем и воспользуемся.
"Рамки" образуют коллекцию Frames, нумеруются целым индексом, пробегающим значения от 1 до WordDocument1.Frames.Count. Добавим в документ рамку, изменим ее размер и вставим рисунок:


Clipboard.Assign(DBImage1.Picture);  
vstart:=1;  
vend:=2;  
WordDocument1.Frames.Add(WordDocument1.Range(vstart,vend));  
i:=1;  
WordDocument1.Frames.Item(i).Height:=DBImage1.Height;  
WordDocument1.Frames.Item(i).Width:=DBImage1.Width;  
WordDocument1.Frames.Item(i).Select;  
WordApplication1.Selection.Paste;  

Здесь для простоты предполагается, что размер DBImage равен размеру самой картинки, а также что до этого рамок у нас в документе не было. Обратить внимание следует на несколько моментов. Размер рамки надо задавать до того, как копировать в нее рисунок. Иначе она будет иметь размер по умолчанию, под который замасштабируется и наша картинка. При попытке изменить размер рамки задним числом размер картинки уже не изменится. Кроме того, параметр Range при добавлении рамки часто никакой роли не играет. Рамка изначально все равно появится в левом верхнем углу документа, а указанный кусок текста при этом не пострадает. Но это только в том случае, если он не выделен. Если в документе есть выделение, рамка появится вместо выделенного фрагмента. Таким образом можем ее вставить в нужное место взамен какого-то ключевого слова.
При желании можем ее подвигать в документе и "вручную". Для этого служат свойства горизонтального и вертикального позиционирования, которые задают ее отступ от левого верхнего "угла" документа:


i:=1;  
WordDocument1.Frames.Item(i).VerticalPosition:=30;  
WordDocument1.Frames.Item(i).HorizontalPosition:=50;  
Отступ между краями рамки и текстом задается следующим образом:  
WordDocument1.Frames.Item(i).HorizontalDistanceFromText:=10;  
WordDocument1.Frames.Item(i).VerticalDistanceFromText:=10;  

А теперь о масштабировании. Для этого достаточно длину и ширину рамки умножить на одно и то же число. Например:


WordDocument1.Frames.Item(i).Height:=DBImage1.Height*1.5;  
WordDocument1.Frames.Item(i).Width:=DBImage1.Width*1.5;  

При этом наша картинка в полтора раза пропорционально растянется. Точно также можно и уменьшить, но делить, как и множить, следует на одно число. Растягивать длину и ширину по-разному у меня лично не получалось. Задавать размер опять-таки надо еще до вставки рисунка. Ну и, наконец, удаление рамки:


WordDocument1.Frames.Item(i).Delete;  

Списки Списки в документе образуют коллекцию Lists, к отдельному списку обращаемся WordDocument1.Lists.Item(i), где i целое число от 1 до WordDocument1.Lists.Count ... на этом все. Нет методов, позволяющих не то что создать новый список, а даже добавить пункт к уже существующему. Ничего страшного, настоящие герои всегда идут в обход:)) Сейчас мы все же проделаем и то, и другое. Все что нам понадобится - свойство Range отдельного списка, то есть его текст без разделения на пункты, а также возможность его выделить:


WordDocument1.Lists.Item(i).Range.Select;  

Для этого в любом случае потребуется заготовка. Неважно, вставлена она в общий шаблонный документ или хранится в отдельном файле. Заготовку делаем так: выбираем в меню Формат/Список, и сохраняем, если это отдельный шаблон списка. У нас появляется пустой список без текста с одним маркером. Далее вспоминаем, как мы делали списки вручную - писали текст, нажимали "Enter", появлялся новый элемент списка. Теперь то же самое, только программно. Предположим, у нас уже открыт документ с заготовкой, и мы хотим внести в список пункты "Item 1" и "Item 2":


var i: Integer;  
      vcol: OleVariant;  
...  
i:=1;  
vcol:=wdCollapseEnd;  
WordDocument1.Lists.Item(i).Range.Select;  
WordApplication1.Selection.Collapse(vcol);  
WordApplication1.Selection.InsertAfter('Item 1');  
WordDocument1.Lists.Item(i).Range.Select;  
WordApplication1.Selection.Collapse(vcol);  
WordApplication1.Selection.InsertAfter(#13);  
WordDocument1.Lists.Item(i).Range.Select;  
WordApplication1.Selection.Collapse(vcol);  
WordApplication1.Selection.InsertAfter('Item 2');  
WordDocument1.Lists.Items(i).Range.Select;  
WordApplication1.Selection.Copy;  

То есть мы вставляем в документ текст первого пункта списка, он попадает на свое место. Потом посылаем в Word символ перехода строки, он честно переходит и тем самым сам создает нам второй пункт списка, куда и вставляем нужную строку. Ну и так далее, нужное количество раз. Последние две строки нужны, если список заготовлен в отдельном файле - после их выполнения список оказывается в буфере обмена. Здесь выгода в том, что можем иметь заготовки списков разных стилей и по ходу дела выбирать, какой список создать. Затем открываем документ, где должен быть список, выделяем с помощью Range нужный кусок, копируем из буфера обмена через WordDocument1.Range(a,b).Paste. Чтобы не испортить файл с заготовкой, можем сразу после открытия пересохранить его под другим именем, а можем просто выйти из него без сохранения изменений


var vsave: OleVariant;  
...  
vsave:=wdDoNotSaveChanges;  
WordDocument1.Close(vsave);  

Константа сохранения изменений может принимать значения

Символьное обозначение Шестнадцатеричное

wdSaveChanges	$FFFFFFFF
wdDoNotSaveChanges	$00000000
wdPromptToSaveChanges	$FFFFFFFE

Первое значение сохраняет изменения, второе дает возможность выйти без сохранения изменений. Последняя константа вызывает при выходе стандартный диалог сохранения изменений. Можем сделать и несколько по-другому. Хотя мы не можем создать новый элемент списка, но текст в уже существующем изменить можно:


var i,j: Integer;  
...  
i:=1;  
j:=1;  
WordDocument1.Lists.Item(i).ListParagraphs.Item(j).Range.Text:='Item 1';  

Так что можно с помощью переходов строки создать нужное количество элементов, а затем их заполнить:


WordDocument1.Lists.Item(i).Range.Select;  
WordApplication1.Selection.Collapse(vcol);  
WordApplication1.Selection.InsertAfter(#13);  
j:=1;  
WordDocument1.Lists.Item(i).ListParagraphs.Item(j).Range.Text:='Item 1';  
j:=2;  
WordDocument1.Lists.Item(i).ListParagraphs.Item(j).Range.Text:='Item 2';  

Это было в предположении, что у нас один элемент списка в заготовке уже есть. Ну вот, в общем-то, и все про текст, списки и картинкиСтатистика документовВ данном небольшом материале рассматривается вопрос подсчета статистики файлов *.doc и *.rtf. Такой вопрос у меня возник, когда пришлось сделать небольшую базу данных по учету документов, куда надо было заносить и статистику документа - число знаков, слов и т.п. Открывать каждый раз Word, считать статистику и забивать ее в форму ввода было лень, так что пришла в голову мысль это дело автоматизировать. Информации по данному вопросу найти так и не удалось, так что основным источником знаний служили заголовочный файл Word2000.pas и справка по Visual Basic for Applications. Ну и, конечно, множество разных экспериментов. Сразу оговорюсь, что я не профессиональный программист, так что в тонкости интерфейсов вникать не будем - сам в них не особо разбираюсь. Потому, не мудрствуя лукаво, просто поместим на форме компоненты WordApplication и WordDocument с палитры Servers. Для работы используются свойства и методы этих компонентов. Встроенная статистика Word подсчитывает статистику обычного текста, обычных и концевых сносок. Для подсчета статистики используется метод компонента WordDocument ComputeStatistic(). Он имеет один параметр, характеризующий, что именно считать, представляющий из себя шестнадцатеричную константу. Константы описаны в заголовочном файле Word2000.pas, он лежит обычно в /Delphi/Ocx/Servers.

Шестнадцатеричная Символьное обозначение Смысл
$00000000 wdStatisticWords Количество слов
$00000001 wdStatisticLines Количество строк
$00000002 wdStatisticPages Количество страниц
$00000003 wdStatisticCharacters Знаки без пробелов
$00000004 wdStatisticParagraphs Количество разделов
$00000005 wdStatisticCharactersWithSpaces Знаки с пробелами
Это было основное, что надо знать. Ну а теперь по порядку. Поместив на форму упомянутые компоненты, видим, что свойств и методов у них совсем мало. В первую очередь следует определиться с методом ConnectKind компонента WordApplication. Оно может принимать различные значения, но мы оставим присваемое по умолчанию значение ckRunningOrNew. Это означает, что соединение происходит с уже работающим сервером, при его отсутствии запускается новый. Как правило, это вполне устраивает. Первым делом откроем документ. Предварительно надо объявить переменную FileName, она будет типа OleVariant, которой присвоим строку с именем файла.


WordApplication1.Connect;  
WordApplication1.Documents.Open(FileName,  
EmptyParam,EmptyParam,EmptyParam,  
EmptyParam,EmptyParam,EmptyParam,  
EmptyParam,EmptyParam,EmptyParam,  
EmptyParam,EmptyParam);  

WordDocument1.ConnectTo(WordApplication1.ActiveDocument);
Обратите внимание на количество параметров-"пустышек". Их число больше того, которое обычно приводится в книжках. Ну, в моих, во всяком случае. Объясняется это тем, что "книжные" функции предназначены для MS Word 97, а такая запись для работы с Word 2000 и Word XP. "Plain Text"Объявив нужное количество переменных типа LongInt (в очень большом файле или при суммировании по нескольким документам в принципе может оказаться больше знаков, чем пределы обычного целого типа), можем уже и приступать к подсчету. Например, посчитаем число слов, знаков с пробелами и без пробелов обычного текста, а также количество страниц в документе. Результаты сохраним соответственно в "длинных" переменных


WCount:=WordDocument1.ComputeStatistics($00000000);  
CCount:=WordDocument1.ComputeStatistics($00000003);  
SCount:=WordDocument1.ComputeStatistics($00000005);  
PCount:=WordDocument1.ComputeStatistics($00000002);  

Открыв нужный документ в Word'е и вызвав диалог подсчета статистики, нетрудно увидеть, что значения переменных равны параметрам вордовской статистики со сброшенным флажком "Учитывать все сноски". СноскиСноски в документах могут быть обычные и концевые. То есть если первые располагаются внизу данной страницы, то концевые - строго в конце документа. Кроме того, они могут отличаться и нумерацией - автоматической или заданной пользователем. Начнем с обычных сносок как с самого простого. В терминологии объектной модели Word - Footnotes. Сначала надо вычислить количество самих сносок:


ifcount:=WordDocument1.DefaultInterface.Footnotes.Count;  

Подсчет статистики текста в сноске производится так:


FWCount:=WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Range.ComputeStatistics($00000000);  

Здесь ifoot - целое число, "нумерующее" сноску. Для того, чтобы учесть сами номера сносок, сделаем так:


FWCount:=FWCount+WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Reference.ComputeStatistics($00000000);  

Это мы посчитали для примера количество слов в сноске с номером ifoot и ее метке - при пользовательской нумерации в качестве "номера" может быть целое предложение. Далее начинаем перебирать их одну за другой. При этом следует учесть, что кроме статистики сносок необходимо получить и статистику их "номеров". То есть:


for ifoot:=1 to ifcount do begin  
   FWCount:=FWCount+WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Range.ComputeStatistics($00000000);  
   FCCount:=FCCount+WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Range.ComputeStatistics($00000003);  
   FSCount:=FSCount+WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Range.ComputeStatistics($00000005);  
   FCCount:=FCCount+WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Reference.ComputeStatistics($00000003);  
   FSCount:=FSCount+WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Reference.ComputeStatistics($00000005)+1;  
   if WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Reference.Text<>IntToStr(ifoot)  
   then begin  
     FWCount:=FWCount+  
                  WordDocument1.DefaultInterface.Footnotes.Item(ifoot).Reference.ComputeStatistics($00000000);  
   end;  
end;  

Прибавление единицы появляется оттого, что сумма статистики сносок и номеров не совпадает с тем, что выдает встроенная статистика Word. Между номером сноски и текстом сноски Word ставит пробел, который почему-то не учитывается. Условный оператор определяет, как пронумерована данная сноска - по умолчанию или нет. В последнем случае следует проверить количество слов в обозначении сноски. Такая схема дает результат, совпадающий со показаниями встроенной статистики. Кроме того, цикл у нас идет от 1 - так начинается нумерация сносок в MS Word, да и практически всех остальных объектов тоже.Теперь перейдем к концевым сноскам. Теоретически все то же самое, только вместо слова "Footnotes" пишем "Endnotes". И тут наталкиваемся на сюрприз - почему-то оно считает неточно. Я в данном случае поступил так: сохраняю документ под другим именем, переконвертирую концевые сноски в обычные и далее все, как сказано выше. Сохранение документа:


WordDocument1.SaveAs(FileName, FileFormat),  

где в скобках стоят два параметра типа OleVariant - имя файла и шестнадцатеричная константа, задающая формат файла. Некоторые константы:

Шестнадцатеричная Символьное обозначение Смысл
$00000000 wdFormatDocument Документ Word
$00000004 wdFormatDOSText Простой текст
$00000006 wdFormatRTF Файл RTF
Полный список констант формата можно найти все в том же файле Word2000.pas. И еще один интересный момент - если просто поставить в скобки обе константы, работать не будет. Следует предварительно объявить две переменных, присвоить им соответствующие значения и только потом сохранять. Ну, а теперь, собственно, можем вернуться к сноскам. Конвертирование концевых сносок в обычные происходит так:


WordDocument1.DefaultInterface.Endnotes.Convert;  

Теперь мы имеем документ, в котором содержатся только обычные сноски. С ними никаких проблем не возникает, пример, как с ними работать, см. выше. Если интересует статистика отдельно разных типов сносок, считаем предварительно статистику обычных сносок, сохраняем ее в "буферных" переменных и считаем еще раз после конвертирования. Разница даст статистику концевых сносок по отдельности. Сложив статистику сносок и простого текста, получаем статистику документа с учетом сносок так, как ее дает сам Word. Дополнительно...Тут по традиции несколько покритикуем Microsoft. Как оказалось, Word показывает не все, что содержится в документе. Не принимаются в расчет колонтитулы. А ведь в них может содержаться изрядный кусок текста, особенно в справках, бланках и т.п. Оказывается, Word их на самом деле считает, но нам не показывает. Вот и посмотрим, как же его можно заставить это сделать. Колонтитулы в документе тесно связаны с несколько загадочной штукой под названием "разделы" - Sections. Каждый раздел может иметь верхние и нижние колонтитулы. Потому первым делом определяем количество абзацев.

isectct:=WordDocument1.DefaultInterface.Sections.Count; 

Здесь у нас целые переменные isectct, icofct, icohct обозначают соответственно количество разделов как таковых, количество нижних и верхних колонтитулов данного раздела. Переменная isec служит "номером" раздела, переменные icof, icoh "нумеруют" соответственно нижние и верхние колонтитулы в пределах данного раздела. Количество колонтитулов в разделе определяем так:

icofct:=WordDocument1.DefaultInterface.Sections.Item(isec).Footers.Count;  
icohct:=WordDocument1.DefaultInterface.Sections.Item(isec).Headers.Count;  

Теперь уже можем "достать" текст из колонтитула:


CBWCount:=  
WordDocument1.DefaultInterface.Sections.Item(isec).Footers.Item(icof).Range.ComputeStatistics($00000000);  

В данном случае мы для примера посчитали число слов, содержащихся в нижнем колонтитуле под номером icof, принадлежащем разделу под номером isec. Теперь можем написать "двойной" цикл для подсчета статистики верхних и нижних колонтитулов.

Добавлено: 04 Августа 2018 11:56:22 Добавил: Андрей Ковальчук

Потоки

Сегодня нам предстоит познакомится с потоками. Эта штука очень интересная и беспощадно нужная. Всё программирование звука будет написано с использованием потоков, так что вникай где суть.

Представь, что ты хочешь вставить в свою прогу проверку орфографии. Если ты после каждой нажатой клавиши будешь проверять правильность слов, то твоя прога будет сумасшедше тормозить. А как же это делает MS Word ? Очень просто, после запуска проги запускается поток, который в фоновом режиме производит проверку орфографии. Ты спокойно набираешь текст и даже не ощущаешь (почти) как параллельный процесс в свободное время производит сложнейшие проверки твоих каракуль.

Любая программа содержит хотя бы один поток (главный), в котором она выполняется. Помимо этого, она может порождать любое количество дополнительных потоков, которые будут выполняться в фоновом режиме. У дополнительных потоков приоритет выставляется такой же как и у главного потока программы, но ты его можешь увеличить или уменьшить. Чем выше приоритет потока, тем больше на него отводится процессорного времени.

Да что тут распинаться, давай программировать. Со всем разберёмся в процессе.

Создай новый проект. Поставь на форму ТRichEdit из палитры Win32 и один TLabel. Это мы создали форму, а теперь создадим поток.

Выбери File -> New (рисунок 1). Находишь там Thread Object , выделяешь и щёлкаешь "ОК". Появляется окошко, как на рисунке 2. Вводим имя потока (я ввёл TCountObj).

Сохраняем весь проект. Главную форму под именем main (как всегда), а поток под именем MyThread.

После этого Delphi создаст вот такой код:


unit MyThread;  
  
interface  
  
uses  
  Classes;  
  
type  
  TCountObj = class(TThread)  
  private  
    { Private declarations }  
  protected  
    procedure Execute; override;  
  end;  
  
implementation  
  
{ Important: Methods and properties of objects in VCL can only be used in a 
  method called using Synchronize, for example, 
 
      Synchronize(UpdateCaption); 
 
  and UpdateCaption could look like, 
 
    procedure TCountObj.UpdateCaption; 
    begin 
      Form1.Caption := 'Updated in a thread'; 
    end; }  
  
{ TCountObj }  
  
procedure TCountObj.Execute;  
begin  
  { Place thread code here }  
end;  
  
end.  

Это новый поток. У объекта есть только одна функция Execute . В этой функции мы и будем писать код потока. Напишем вот что:


procedure TCountObj.Execute;  
begin  
 index:=1;  
 //Запускаем бесконечный счётчик  
 while index>0 do  
  begin  
   Synchronize(UpdateLabel);  
   Inc(index);  
   if index>100000 then  
    index:=0;  
  
   //Если поток остановлен, то выйти.  
   if terminated then exit;   
  end;  
end;  

index я объявил как integer в разделе private потока. Там же я объявил процедуру UpdateLabel. Эта процедура выглядит так:


procedure TCountObj.UpdateLabel;  
begin  
 Form1.Label1.Caption:=IntToStr(Index);  
end;  

И последнее, что я сделал - подключил главную форму в раздел uses, потому что я обращаюсь к ней в коде выше (Form1.Label1.Caption).

Теперь о магической функции Synchronize. В качестве параметра ей передаётся процедура UpdateLabel, которая производит вывод в главную форму. Для чего нужно вставлять вывод на экран в Synchronize? Библиотека VCL имеет один косяк - она не защищена от потоков. Если главная форма и поток попробуют одновременно вывести что-нибудь в одну и ту же область экрана или компонент, то программа рухнет как эфелева башня. Поэтому весь вывод на форму нужно выделять в отдельную процедуру и вызывать эту процедуру с помощью Synchronize.

Что происходит во время вызова Synchronize? В этот момент поток останавливается и управление передаётся главному потоку, который и произведёт обновление.

Наш поток готов. Возвращаемся к главной форме. Я её сделал, как на рис 3. В раздел uses (самый первый, который идёт после interface) я добавил свой поток MyThread.

В разделе private я объявил переменную co типа TCountObj (объект моего потока).

По нажатию кнопки "Запустить" я написал такой код:


procedure TForm1.Button1Click(Sender: TObject);  
begin  
 co:=TCountObj.Create(true);  
 co.Resume;  
 co.Priority:=tpLower;  
end;  

В первой строке я создаю поток co. В качестве параметра может быть true или false. Если false, то поток сразу начинает выполнение, иначе поток создаётся, но не запускается. Для запуска нужно использовать Resume, что я делаю во второй строке.

В третьей строке я устанавливаю приоритет потока поменьше, чтобы он не мешал работе основному потоку и выполнялся в фоне. Если установить приоритет повыше, то основной поток начнёт притормаживать, потому что у них будут одинаковые приоритеты.

По кнопке "Остановить" я написал:


procedure TForm1.Button1Click(Sender: TObject);  
begin  
 co.Terminate;  
 co.Free;  
end;  

В первой строке я останавливаю выполнение потока, а во второй уничтожаю его.

Попробуй запустить прогу, запустить поток (нажатием кнопки "Запустить") и понабирать текст в RichEdit. Текст будет набиратся без проблем, и в это время в ТLabel будет работать счётчик. Если бы ты запустил счётчик без отдельного потока, то ты бы не смог набирать текст в RichEdit, потому что все ресурсы программы (основного потока) уходили бы на работу счётчика.

Итак, наш первый поток готов. При программировании звука мы напишем более полезные примеры с потоками. А сейчас ещё несколько полезных фишек:

Suspend - приостанавливает поток. Для вызова просто напиши co.Suspend. Чтобы возобновить работу с этой же точки нужно вызвать Resume.
Priority- устанавливает приоритет потока. Например Priority:=tpIdle;
tpIdle - поток будет работать только когда процессор бездельничает.
tpLowest - самый слабый приоритет
tpLower - слабый приоритет
tpNormal - нормальный
tpHigher - высокий
tpHighest - самый высокий
tpTimeCritical - критичный (не советую использовать, потому что может грохнуть систему).
Suspended - если этот параметр true, то поток находится в паузе.
Terminated - если true, то поток должен быть остановлен.
Вот и всё. С потоками окончено.

Добавлено: 04 Августа 2018 09:56:43 Добавил: Андрей Ковальчук

Потоки и методы их синхронизаций в Delphi

Статья призвана дать понятия о процессах, потоках и принципах программирования многопоточных приложений в delphi. Процесс - экземпляр выполняемого приложения. При запуске приложения происходит выделение памяти под процесс, в часть которой и загружается код программы. Поток - объект внутри процесса, отвечающий за выполнение кода и получающий для этого процессорное время.

При запуске приложения система автоматически создает поток для его выполнения. Поэтому если приложение однопоточное, то весь код будет выполняться последовательно, учитывая все условные и безусловные переходы.

Каждый поток может создать другой поток и т.д. Потоки не могут существовать отдельно от процесса, т.е. каждый поток принадлежит какому-то процессу и этот поток выполняет код, только в адресном пространстве этого процесса. Иными словами, поток не может выполнить код чужого процесса, хотя в nt-системах есть лазейка, но это уже тема отдельной статьи.

Многопоточность обеспечивает псевдопараллельную работу множества программ. В некоторых случаях без создания потоков нельзя обойтись, например, при работе с сокетами в блокирующем режиме.

В delphi существует специальный класс, реализующий потоки - tthread. Это базовый класс, от которого надо наследовать свой класс и переопределять метод execute.


tnew = class(tthread)  
private  
{ private declarations }  
protected  
procedure execute; override;  
end;  
…  
procedure tnew.execute;  
begin  
{ place thread code here }  
// Код, который будет выполняться в отдельном потоке  
end;  

Теперь можно в теле процедуры tnew.execute писать код, выполнение, которого подвешивало бы программу.

Тонкий момент. В теле процедуры не надо вызывать метод execute предка.

Теперь необходимо запустить поток. Как всякий класс tnew необходимо создать:


var  
new: tnew;  
…  
begin  
new := tnew.create(true);  
end;  

Значение true в методе create значит, что после создания класса поток автоматически запущен не будет.

Потом указываем, что после завершения кода потока он сразу завершится, т.е. не надо заботиться о его закрытии. В противном случае, необходимо самим вызывать функцию terminate.


new.freeonterminate := true;  

Устанавливаем приоритет в одно из возможных значений:

tpidle Работает, когда система простаивает
tplowest Нижайший
tplower Низкий
tpnormal Нормальный
tphigher Высокий
tphighest Высочайший
tptimecritical Критический


new.priority := tplowest;  

Не рекомендую устанавливать слишком большой приоритет т.к. поток может существенно загрузить систему.

Тонкий момент. Если в потоке присутствует бесконечный цикл обработки чего-либо, то поток будет загружать систему под завязку. Чтобы избежать этого вставляйте функцию sleep(n), где n - количество миллисекунд, на которое поток приостановит свое выполнение, встретив это функцию. n следует выбирать в зависимости от решаемой задачи.

Запускаем поток:


new.resume;   

Кстати, если Вы планируйте писать код потока в отдельном модуле, то можно немного упростить написание скелета класса. Для этого выберите в хранилище объектов - thread object (Это на закладке new). Выскочит окно, в котором надо ввести имя класса, после чего, нажав Ок, автоматически создаться новый модуль со скелетом Вашего класса.

Синхронизация потоков при обращении к vcl-компонентам

Значит, мы научились создавать потоки. Но тут всплывает интересная вещь: что будет, если два потока обращаются к одним и тем же данным по записи? Например, два потока пытаются изменить заголовок главной формы.

Специально для этого в ОС реализованы механизмы синхронизаций. В частности, в классе tthread есть метод позволяющий избежать параллельного доступа к vcl-компонентам:


procedure synchronize(method: tthreadmethod);  

Он то и позволяет избежать конфликта при обращении к одним vcl-компонентам разными потоками. В качестве параметра ему передается адрес процедуры без параметров. А как вызвать с параметрами? Для этого можно использовать внутриклассовые переменные.


tnew = class(tthread)  
private  
{ private declarations }  
st: string;  
procedure update;  
protected  
procedure execute; override;  
end;  
  
var  
new: tnew;  
…  
procedure update;  
begin  
form1.caption := s;  
end;  
…  
begin  
s := 'yes';  
synchronize(update);  
end;  

Вот полный пример, в котором метод addstr добавляет в memo несколько строчек. Если мы просто вызовем метод, то строчки от потоков будут добавятся в произвольном порядке. Если addstr вызовем методом synchronize, то строчки добавятся сначала от одного потока, а затем от второго. Получается, что поток монопольно захватывает ресурс memo и добавляет в него необходимую информацию, после добавления поток освобождает memo и вот теперь уже другой поток может добавлять в memo свои данные. Поменьше слов - побольше сурсов:


unit unit1;  
  
interface  
  
uses  
windows, messages, sysutils, variants, classes, graphics, controls, forms, dialogs, stdctrls;  
  
type  
tform1 = class(tform)  
memo1: tmemo;  
button1: tbutton;  
procedure button1click(sender: tobject);  
private  
{ private declarations }  
public  
{ public declarations }  
end;  
  
tnew = class(tthread)  
private  
s: string;  
procedure addstr;  
protected  
procedure execute; override;  
end;  
  
var  
form1: tform1;  
new1, new2: tnew;  
  
implementation  
  
{$r *.dfm}  
  
procedure tform1.button1click(sender: tobject);  
begin  
new1 := tnew.create(true);  
new1.freeonterminate := true;  
new1.s := '1 thread';  
new1.priority := tplowest;  
new2 := tnew.create(true);  
new2.freeonterminate := true;  
new2.s := '2 thread';  
new2.priority := tptimecritical;  
new1.resume;  
new2.resume;  
end;  
  
{ tnew }  
procedure tnew.addstr;  
begin  
form1.memo1.lines.add(s);  
sleep(2);  
form1.memo1.lines.add(s);  
sleep(2);  
form1.memo1.lines.add(s);  
sleep(2);  
form1.memo1.lines.add(s);  
sleep(2);  
form1.memo1.lines.add(s);  
end;  
  
procedure tnew.execute;  
begin  
synchronize(addstr); // Вызов метода с синхронизацией  
//addstr; // Вызов метода без синхронизации  
end;  
  
end.  

Другие способы синхронизации. Модуль syncobjs

В модуле syncobjs находятся классы синхронизации, которые являются оберткой вызовов api-функций . Всего в этом модуле объявлено пять классов. tcriticalsection, tevent, а так же и более простая реализация класса tevent - tsimpleevent и используются для синхронизации потоков, остальные классы можно и не рассматривать. Вот иерархия классов в этом модуле:

Критические секции tcriticalsection

Наиболее простым в понимании является tcriticalsection или критическая секция. Код, расположенный в критической секции, может выполняться только одним потоком. В принципе код ни как не выделяется, а происходит обращение к коду через критическую секцию. В начале кода находится функция входа в секцию, а по завершению его выход из секции. Если секция занята другим потоком, то потоки ждут, пока критическая секция не освободится.

В начале работы критическую секцию необходимо создать:


var  
section: tcriticalsection; // глобальная переменная  
begin  
section.create;  
end;  

Допустим, имеется функция, в которой происходит добавление элементов в глобальный массив:


function addelem(i: integer);  
var  
n: integer;  
begin  
n := length(mas);  
setlength(mas,n + 1);  
mas[n + 1] := i;  
end;  

Допустим, эту функцию вызывают несколько потоков, поэтому, чтобы не было конфликта по данным можно использовать критическую секцию следующим образом:


function addelem(i: integer);  
var  
n: integer;  
begin  
section.enter;  
n := length(mas);  
setlength(mas,n + 1);  
mas[n + 1] := i;  
section.leave;  
end;  

Уточню, что критических секций может быть несколько. Поэтому при использовании нескольких функций, в которых могут быть конфликты по данным надо для каждой функции создавать свою критическую секцию. После окончания их использования, когда функции больше не будут вызываться, секции необходимо уничтожить.


section.free;   

Как Вы поняли, очень надеюсь, что вход и выход из критической секции не обязательно должен находиться в одной функции. Вход обозначает, только то, что другой поток встретив вход и обнаружив его занятость, будет приостановлен. А выход просто освобождает вход. Совсем просто, критическую секцию можно представит как узкую трубу на один поток, как только поток подходит к трубе, он заглядывает в нее и если видит, что через трубу уже кто-то лезет, будет ждать, пока другой не вылезет.

А вот и пример, в котором происходит добавление элемента в динамический массив. Функция sleep добавляет задержку в цикл, что позволяет наглядно увидеть конфликт по данным, если Вы, конечно, уберете вход и выход из критической секции в коде.


unit unit1;  
  
interface  
  
uses  
windows, messages, sysutils, variants, classes, graphics, controls, forms, dialogs, stdctrls, syncobjs;  
  
type  
tform1 = class(tform)  
button1: tbutton;  
memo1: tmemo;  
procedure formcreate(sender: tobject);  
procedure formdestroy(sender: tobject);  
procedure button1click(sender: tobject);  
private  
{ private declarations }  
public  
{ public declarations }  
end;  
  
tnew = class(tthread)  
protected  
procedure execute; override;  
end;  
  
var  
form1: tform1;  
cs: tcriticalsection;  
new1, new2: tnew;  
mas: array of integer;  
  
implementation  
  
{$r *.dfm}  
  
procedure tform1.formcreate(sender: tobject);  
begin  
setlength(mas,1);  
mas[0] := 6;  
// Создаем критическую секцию  
cs := tcriticalsection.create;  
end;  
  
procedure tform1.formdestroy(sender: tobject);  
begin  
// Удаляем критическую секцию  
cs.free;  
end;  
  
{ tnew }  
procedure tnew.execute;  
var  
i: integer;  
n: integer;  
begin  
for i := 1 to 10 do  
begin  
// Вход в критическую секцию  
cs.enter;  
// Код, выполнение которого параллельно запрещено  
n := length(mas);  
form1.memo1.lines.add(inttostr(mas[n-1]));  
sleep(5);  
setlength(mas,n+1);  
mas[n] := mas[n-1]+1;  
// Выход из критической секции  
cs.leave;  
end;  
end;  
  
procedure tform1.button1click(sender: tobject);  
begin  
new1 := tnew.create(true);  
new1.freeonterminate := true;  
new1.priority := tpidle;  
new2 := tnew.create(true);  
new2.freeonterminate := true;  
new2.priority := tptimecritical;  
new1.resume;  
new2.resume;  
end;  
  
end.  

Немного wait-функциях

Для начала не много о wait-функциях. Это функции, которые приостанавливают выполнение потока. Частным случаем wait-функции является sleep, в качестве аргумента передается количество миллисекунд, на которое требуется заморозить или приостановит поток.

Тонкий момент. Если вызвать sleep(0), то поток, откажется от своего такта - процессорного времени и тут же встанет в очередь с готовностью на выполнение.

Полной wait-функции в качестве параметров передается дескрипторы потока(ов). Я не буду останавливаться на них сейчас подробно. В принципе, wait-функции инкапсулируют некоторые классы синхронизации в явном виде, остальные в не явном виде.

События tevent

События tevent могут использоваться не только в многопоточном приложении, но и в однопоточном в качестве координации между секциями кода и при передачи данных их одного приложения в другое. В многопоточных приложениях использование tevent кажется более разумным и понятнее.

Все происходит следующим образом. Если событие установлено, то работать дальше можно, если событие сброшено, то все остальные потоки ждут. Различие между событиями и критическими секциями в то, что события проверяются в коде самого потока и используется wait-функция в явном виде. Если в критической секции wait-функция выполнялась автоматически, то при использовании событий необходимо вызывать ее для заморозки потока.

События бывают с автосбросом и без автосброса. С автосбросом значит, что сразу после возврата из wait-функции событие сбрасывается. При использовании событий без автосброса необходимо самим сбрасывать их.

Событием без автосброса удобно делать паузу в каком-то определенном участке кода потока. Просто сделать паузу в потоке, когда не имеет значения, где произойдет заморозка можно использовать метод tthread.suspend. События с автосбросом можно использовать, так же как и критические секции.

Для начала событие необходимо создать и желательно до того как будут созданы потоки их использующие, хотя точнее до вызова wait-функции.

create(eventattributes: psecurityattributes; manualreset, initialstate: boolean; const name: string);

eventattributes - берем nil.
manualreset - автосброс - false, без автосброса - true.
initialstate - начальное состояние true - установленное, false - сброшенное.
const name - имя события, ставим пустое. Событие с именем нужно при обмене данных между процессами.


var  
event: tevent;  
new1, new2: tnew; // потоки  
…  
begin  
event := tevent.create(nil, false, false, '');  
end;  
procedure tnew.execute;  
var  
n: integer;  
begin  
event.waitfor(infinite);  
n := length(mas);  
setlength(mas,n + 1);  
mas[n + 1] := i;  
event.setevent;  
end;  

Все теперь ошибки не будет.

Более простым в использовании является класс tsimpleevent, который является наследником tevent и отличается от него только тем, что его конструктор вызывает конструктор предка сразу с установленными параметрами:


create(nil, true, false, '');   

Фактически, tsimpleevent есть событие без автосброса, со сброшенным состоянием и без имени.

Следующий пример показывает, как приостановить выполнение потока в определенном месте. В данном примере на форме находятся три progressbar, поток заполняет progressbar. При желании можно приостановить и возобновить заполнение progressbar. Как Вы поняли мы будем создавать событие без автосброса. Хотя тут уместнее использовать tsimpleevent, мы использовали tevent, т.к. освоив работу с tevent будет просто перейти на tsimpleevent.


unit unit1;  
  
interface  
  
uses  
windows, messages, sysutils, variants, classes, graphics, controls, forms, dialogs, stdctrls, syncobjs, comctrls;  
  
type  
tform1 = class(tform)  
button1: tbutton;  
progressbar1: tprogressbar;  
progressbar2: tprogressbar;  
progressbar3: tprogressbar;  
button2: tbutton;  
procedure formcreate(sender: tobject);  
procedure formdestroy(sender: tobject);  
procedure button1click(sender: tobject);  
procedure button2click(sender: tobject);  
private  
{ private declarations }  
public  
{ public declarations }  
end;  
  
tnew = class(tthread)  
protected  
procedure execute; override;  
end;  
  
var  
form1: tform1;  
new: tnew;  
event: tevent;  
  
implementation  
  
{$r *.dfm}  
  
procedure tform1.formcreate(sender: tobject);  
begin  
// Создаем событие до того как будем его использовать  
event := tevent.create(nil,true,true,'');  
// Запускаем поток  
new := tnew.create(true);  
new.freeonterminate := true;  
new.priority := tplowest;  
new.resume;  
end;  
  
procedure tform1.formdestroy(sender: tobject);  
begin  
// Удаляем событие  
event.free;  
end;  
  
{ tnew }  
procedure tnew.execute;  
var  
n: integer;  
begin  
n := 0;  
while true do  
begin  
// wait-функция  
event.waitfor(infinite);  
if n > 99 then  
n := 0;  
// Одновременно приращиваем  
form1.progressbar1.position := n;  
form1.progressbar2.position := n;  
form1.progressbar3.position := n;  
// задержка для видимости  
sleep(100);  
inc(n)  
end;  
end;  
  
procedure tform1.button1click(sender: tobject);  
begin  
// Устанавливаем событие  
// wait-функция будет фозвращать управление сразу  
event.setevent;  
end;  
  
procedure tform1.button2click(sender: tobject);  
begin  
// wait-функция блокирует выполнение кода потока  
event.resetevent;  
end;  
  
end.  

Примером использования события с автосбросом может служить работа двух потоков, причем они работают следующим образом. Один поток готовит данные, а другой поток, после того как данные будут готовы, ну, например, отсылает их на сервер или еще куда. Получается нечто вроде поочередной работы.


unit unit1;  
  
interface  
  
uses  
windows, messages, sysutils, variants, classes, graphics, controls, forms, dialogs, stdctrls, syncobjs, comctrls;  
  
type  
tform1 = class(tform)  
label1: tlabel;  
procedure formcreate(sender: tobject);  
procedure formdestroy(sender: tobject);  
private  
{ private declarations }  
public  
{ public declarations }  
end;  
  
tproc = class(tthread)  
protected  
procedure execute; override;  
end;  
  
tsend = class(tthread)  
protected  
procedure execute; override;  
end;  
  
var  
form1: tform1;  
proc: tproc;  
send: tsend;  
event: tevent;  
  
implementation  
  
{$r *.dfm}  
  
procedure tform1.formcreate(sender: tobject);  
begin  
// Создаем событие до того как будем его использовать  
event := tevent.create(nil,false,true,'');  
// Запускаем потоки  
proc := tproc.create(true);  
proc.freeonterminate := true;  
proc.priority := tplowest;  
proc.resume;  
send := tsend.create(true);  
send.freeonterminate := true;  
send.priority := tplowest;  
send.resume;  
end;  
  
procedure tform1.formdestroy(sender: tobject);  
begin  
// Удаляем событие  
event.free;  
end;  
  
{ tnew }  
procedure tproc.execute;  
begin  
while true do  
begin  
// wait-функция  
event.waitfor(infinite);  
form1.label1.caption := 'proccessing...';  
sleep(2000);  
// Подготовка данных  
//...  
// разрешаем работать другому потоку  
event.setevent;  
end;  
end;  
  
{ tsend }  
procedure tsend.execute;  
begin  
while true do  
begin  
// wait-функция  
event.waitfor(infinite);  
form1.label1.caption := 'sending...';  
sleep(2000);  
// Отсылка данных  
//...  
// разрешаем работать другому потоку  
event.setevent;  
end;  
end;  
  
end.  

Вот и все объекты синхронизации модуля syncobjs, которых в принципе хватит для решения различных задач. В windows существуют другие объекты синхронизации, которые тоже можно использовать в delphi, но уже на уровне api. Это мьютексы - mutex, семафоры - semaphore и ожидаемые таймеры.

Добавлено: 04 Августа 2018 09:02:37 Добавил: Андрей Ковальчук

Построение графиков в Delphi

Начало
Наверное, все видели программы, которых довольно много, для построения всяческих графиков. Если Вы хотите написать что-то подобное на Delphi, то эта статья для Вас. В самых-самых программах Вам предлагается ввести формулу строкой, а не выбирать функции из списка. Самым сложным (?) элементом таких программ является текстовый анализатор. В данной статье я не собираюсь рассказывать, как пишутся текстовые анализаторы. Я собираюсь рассказать о некоторых основных принципах построения графиков, и работы с графикой в среде Delphi без использования специальных графических платформ, таких как DirectX или OpenGL.

Введение
В Delphi для прорисовки различных элементов управления используется специальный класс TCanvas. Можно выделить 4 основных направления, в которых используется этот класс:

Загрузка и хранение графических изображений.
Создание новых и изменение хранимых изображений с помощью пера, кисти, шрифта.
Рисование и/или закраска фигур, линий, текстов.
Комбинирование изображений.
Как Вы уже поняли, мы пойдем по третьему направлению.

Теперь давайте рассмотрим некоторые свойства и методы класса TCanvas. Сразу скажу, что я буду рассматривать далеко не все методы и свойства класса TCanvas, а лишь те, которые мы будем использовать потом.

TCanvas
Свойства:

property Brush: TBrush;

Данное свойство позволяет определить цвет (Brush.Color) и стиль (Brush.Style) заполнения замкнутых фигур и фона.

property ClipRect: TRect; - read-only

Данное свойство позволяет получить доступную область рисования. Вне этой области рисовать невозможно.

Тип TRect, описанный в модуле Windows,, имеет следующий синтаксис:


Type  
  TRect = record  
   Case integer of  
     0: (Left, Top, Right, Bottom: Integer);  
     1: (TopLeft, BottomRight: TPoint);  
 end;  
property Pen: Pen;

Данное свойство позволяет задать цвет пера, рисующего фигуры или линии.

Методы:

procedure FillRect (const Rect: TRect);

Метод позволяет заполнить цветом прямоугольную область холста Rect, используя текущее значение кисти Brush.

procedure MoveTo (x, y: integer);

Метод позволяет переместить перо в точку (X, Y).

procedure LineTo (x, y: integer);

Метод позволяет нарисовать прямую линию, которая начинается с текущей позиции пера и заканчивается точкой (x, y). При рисовании используются текущие установки пера Pen.

Ну вот, пожалуй, и все, что нам будет нужно, для успешного построения графика.

Построение графика. Теория.
Для начала предлагаю немного теории. Мы собираемся писать процедуру построения графика функции на определенной поверхности, заданной свойством Canvas. Я предлагаю поставить оси координат в середине этой области, а график растянуть так, чтобы он растянулся на всю область. Строить мы будем методом lineto. Поэтому нам нужно определиться с шагом изменения величины аргумента. Я предлагаю взять его обратным к масштабу по оси ординат. Так наш график будет выглядеть плавно при любой функции и любом начальном и конечном значении абсциссы. Масштаб по оси абсцисс считается, отношение ширины поверхности к разнице максимального и минимального значения абсциссы. Масштаб по оси ординат считается аналогично: отношение высоты поверхности к разнице между максимальным и минимальным значениями данной функции на данном интервале.

Процедура DrawGraph
Ну вот и все с теорией и я приведу полный код функции, а потом разберем его.


Type TFunc = function (x: real): real;  
  
procedure DrawGraph (f: TFunc; a: real; b: real; C: TCanvas);  
var x, y, h: real;  
    max, min: real;  
    sx, sy: real;  
    xmid, ymid: integer;  
begin  
sx := (c.ClipRect.Right)/(b-a);  
 h := 1/sx;  
 xmid := c.ClipRect.Right div 2;  
 ymid := c.ClipRect.Bottom div 2;  
 x := a;  
 max := f( x);  
 min := max;  
 while x<=b do  
  begin  
   y := f( x);  
   if y<min then min := y;  
   if y>max then max := y;  
   x := x + h;  
  end;  
 sy := c.ClipRect.Bottom/ (max-min);  
 c.Brush.Color := clBlack;  
 c.FillRect(Rect(0, 0, c.ClipRect.Right, c.ClipRect.Bottom));  
 c.Pen.Color := clYellow;  
 c.MoveTo(0, ymid);  
 c.LineTo(c.ClipRect.Right, ymid);  
 c.MoveTo(xmid, 0);  
 c.LineTo(xmid, c.ClipRect.Bottom);  
 x := a;  
 y := f(x);  
 c.Pen.Color := clWhite;  
 c.MoveTo(xmid+round(sx*x), ymid-round(sy*y));  
 while x<=b do  
  begin  
   y := f(x);  
   c.LineTo(xmid+round(sx*x), ymid-round(sy*y));  
   x := x + h;  
  end;  
end;  

А теперь, если Вы чего-либо не поняли, давайте разберем этот код.


Type TFunc = function (x: real): real;  

Здесь я создал тип-функцию, для того, чтобы передавать в функцию построения графика можно было передавать имя функции в эту процедуру.


procedure DrawGraph (f: TFunc; a: real; b: real; C: TCanvas); 

Заголовок функции. Параметры: f – функция, график, которой будем троить. a – начальное значение переменной “x”. b – конечное значение переменной “x”. C – канва, на которой будем рисовать.


sx := (c.ClipRect.Right)/(b-a);  
h := 1/sx;  
xmid := c.ClipRect.Right div 2;  
ymid := c.ClipRect.Bottom div 2;  
x := a;  
max := f( x);  
min := max;  
while x<=b do  
 begin  
  y := f( x);  
  if y<min then min := y;  
  if y>max then max := y;  
  x := x + h;  
 end;  
sy := c.ClipRect.Bottom/ (max-min);  

В этом куске кода мы считаем масштабы по осям координат, и среднее значения высоты и ширины канвы, чтобы отобразить оси координат.


c.Brush.Color := clBlack;  
c.FillRect(Rect(0, 0, c.ClipRect.Right, c.ClipRect.Bottom));  
c.Pen.Color := clYellow;  
c.MoveTo(0, ymid);  
c.LineTo(c.ClipRect.Right, ymid);  
c.MoveTo(xmid, 0);  
c.LineTo(xmid, c.ClipRect.Bottom);  

Здесь мы заливаем всю канву черным цветом и рисуем желтым цветом оси координат.


x := a;  
y := f(x);  
c.Pen.Color := clWhite;  
c.MoveTo(xmid+round(sx*x), ymid-round(sy*y));  
while x<=b do  
 begin  
  y := f(x);  
  c.LineTo(xmid+round(sx*x), ymid-round(sy*y));  
  x := x + h;  
 end;  

Ну и, наконец, нарисовали график нужной нам функции.

Небольшой пример:

Положим на форму одну кнопку и один компонент TImage. Создадим обработчик функции OnClick для кнопки примерно следующего характера, и следующую функцию для расчета функции


Function f(x: real): real;  
Begin  
 Result := sin(x)*cos(x);  
End;  
  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
 DrawGraph (f, -10, 10, Image1.Canvas);  
end;  

Вот и все.

Добавлено: 04 Августа 2018 09:00:05 Добавил: Андрей Ковальчук

Пособие по написанию своих компонентов на Дельфи для начинающих. Часть 2

Cодержание:

Редактирование значения, которое ввел пользователь
Использование другого компонента в вашем
Доступ к свойствам другого компонента
Использование в качестве предка класс TWinControl
Обработка событий OnMouseDown, OnMouseMove и OnMouseUp
Создание и использование своей иконки для компонента

Если вы прочли первую часть моего руководства или имеете хоть какие-то представления о написании компонентов, то вам конечно же хочется углубить свои знания и создавать более интересные компоненты. В этой части руководства мы рассмотрим много интересных моментов, касающихся создания компонентов.

Редактирование значения, которое ввел пользователь, изменяя какое-нибудь свойство.

Простой пример. Допустим у нас есть компонент (основанный на Tedit), у него есть два свойства: FirstNumber и SecondNumber. И у него есть процедура Division, в которой первое число делится на второе и результат присаивается свойству текст нашего компонента. Вот код этого компонента:


unit DivEdit;  
  
interface  
  
uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  
StdCtrls;  
  
type  
TDivEdit = class(Tedit)  
private  
{ Private declarations }  
FFirstNumber:integer;  
FSecondNumber:integer;  
FResult:Single; //в компонентах нельзя использовать Real!!!  
protected  
{ Protected declarations }  
public  
{ Public declarations }  
procedure Division;  
published  
{ Published declarations }  
constructor create(aowner:Tcomponent);override;  
property FirstNumber:integer read FFirstNumber write FFirstNumber;  
property SecondNumber:integer read FSecondNumber write FSecondNumber;  
property Result:Single read Fresult write FResult;  
end;  
  
procedure Register;  
  
implementation  
  
Constructor TDivEdit.create(aowner:Tcomponent);  
begin  
inherited create(aowner);  
FFirtsNumber:=1;  
  
FSecondNumber:=1;  
  
end;  
  
procedure TDivEdit.Division;  
begin  
FResult:=FFirstNumber/FSecondNumber;  
text:=floattostr(FResult);  
end;  
  
procedure Register;  
begin  
RegisterComponents('Mihan Components', [TDivEdit]);  
end;  
  
end.  

Хочется обратить ваше внимание на то, что в компонентах нельзя использовать переменные и поля типа Real, вместо него нужно брать переменные типов Single, Double, Extended.

Здесь все просто. Но вот если пользователю вздумается поделить на ноль (ну вдруг он математики не знает), то компонент выдаст ошибку DivisionByZero, а кому они нужны. Обойти эту проблему можно так: в код компонента добавить процедуру, которая проанализирует данные введенные пользователь и если все будет в порядке, то она присвоит значения соответствующим свойтсвам. В директиве Private объявите такую процедуру:

procedure SetSecondNumber(value:integer);


Обычно такие процедуры начинаются с приставки Set, затем идет имя свойства, и в конце тип переменной. Теперь в директиве Published надо сделать небольшие изменения:

property SecondNumber:integer read FSecondNumber write SetSecondNumber;

А теперь напишем саму процедуру:


procedure TDivEdit.SetSecondNumber(value:Integer);  
begin  
if value<>FSecondNumber then //надо проверить совпадают ли исходное и вводимое значения  
FSecondNumber:=value; //если нет, то изменить значение  
if FSecondNumber=0 then  
FSecondNumber:=1;  
end;  

Теперь сколько бы пользователь не вводил нулей значение SecondNumber будет единицей. Такие процедуры проверки рекомендуется использовать везде, где только допустимо появление исключительной ситуации.

Наверх^

Использование другого компонента в вашем

Попробуем создать такой компонент. Это будет обычная метка (Label), у которой будет две процедуры: ChangeBackColor и ChangeFontColor, которые соответственно будут менять цвет фона метки и цвет текста. Для этого нам понадобиться ColorDialog, который будет создаваться вместе с компонентом, а потом с помощью процедур он будет активироваться. Назовем компонент ColorLabel. Вначале добавим в uses два модуля: Dialogs, StdCtrls (в них находятся описания классаов диалога и метки). Теперь нам надо объявить переменную типа TColorDialog. Объявление идет сразу после секции Uses. Примерно это выглядит так:


uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls;  
var ColorDialog:TColorDialog;  
  
type  
...  

Теперь в конструкторе (Create), нам надо создать этот компонент:


constructor TColorLabel.create(aowner:Tcomponent);  
begin  
Inherited Create(aowner);  
ColorDialog:=TColorDialog.Create(self);  
end;  

Теперь надо объявить процедуры ChangeBackColor, ChangeFontColor. Чтобы они были доступны пользователю их надо поместить в директиву Public:


public  
{ Public declarations }  
procedure ChangeBackColor;  
procedure ChangeFontColor;  
published   

Осталось написать сами процедуры. Все очень просто: открываете диалог методом Execute, а затем присваиваете полученное значение цвета метке. У меня эти процедуры имеют такой вид:


procedure TColorLabel.ChangeBackColor;  
begin  
if ColorDialog.Execute then  
color:=ColorDialog.color;  
end;  
  
procedure TColorLabel.ChangeFontColor;  
begin  
if ColorDialog.Execute then  
font.color:=ColorDialog.color;  
end;  

Если у вас вдруг что-то не получилось, то взгляните на мой код целиком:


unit ColorLabel;  
  
interface  
  
uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls;  
var ColorDialog:TColorDialog;  
type  
TColorLabel = class(Tlabel)  
private  
{ Private declarations }  
protected  
{ Protected declarations }  
public  
{ Public declarations }  
procedure ChangeBackColor;  
procedure ChangeFontColor;  
published  
{ Published declarations }  
constructor create(aowner:tcomponent);override;  
end;  
  
procedure Register;  
  
implementation  
  
constructor TColorLabel.create(aowner:Tcomponent);  
begin  
Inherited Create(aowner);  
ColorDialog:=TColorDialog.Create(self);  
end;  
  
procedure TColorLabel.ChangeBackColor;  
begin  
if ColorDialog.Execute then  
color:=ColorDialog.color;  
end;  
  
procedure TColorLabel.ChangeFontColor;  
begin  
if ColorDialog.Execute then  
font.color:=ColorDialog.color;  
end;  
  
procedure Register;  
begin  
RegisterComponents('Mihan Components', [TColorLabel]);  
end;  
end.  

Наверх^

Доступ к свойствам другого компонента

Сейчас нам предстоит более сложная задача. Мы будем создавать компонент, вместе с которым будет создаваться какой-нибудь визуальный компонент. Например создадим кнопку, которая будет сопровождаться поясняющей надписью сверху. За основу возмем тип TButton. Нам надо будет создать еще и Label. Здесь существует одна проблемка: при перемещении компонента по форме, метка должна двигаться вместе с кнопкой, поэтому нам придется обрабатывать сообщение WmMove. Итак, объявляем переменную Label (в данном примере она объявлена в директиве Private, что тоже допустимо):


uses  
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,  
Forms, Dialogs, StdCtrls,buttons;  
  
type  
TLabelButton = class(TButton)  
private  
FLabel : TLabel ;  
Теперь я приведу весь код этого компонента и походу буду вставлять необходимые пояснения:


unit LabelBtn;  
interface  
  
uses  
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,  
Forms, Dialogs, StdCtrls,buttons;  
  
type  
TLabelButton = class(TButton)  
private  
FLabel : TLabel ; {создаем поле типа Tlabel}  
procedure WMMove( var Msg : TWMMove ) ; message WM_MOVE ;{процедура для обработки сообщения Wm_move, чтобы метка перемещалась вместе с кнопкой}  
protected  
procedure SetParent( Value : TWinControl ) ; override ;{необходимо воспользоваться и этой процедурой, так как нужно убедиться, имеют ли кнопка и метка общего предка}  
function GetLabelCaption : string ; virtual ; {Вот пример доступа из компонента к свойствам другого. Эти две процедуры для изменения текста метки}  
procedure SetLabelCaption( const Value : string ) ; virtual ;  
public  
constructor Create( AOwner : TComponent ) ; override ;  
destructor Destroy ; override ;  
published  
property LabelCaption : string read GetLabelCaption write  
SetLabelCaption ;  
end;  
  
procedure Register;  
  
implementation  
  
constructor TLabelButton.Create( AOwner : TComponent ) ;  
begin  
inherited Create( AOwner ) ;  
{ создаем TLabel }  
FLabel := TLabel.Create( NIL ) ;  
FLabel.Caption := 'Описание:' ;  
end ;  
  
procedure TLabelButton.SetParent( Value : TWinControl ) ;  
begin  
{надо убедиться, что у них предок один, чтоб проблем потом не было}  
if ( Owner = NIL ) or not ( csDestroying in Owner.ComponentState ) then  
FLabel.Parent := Value ;  
inherited SetParent( Value ) ;  
end ;  
  
destructor TLabelButton.Destroy ;  
begin  
if ( FLabel <> NIL ) and ( FLabel.Parent = NIL ) then  
FLabel.Free ;{Уничтожаем метку, т.к. она нам больше не нужна}  
inherited Destroy ;  
end ;  
  
function TLabelButton.GetLabelCaption : string ;  
begin  
Result := FLabel.Caption ;  
end ;  
  
procedure TLabelButton.SetLabelCaption( const Value : string ) ;  
begin  
FLabel.Caption := Value ;  
end ;  
  
procedure TLabelButton.WMMove( var Msg : TWMMove ) ;  
begin  
inherited ;  
if FLabel <> NIL then with Flabel do  
SetBounds( Msg.XPos, Msg.YPos - Height, Width,Height ) ; {изменяем левое и верхнее положение метки исходя из полученных координат}  
end;  
  
procedure Register;  
begin  
RegisterComponents('Mihan Components', [TLabelButton]);  
end;  
  
initialization  
RegisterClass( TLabel ) ; {Это делается для обеспечения поточности, но об этом не думайте, этим редко придется пользоваться}  
end.{Вы можете пользоваться этим компонентом сколько угодно, но распространять его можно только указывая авторство}  

Можно сделать доступ к любым свойствам метки, например, к шрифту, цвету и так далее, используя необходимые процедуры.

Наверх^

Использование в качестве предка класс TWinControl

Предыдущий пример был очень сложным, к тому же пришлось обрабатывать системные сообщения. Есть другое решение этой проблемы, более простое для понимания и для реализации: использовать в качестве контейнера класс TWinControl и в этот контейнер помещать другие компоненты. Теперь попробуем совместить Edit и Label. Давайте вместе создадим такой компонент. В качестве предка нужно выбрать класс TWinControl, а в качестве типа вашего компонента выберите TlabelEdit. Будем разбирать код по кусочкам.


unit LabelEdit;  
interface  
uses  
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,  
Forms, Dialogs, stdctrls;  
type  
TLabelEdit = class(TWinControl)  
private  
{ Private declarations }  
FEdit: TEdit;  
FLabel: TLabel;   

Здесь объявляются поля для метки и для Edit'a.


function GetLabelCaption: string;  
procedure SetLabelCaption(LabelCaption: string);  
function GetEditText: string;  
procedure SetEditText(EditText: string);   

Здесь объявлены функции для работы со свойствами Caption у метки и Text у Edit'a.


protected  
{ Protected declarations }  
public  
{ Public declarations }  
constructor Create(AOwner: TComponent); override;  
published  
property LabelCaption: string read GetLabelCaption write SetLabelCaption;  
property EditText: string read GetEditText write SetEditText;  
{ Published declarations }  
end;  
procedure Register;  
implementation  
constructor TLabelEdit.Create(AOwner: TComponent);  
begin  
inherited Create(AOwner);  
FEdit := TEdit.Create(self);{создаем поле редактирования Edit}  
FLabel := TLabel.Create(self);{создаем Label}  
with FLabel do begin  
Width := FEdit.Width;  
visible := true;  
Parent := self;  
Caption := 'Описание:';  
end;  
with FEdit do begin  
Top := FLabel.Height+2;  
Parent := self;  
Visible := true;  
end;  
Top := 0;  
Left := 0;  
Width := FEdit.Width;  
Height := FEdit.Height+FLabel.Height;{определяются размеры и положение компонентов}  
Visible := true;  
end;  
function TLabelEdit.GetLabelCaption: string;  
begin  
Result := FLabel.Caption;  
end;  
procedure TLabelEdit.SetLabelCaption(LabelCaption: string);  
begin  
FLabel.Caption := LabelCaption;  
end;  
function TLabelEdit.GetEditText: string;  
begin  
Result := FEdit.Text;  
end;  
procedure TLabelEdit.SetEditText(EditText: string);  
begin  
FEdit.Text := EditText;  
end;  
procedure Register;  
begin  
RegisterComponents('Mihan Components', [TLabelEdit]);  
end;  
end.   

Попробуйте установить этот компонент. Когда вы будете размещать его на форме, то будет виден "контейнер", на котором располагаются Edit и Label. Использование в качестве предка компонента класса TWinControl, очень удобно если вы хотите объединить несколько визуальных компонентов.

Наверх^

Обработка событий OnMouseDown, OnMouseMove и OnMouseUp

Часто возникает необходимость обработки событий нажатия и отпускания кнопки в вашем компоненте. Сейчас мы это и рассмотрим. Только ради примера сделаем компонент, который будет считать количество нажатий и отпусканий кнопки в его области, допустим это будет панель (Tpanel). Для этого в директиве Private надо объявить следующие процедуры и поля:


FClickCount:integer;  
FUpCount:integer;  
procedure MouseDown(Button:TMouseButton; Shift: TShiftState; X,Y: Integer); override;  
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;  
procedure MouseUp(Button:TMouseButton; Shift:TShiftState; X, Y: Integer); override; 

А в директиве Published надо написать:


constructor create(aowner:tcomponent);override;  
property ClickCount:integer read FclickCount write FClickCount;  
property UpCount:integer read FUpCount write FUpCount;  
property OnMouseDown;  
property OnMouseMove;  
property OnMouseUp;  

Ну и теперь осталось описать нужные процедуры:


procedure TMpanel.MouseDown(Button:TMouseButton; Shift: TShiftState; X,Y: Integer);  
begin  
FClickCount:=FClickCount+1;  
end;  
  
procedure TMpanel.MouseMove(Shift: TShiftState; X, Y: Integer);  
begin  
caption:=inttostr(x)+' '+inttostr(y);{для демонстрации работы этой процедуры. Надпись на панели будет отражать координаты курсора мыши над этой панелью}  
end;  
  
procedure TMpanel.MouseUp(Button:TMouseButton; Shift:TShiftState; X, Y: Integer);  
begin  
FUpCount:=FUpCount+1;  
end;  

Таким образом весь код компонента был таким:


unit Mpanel;  
  
interface  
  
uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  
ExtCtrls;  
  
type  
TMpanel = class(TPanel)  
private  
{ Private declarations }  
FClickCount:integer;  
FUpCount:integer;  
procedure MouseDown(Button:TMouseButton; Shift: TShiftState; X,Y: Integer); override;  
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;  
procedure MouseUp(Button:TMouseButton; Shift:TShiftState; X, Y: Integer); override;  
  
protected  
{ Protected declarations }  
public  
{ Public declarations }  
published  
{ Published declarations }  
constructor create(aowner:tcomponent);override;  
property ClickCount:integer read FclickCount write FClickCount;  
property UpCount:integer read FUpCount write FUpCount;  
property OnMouseDown;  
property OnMouseMove;  
property OnMouseUp;  
end;  
  
procedure Register;  
  
implementation  
  
constructor TMpanel.create(aowner:Tcomponent);  
begin  
inherited create(aowner);  
end;  
  
procedure TMpanel.MouseDown(Button:TMouseButton; Shift: TShiftState; X,Y: Integer);  
begin  
FClickCount:=FClickCount+1;  
end;  
  
procedure TMpanel.MouseMove(Shift: TShiftState; X, Y: Integer);  
begin  
caption:=inttostr(x)+' '+inttostr(y);  
end;  
  
procedure TMpanel.MouseUp(Button:TMouseButton; Shift:TShiftState; X, Y: Integer);  
begin  
FUpCount:=FUpCount+1;  
end;  
  
procedure Register;  
begin  
RegisterComponents('Mihan Components', [TMpanel]);  
end;  
  
end.  

Наверх^

Создание и использование своей иконки для компонента

Когда вы создали свой компонент и установили его, та на палитре компонентов, его иконка будет такой же как и у компонента, который вы выбрали в качестве предка. Конечно же вам хотелось бы видеть свой компонент со своей иконкой. Для этого необходимо создать файл ресурсов компонента. Сейчас я расскажу вам как это делается.

Откройте Image Editor (Tools->Image Editor) и выберите File->New->Component Resourse File. Перед вами появится небольшое окно с надписью Untitled.dcr в нем будет только одно слово: Contents. Нажмите на него правой кнопкой и в появившемся меню выберите New->Bitmap. Откроется диалоговое окно для настройки параметров изображения. Они должны быть такими: Размер 32x32, цветовой режим VGA (16 colors). Теперь нажмите ok. Теперь надо нажать правой кнопкой на появившейся надписи Bitmap1 и выбрать пункт Rename. Название картинки должно совпадать с названием класса компонента, для которого вы делаете эту иконку (например, TMPanel). Нажмите два раза на Bitmap1 и перед вами появится окно для рисования. Нарисуйте, что вам надо и перейдите на окно с надписью Untitled.dcr и в меню File выберите Save. Имя файла ресурса компонента должно совпадать с именем модуля компонента (без расширения конечно же, например, Mpanel). Файл ресурса готов. Теперь установите ваш компонент заново и в палитре компонентов ваш компонент будет уже с новой иконкой.

Добавлено: 04 Августа 2018 08:58:25 Добавил: Андрей Ковальчук

Полный мануал по созданию компактного кода

Любой хакер думает о том, как сократить размер своей программы. Это же несолидно иметь вирь или троян размером в пару мегабайт. Чем больше размер кода, тем дольше он загружается в память и больше отбирает ресурсов, что очень легко может выдать твое творение. Если при написании офисных приложений мы можем забыть про оптимизацию размера, то для вирусов, троянов и твоих приколов размер кода критичен.

Почему код большой?

В рубрике кодинг мы рассказываем тебе про язык программирования Delphi. Программы, созданные им, получаются достаточно большого размера. С чем это связано? А с тем, что Delphi является объектным языком. В нем каждый элемент выглядит как объект, который обладает своими свойствами, методами и событиями.

Любой объект вполне автономен и может работать без твоего ведома. Это значит, что тебе нужно только подключить его к своей форме, изменить нужные свойства, и все готово. После этого все будет работать без какого-либо внешнего вмешательства.

Но в этом есть и свои недостатки. В объектах реализовано большинство возможных действий, которые ты можешь производить с ним. Но реально в любой программе мы пользуемся двумя-тремя из всех этих свойств. Все остальное для программы лишний груз, который на фиг никому не нужен.

Как же тогда быть?

Но как же тогда создать компактный код, чтобы мой троян занимал минимум места на винте и как можно меньше светился в памяти? У тебя есть несколько вариантов:

Не использовать визуальную библиотеку VCL (для любителей Visual C++ это библиотека MFC), которая упрощает программирование. В этом случае придется все делать вручную и работать только с WinAPI. Код в этом случае получается очень маленьким и быстрым. Но тут ты лишаешься визуальности и можешь ощутить весь гемор программирования на чистом WinAPI.
Если ты регулярно читаешь Х, то в ноябре 2001 года ты должен был увидеть пример проги на чистом WinAPI в рубрике кодинг. Там наш запускной файл получился размером всего в 8 кило. И это притом, что при использовании VCL он увеличивается до 300 кило.

Сжимать программы с помощью компрессоров. Такой код сжимается в несколько раз, и программа с использованием VCL может превратиться из 300 кило в 30-50. Главное преимущество тут в том, что ты не лишаешься возможностей объектности и можешь спокойно забыть про пятна....
В этой статье я постараюсь как можно подробнее рассмотреть оба этих метода.

Ручной кодиг

Ручной кодинг (программирование без использования объектов и визуальности) похож на ручной секс (это когда ты удовлетворяешь себя вручную в отсутствии очаровашки). В обоих случаях эффект есть, но его приходится добиваться очень долго, и удовольствия от ручного метода намного меньше :). Но что поделать, иногда приходится идти на такие извращения ради создания компактных примочек.

Если ты хочешь создать программу маленького размера, то ты должен забыть про все удобства. Ты не сможешь подключать визуальные формы или другие примочки, написанные дядей Борманом для упрощения жизни программера. Только API функции и ничего больше.

Ручной кодиг в Delphi

Для того чтобы создать маленькую прогу в Delphi, нужно создать новый проект и зайти в менеджер проектов (меню View->Project Manager). Здесь нужно удалить все формы, чтобы остался только файл самого проекта (по умолчанию его имя Project1.exe). Никаких модулей в проекте не должно быть.

Теперь щелкни правой кнопкой по имени проекта и выбери из появившегося меню пункт "View Source" (или из главного меню Project выбери View Source). В редакторе кода откроется для редактирования файл проекта Project1.dpr. Если ты уже удалил все модули, то его содержимое должно быть таким:


program Project1;  
uses  
Forms;  
{$R *.res}  
begin  
Application.Initialize;  
Application.Run;  
end.  

Я удалил все визуальные формы и теперь могу скомпилировать абсолютно пустой проект. Я решил попробовать сделать это. После компиляции я выбрал из меню Project пункт "Information for Project1". Передо мной появилось окно с информацией о проекте.

В правой части окна должны быть описаны используемые пакеты. Мы все удалили, значит там точно должна красоваться надпись "None". А вот с левой стороны должна быть описана информация о скомпилированном коде. Самая последняя строка показывает размер файла, и у меня он равен 370688 байт. Ничего себе пельмень!!! Мы же ничего еще не писали. Откуда же тогда такой большой код?

Откуда ноги растут?

Давай разберем, что осталось в нашем проекте, чтобы обрезать все, что еще не обрезано. Сразу обрати внимание, что в разделе uses подключен модуль Forms. Это объектный модуль, написанный дядей Борманом, а значит его использовать нельзя. Между begin и end используется объект Application. Его тоже использовать нельзя.

Все накладки большого кода, даже у пустой проги, как раз и связаны с объектом Application. Хотя мы используем только два метода Initialize и Run, при компиляции в запускной файл попадает весь объект TApplication, а он состоит из сотен, а может и тысяч строчек кода.

Чтобы избавиться от накладных расходов, нужно заменить модуль Forms на Windows. А между begin и end вообще все можно удалять. Самый минимальный код проги будет выглядеть так:


program Project1;  
uses Windows;  
Begin  
end.  

Снова откомпилируй проект. Зайди в окно информации и посмотри на размер получившегося файла. У меня получилось 8192 байта. Вот это уже по-человечески.

Кодинг на WinAPI

Заготовка минимальной программы с использованием WinAPI готова. Теперь ты можешь смело добавлять свой код. Мне только надо объяснить тебе, какие модули можно подключать к своему проекту в раздел uses. Тут все очень просто и не займет много времени.

Если при установке Delphi ты не отключал копирование исходников библиотек, то перейди в диру, куда ты засандалил Delphi. Здесь перейди в папку "Source", затем в "Rtl" и, наконец, "Win". Вот здесь расположены исходники модулей, в которых описаны все API функции Windows. Именно эти модули ты можешь подключать к своим проектам, если хочешь получить маленький код. Если ты подключишь что-то другое, то я уже не гарантирую тебе минимум размера твоей проги (хотя есть и исключения).

Сразу лови пример. Если ты хочешь, чтобы в твоей программе были возможности работы с сетью, то тебе нужно подключить к нему библиотеку сокетов. Среди модулей WinAPI есть файл с именем winsock.pas. Значит, ты должен в раздел uses написать winsock (расширение писать не надо), и твоя программа сможет работать с сетью.

Пусть всегда будет...

Пока что я описал минимальный проект, в который можно добавлять свой код. Но код, который ты вставишь, выполнится один раз, и программа выгрузится из памяти. А что если тебе надо, чтобы твоя программа постоянно висела в окнах? Для этого используй следующий шаблон для своих прог:


program Project1;  
uses Windows;  
var  
Msg: TMsg;  
Begin  
//Сюда можешь добавлять свой код  
// Дальше идет код, который заставит прогу висеть в  
// памяти вечно и не будет сильно грузить систему.  
while GetMessage( Msg, HInstance, 0, 0) do  
begin  
TranslateMessage(msg);  
DispatchMessage(msg);  
end;  
end.  

Маленький код в Visual C++

Многие заблуждаются, говоря, что программы, созданные в Visual С++, уже получаются маленькими. Это действительно на 90% заблуждение. Сам язык С++ является объектным и страдает теми же недостатками, что и Delphi. Это значит, что именно на С++ код будет получаться очень большим.

Даже если ты создал новый проект и, откомпилировав его, получил очень маленький код, то это не значит, что программа получилась компактной. Реально твоя прога использует динамические библиотеки mfcХХ.dll. Здесь ХХ - это номер версии MFC (Microsoft Foundation Classes). Вся библиотека занимает около 2 мегов на диске. В результате твоя прога будет состоять из размера запускного файла плюс размер библиотеки MFC. Нехило? В Delphi тоже можно так мухлевать, если установить в свойствах проекта компиляцию с динамической загрузкой bpl (Borland Pascal Library) библиотек.

Чтобы реально создать маленький код на Visual C++, нужно также использовать только WinAPI и никаких объектов. Для этого при создании нового проекта ты должен выбрать тип "Win32 Application". В этом случае ты, как и в Delphi, ощутишь все прелести и корявости кодинга на WinAPI. Если ты до этого момента относился к Биллу параллельно, то после пары часов кодинга на WinAPI ты вступишь в партию ненавистников M$ :).

Сжатие программ

Если тебя не устраивает кодинг на чистом WinAPI, то твоим лучшим другом должна стать какая-нибудь прога для сжатия размера файлов. Я очень люблю ASPack, которую ты можешь забрать по адресу www.cydsoft.com/vr-online/download.htm. Она прекрасно сжимает запускные файлы .exe и динамические библиотеки .dll.

Я не буду объяснять установку ASPack, потому что там абсолютно ничего сложного нет. Только одно нажатие на кнопке "Next", и все готово. Теперь запусти установленную прогу и ты увидишь окно, как на рисунке 5. Главное окно состоит из нескольких закладок:

Open File
Compress
Options
About
Help

На закладке "Open File" есть только одна кнопка - "Оpen". Нажми на нее и выбери файл, который ты хочешь сжать. Как только ты выберешь файл, программа перескочит на закладку "Compress" и начнет сжатие.

Сжатый файл сразу перезаписывает существующий, а старая несжатая версия сохраняется на всякий случай под тем же именем, только с расширением bak.

Настроек у проги не так уж много, и с ними ты сможешь разобраться без меня. Уж лучше я расскажу тебе, как все работает.

Aspack под ножом патологоанатома

Давай разберемся, как работает сжатие. Сначала весь код программы сжимается архиватором. Если ты думаешь, что он какой-то навороченный, то сильно ошибаешься. Для сжатия используется простой архиватор типа WinZIP, только оптимизированный для сжатия байт-кода.

После этого в конец сжатого кода добавляется код разархиватора, который будет все это дело разжимать обратно. И в самом конце ASPack изменяет заголовок запускного файла так, чтобы при старте сначала запускался разархиватор.

Теперь, когда ты запустишь сжатую прогу, сначала запустится разархиватор, который разожмет байт-код программы и аккуратно выложит его в памяти машины. Как только этот процесс пройдет, разархиватор передаст управление твоей проге.

Некоторые умники сейчас ляпнут, что из-за расходов на распаковку программа будет работать медленней!!! Я бы не сказал, что ты это заметишь. Даже если и возникнут какие-то потери, то они будут неощутимы. Это потому, что архивация хорошо оптимизирована под байт-код. К тому же, размер проги уменьшится, а значит она загрузится в память намного быстрее. В результате потери на скорости неощутимы даже с секундомером.

Archiving complete

Конечно же, кодинг на WinAPI слишком сложный, но программы получаются очень маленького размера, и никакой архиватор не сможет сжать байт-код до такой степени. А если еще и сжать прогу, написанную на WinAPI, то ее размеры будут меньше некуда.

При нормальном кодинге с использованием всех навороченных фишек типа визуальности и объектности код получается большим, но его можно сжать на 60-70% спецархиватором. К тому же такой код писать намного легче и быстрее.

В любом случае архивирование - необходимая любому хакеру фишка. Сжатый код труднее взломать, потому что не каждый disassembler сможет прочитать упакованные команды. Так что, помимо уменьшения размера, ты получаешь защиту, способную отпугнуть большинство крякеров. Конечно же, профи не отпугнешь даже большим Билом :), но крякер средней паршивости не будет мучиться со сжатым байт-кодом.

На этом архивирование считаю законченным. Несмотря на небольшой размер выделенного мне места, я смог рассказать тебе достаточно инфы, чтобы ты смог начать уже сейчас писать маленький код. На этом и закончим сегодняшний урок оптимизации. Надеюсь, что еще увидимся.

Автор: Фленов Михаил

Добавлено: 04 Августа 2018 08:46:52 Добавил: Андрей Ковальчук

Полет над строкой

Не сильно преувеличу, если скажу, что строки являются одной из основных жемчужин языка Object Pascal. Простые и незаметные, но в то же время такие мощные. Речь, конечно, о длинных строках, объявляемых с помощью типа string (AnsiString). Строки настолько удобны, что их использование часто выходит далеко за рамки работы с текстом. Ну разве не может понравиться возможность склеить два бинарных куска данных простым сложением s1 + s2. В немалой степени таким возможностям способствует поистине гениальное устройство длинной строки. В частности она позволяет хранить любые символы, в том числе нулевые. Замечу, что во многих языках строки представляют собой указатели на первый символ строки, которая должна заканчиваться нулем. Такие строки называются zero-terminated strings. Недостатки такого подхода очевидны: невозможность хранить нулевые символы в строке, медленная работа из-за необходимости сканирования строки для нахождения ее длины, блуждание и порча памяти в случае отсутствия завершающего нуля. Паскалевская строка вместо этого хранит свою длину в виде четырехбайтного значения по отрицательному смещению от начала самой строки. Но при этом еще автоматически подставляет нулевой символ в конце строки! То есть такая строка может выступать и в качестве zero-terminated string с помощью простого приведения типа к указателю на строку PChar. Это часто требуется, например, при вызове функций WinAPI. Возможность хранить в строке любые бинарные данные, гибкость работы с ней и широта использования невольно наводят на мысль использовать строку в качестве хранилища данных. И разработчики Delphi 6 даже включили в стандартный модуль Classes новый потоковый класс - TStringStream. Он весьма похож на TMemoryString, только внутри в качестве хранилища данных потока используется строка. Интерфейс этого класса позволяет легко заполнить поток данными из строки, произвести над ними какие-то операции, и получить обратно данные опять же в виде строки:


var  
  ss: TStringStream;  
  s: string;  
  i: integer;  
  r: TRecord;  
begin  
  s:= '12345';  
  i:= $FFFFFFFF;  
  ss:= TStringStream.Create( s );  
  try  
    ss.Position:= 3;  
    ss.WriteString( '321' );      // теперь строка имеет вид '123321'  
    ss.Write( i, sizeof( i ) );   // теперь в конце еще добавлены 4 символа с кодом FF  
    ss.Write( rr, sizeof( rr );   // теперь дописали еще данные некой записи (record)  
    s:= ss.DataString;            // получаем результирующую строку  
  finally  
    FreeAndNil( ss );  
  end;  
end;  

Такие вещи и раньше делались с помощью TMemoryString, но теперь это гораздо удобнее из-за отсутствия необходимости приведения типов. Код стал короче и прозрачнее. Но все же есть в классе TStringStream и парочка своих ложек дегтя. Во-первых, довольно странная реализация метода Write, которая не позволяет этому классу быть равнозначной заменой другим наследникам TStream. Дело в том, что данный метод всегда устанавливает размер потока по концу только что записанных данных. Так что имеет смысл только последовательная запись. Попытка переместиться внутри потока и записать небольшой фрагмент данных приведет к "обрезанию" потока по концу этого фрагмента. Во-вторых, далеко не оптимальная реализация механизмов работы с памятью (в частности интенсивное использование функции Length для определения размера потока), что делает класс несколько "тормозным" при активной работе. Такая ситуация сподвигла меня на написание своего аналога TStringStream, лишенного этих недостатков. Его вам и представляю:


unit StrStrm;  
   
interface  
  
uses  
  Classes;  
  
type  
  TStrStream = class(TStream)  
  private  
    FDataString: string;  
    FPosition: integer;  
    FSize: integer;  
    FMemory: pointer;  
  protected  
    procedure SetSize(NewSize: Longint); override;  
  public  
    constructor Create(const AString: string);  
    function Read(var Buffer; Count: Longint): Longint; override;  
    function ReadString(Count: Longint): string;  
    function Seek(Offset: Longint; Origin: Word): Longint; override;  
    function Write(const Buffer; Count: Longint): Longint; override;  
    procedure WriteString(const AString: string);  
    property DataString: string read FDataString;  
  end;  
  
implementation  
  
{ TStrStream }  
  
constructor TStrStream.Create(const AString: string);  
begin  
  inherited Create;  
  WriteString(AString);;  
  FPosition:= 0;  
end;  
  
function TStrStream.Read(var Buffer; Count: Longint): Longint;  
begin  
  Result := FSize - FPosition;;  
  if Result > Count then Result := Count;  
  Move((PChar(longword(FMemory) + longword(FPosition)))^, Buffer, Result);  
  Inc(FPosition, Result);  
end;  
  
function TStrStream.Write(const Buffer; Count: Longint): Longint;  
begin  
  Result := Count;  
  if FPosition + Result > FSize then  
  begin  
    SetLength(FDataString, (FPosition + Result));  
    FSize:= FPosition + Result;  
    if FSize > 0 then  
      FMemory:= @(FDataString[1]);  
  end;  
  Move(Buffer, (PChar(longword(FMemory) + longword(FPosition)))^, Result);  
  Inc(FPosition, Result);  
end;  
  
function TStrStream.Seek(Offset: Longint; Origin: Word): Longint;  
begin  
  case Origin of  
    soFromBeginning: FPosition := Offset;  
    soFromCurrent: FPosition := FPosition + Offset;  
    soFromEnd: FPosition := FSize - Offset;  
  end;  
  if FPosition > FSize then  
    FPosition := FSize  
  else  
    if FPosition < 0 then  
      FPosition := 0;  
  Result := FPosition;  
end;  
  
function TStrStream.ReadString(Count: Longint): string;  
var  
  Len: Integer;  
begin  
  Len := FSize - FPosition;  
  if Len > Count then Len := Count;  
  SetString(Result, PChar(longword(FMemory) + longword(FPosition)), Len);  
  Inc(FPosition, Len);  
end;  
  
procedure TStrStream.WriteString(const AString: string);  
begin  
  Write(PChar(AString)^, Length(AString));  
end;  
  
procedure TStrStream.SetSize(NewSize: Longint);  
begin  
  if NewSize <> FSize then  
  begin  
    SetLength(FDataString, NewSize);  
    FSize:= NewSize;  
    if FSize > 0 then  
      FMemory:= @(FDataString[1])  
    else  
      FMemory:= nil;  
    if FPosition > NewSize then FPosition := NewSize;  
  end;  
end;  
  
end.  

Быстрота и удобство этого класса привели к тому, что я использую его практически везде, где раньше требовался TMemoryStream. Если к нему еще добавить методы LoadFrom... и SaveTo..., то замена будет полной. Но эту доработку я оставлю для вашего удовольствия :)

Владимир Волосенков uno@tut.by

Добавлено: 04 Августа 2018 08:45:36 Добавил: Андрей Ковальчук