Скриншот страницы в компоненте WebBrpwser

Сегодня мы, будем делать скриншот активной web страницы в компоненте webbrowser.
Итак нам понадобятся следующие компоненты: WebBrowser с закладки Internet, 2 компонента Button с зкладки Standard.
Для начала после ключевого слова uses допишите ActiveX, jpeg

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


procedure WebBrowserScreenShot(const wb: TWebBrowser; const fileName: TFileName) ;  

Нажимаем комбинацию клавиш CTRL+SHIFT+C, Delphi создаст шаблон процедуры, а вот что должно получиться в итоге:


procedure TForm1.WebBrowserScreenShot(const wb: TWebBrowser;  
const fileName: TFileName);  
var  
viewObject : IViewObject;  
r : TRect;  
bitmap : TBitmap;  
begin  
if wb.Document <> nil then  
begin  
wb.Document.QueryInterface(IViewObject, viewObject) ;  
if Assigned(viewObject) then  
try  
bitmap := TBitmap.Create;  
try  
r := Rect(0, 0, wb.Width, wb.Height) ;  
bitmap.Height := wb.Height;  
bitmap.Width := wb.Width;  
viewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Application.Handle, bitmap.Canvas.Handle, @r, nil, nil, 0) ;  
with TJPEGImage.Create do  
try  
Assign(bitmap) ;  
SaveToFile(fileName) ;  
finally  
Free;  
end;  
finally  
bitmap.Free;  
end;  
finally  
viewObject._Release;  
end;  
end;  
end;   

*Посмотрите на этот код и на свой шаблон, допишите не достающие строки !
Двигаемся дальше, создаем обработчик событий OnClick на первой кнопке, в нем прописываем вот такую строку:


WebBrowser1.Navigate('http://delphiexpert.ru') ;   

Теперь создаем обработчик событий на второй кнопке, между begin ... end пропишите:


WebBrowserScreenShot(WebBrowser1,'c:\WebBrowserImage.jpg') ;   

Вот в принципе и все, запускаем проект, нажимаем сначала на первую кнопку - в WebBrouser'e открывается страница www.delphiexpert.ru. Теперь жмем на вторую кнопку и на диске C:\ создается файл с именем WebBroserImage.jpg в котором будет находиться скриншот сайта delphiexpert.ru

На этом всё.

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

Создаем Анимированный ProgressBar

Всем привет в этом уроке мы научимся создавать свой анимированный ProgressBar, подойдет он для тех случаев когда точное число шагов неизвестно, ну в общем скоро вы все поймете ) Итак поехали:

Открываем Delphi и как всегда создаем новый проект, кидаем на форму компонент Timer с закладки System и компонент Image с закладки Additional, больше компонентов у нас не будет! Двигаемся дальше, сейчас нам нужно будет создать одну небольшую процедурку поэтому переходим в код находим там ключевое слово public и после него пишем


procedure GoImgProgress (Const IMG: TImage);  

Нажимаем комбинацию клавиш Ctrl+Shift+C Delphi генерирует нам шаблон будущей процедуры. Теперь посмотрите то что должно получиться в конце и допишите к своему шаблону недостающие строчки.


procedure TForm1.GoImgProgress(const IMG: TImage);  
const  
step=2;  
var  
f:Tbitmap;  
begin  
with image1.Picture.Bitmap do // Image1 - это имя компонента image  
begin  
f:= Tbitmap.create;  
try  
f.width:=width;  
f.height:=height;  
BitBlt(f.Canvas.Handle, step, 0, Width-step, Height, Canvas.Handle, 0, 0, SRCCOPY) ;  
BitBlt(f.Canvas.Handle, 0, 0, step, Height, Canvas.Handle, Width-step, 0, SRCCOPY) ; ;  
Assign(f) ;  
finally  
FreeAndNil(f) ;  
end;  
end;  
end;  

Ну что я надеюсь что вы справились, потому что сейчас нам нужно будет загрузить в компонент image1 какую ни будь картинку в формате bmp. Кликаем два раза на компонент image, далее жмем load и выбираем нужную картинку. Лично я пользовался вот этой:

Далее переходим к компоненту timer, свойство interval ставим 100, свойство Enabled ставим true. Создаем обработчик событий (OnTimer) на нашем таймере - два раза кликаем по нему и между словами begin end пишем:


GoImgProgress(image1);  

Вот и всё, теперь вы умеете создавать анимированный Progressbar ! Запускаем проект и наслаждаемся !)

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

Основные функции библиотеки BASS 2.4

Иницилаизирует звуковой поток


function BASS_Init(device: Integer; freq, flags: DWORD; win: HWND; clsid: PGUID): BOOL;  
// Пример использования:  
BASS_Init(-1, 44100, 0, handle, nil);  

Очищает звуковой поток, в скобках указываем имя потока.


function BASS_StreamFree(handle: HSTREAM): BOOL;  

Создаем звуковой поток из локального файла


function BASS_StreamCreateFile(mem: BOOL; f: Pointer; offset, length: QWORD; flags: DWORD): HSTREAM;   
// Пример использования  

Имя потока := Bass_streamCreateFile(false, PChar('C:\muzic.mp3'),0,0,0);
Узнать длинну звукового потока


function BASS_ChannelGetLength(handle, mode: DWORD): QWORD;  
// Пример использования  
BASS_ChannelGetLength(Имя потока,0);  

Начать проигрывать звук


function BASS_ChannelPlay(handle: DWORD; restart: BOOL): BOOL;  
// Пример использования:  
Bass_channelPlay(Имя потока, false);   

Сделать паузу


function BASS_ChannelPause(handle: DWORD): BOOL;  
// Пример использования  
BASS_ChannelPause(Имя потока);   

Остановить проигрывание звука.


function BASS_ChannelStop(handle: DWORD): BOOL;  
// Пример использования  
BASS_ChannelStop(Имя потока); 

Установить новую позицию в потоке( необходимио для перемотки) Сдвигает позицию проигрывания на pos вперед.


function BASS_ChannelSetPosition(handle: DWORD; pos: QWORD; mode: DWORD): BOOL;  
// Пример использования  
BASS_ChannelSetPosition(Имя потока, ScrollBar1.Position, 0);   

Получает атрибуты канала. Если не хочешь получать какое-нибудь свойство, ставь null


function BASS_ChannelGetAttribute(handle, attrib: DWORD; var value: FLOAT): BOOL;  

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

Как экспортировать таблицу базы данных в ASCII-файл?

procedure TMyTable.ExportToASCII;  
var  
  I: Integer;  
  Dlg: TSaveDialog;  
  ASCIIFile: TextFile;  
  Res: Boolean;  
begin  
  if Active then  
    if (FieldCount > 0) and (RecordCount > 0) then  
      begin  
        Dlg := TSaveDialog.Create(Application);  
        Dlg.FileName := FASCIIFileName;  
        Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc';  
        Dlg.Options := Dlg.Options+[ofPathMustExist,   
          ofOverwritePrompt, ofHideReadOnly];  
        Dlg.Title := 'Экспоритровать данные в ASCII-файл';  
        try  
          Res := Dlg.Execute;  
          if Res then  
            FASCIIFileName := Dlg.FileName;  
        finally  
          Dlg.Free;  
        end;  
        if Res then  
          begin  
            AssignFile(ASCIIFile, FASCIIFileName);  
            Rewrite(ASCIIFile);  
            First;  
            if FASCIIFieldNames then  
              begin  
                for I := 0 to FieldCount-1 do  
                  begin  
                    Write(ASCIIFile, Fields[I].FieldName);  
                    if I <> FieldCount-1 then  
                     Write(ASCIIFile, FASCIISeparator);  
                  end;  
                Write(ASCIIFile, #13#10);  
              end;  
            while not EOF do  
              begin  
                for I := 0 to FieldCount-1 do  
                  begin  
                    Write(ASCIIFile, Fields[I].Text);  
                    if I <> FieldCount-1 then  
                      Write(ASCIIFile, FASCIISeparator);  
                  end;  
                Next;  
                if not EOF then  
                 Write(ASCIIFile, #13#10);  
              end;  
            CloseFile(ASCIIFile);  
            if IOResult <> 0 then  
              MessageDlg('Ошибка при создании или переписывании '+  
                'в ASCII-файл', mtError, [mbOK], 0);  
          end;  
      end  
    else  
      MessageDlg('Нет данных для экспортирования.',  
        mtInformation, [mbOK], 0)  
  else  
    MessageDlg('Таблица должна быть открытой, чтобы данные '+  
      'можно было экспортировать в ASCII-формат.', mtError,  
      [mbOK], 0);  
end;  

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

Учимся ставить ограничения

В этом уроке я покажу вам 2 способа поставить временное ограничение на работу программы.

Способ №1 Более интересный.

Первое что нам нужно сделать это кинуть на форму 2 компонента label с закладки Standart и один компонент timer с закладки system.
Объявляем переменные: для реализации данного способа нам понадобиться две глобальные переменные:

Opentime
Closetime тип у них будет tDateTime
В общем если кто не понял то после ключевого слова var пишем вот такую строчку:


closetime, opentime: tdatetime;  

Идем дальше, теперь создаем обработчик событий на форме OnCreate - для этого просто кликаем на форме 2 раза
между begin end пишем следующий код:


opentime:= time; //Функция time выдает нам время в данный момент  
closetime:= opentime+strtotime('00:00:30');  
//Здесь мы добавляем к времени старта нужное время.  
//В данном случае - в формате чч:мм:сс  
label1.Caption:=timetostr(opentime);  

С формой разобрались, переходим к таймеру также создаем обработчик событий на нем OnTime
Между begin end; пишем:


if time > closetime then //Если текущее время > времени окончания //программы то  
begin  
showmessage('Время работы программы истекло ! '); //Показываем //сообщение  
close; //закрываем программу  
end;  
Label2.Caption:=timetostr(opentime-closetime); // иначе показываем время //до завершения программы  

Вот в принципе и все, осталось только выставить true в свойстве Enabled у таймера.

Способ №2 Более простой.

Кидаем на форму компонент timer с закладки system. Свойство Enabled выставляем на true. Свойство Interval ставим равное 30000 (через 30 сек программа закроется).
Создаем обработчик событий Ontime в нем прописываем следующий код


showmessage('Время работы программы истекло ! ');  
close;  

Вот и все!

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

Учимся увеличивать часть экрана под курсором

В этом уроке я хочу вам рассказать, как в Delphi увеличить определённую область экрана в районе курсора мышки. Ну что запускаем Delphi, нам понадобиться: Image с закладки Additional, TackBar (Win32), Timer (System) кидаем эти компоненты на форму. Теперь давайте установим свойство min компонента trackbar равным 1, а свойство interval компонента Timer также сделаем равным 1. Все основные действия происходят в Timer'е поэтому создаем обработчик событий OnTime именно на нем. Ниже приведен код данного события.

Delphi увеличиваем часто экрана исходник


procedure tform1.timer1timer(sender: tobject);  
var  
srect,drect,posforme :trect;  
iwidth,iheight,dmx,dmy:integer;  
itmpx,itmpy :real;  
c :tcanvas;  
kursor :tpoint;  
  
begin  
if not isiconic(application.handle) then  
begin // Получаем координаты курсора  
getcursorpos(kursor);  
  
// posform представляет прямоугольник с  
// координатами form (image control).  
posforme:=rect(form1.left,  
form1.top,  
form1.left+form1.width,  
form1.top+form1.height);  
//Показываем magnified screen  
//если курсор за пределами формы.  
if not ptinrect(posforme,kursor) then begin  
// Далее код можно использовать для увеличения выбранной  
// части экрана.  
iwidth:=image1.width;  
iheight:=image1.height;  
drect:=bounds(0,0,iwidth,iheight);  
itmpx:=iwidth / (trackbar1.position * 4);  
itmpy:=iheight / (trackbar1.position * 4);  
srect:=rect(kursor.x,kursor.y,kursor.x,kursor.y);  
inflaterect(srect,round(itmpx),round(itmpy));  
//Получаем обработчик(handle) окна рабочего стола.  
c:=tcanvas.create;  
try  
c.handle:=getdc(getdesktopwindow);  
//Передаём часть изображения окна в tImage.  
image1.canvas.copyrect(drect,c,srect);  
finally  
c.free;  
end;  
end;  
// Обязательно обрабатываем все сообщения windows.  
application.processmessages;  
end;  
end;   

Как видите все просто. А теперь попробуйте сами ументшить часть экрана над которой находиться курсор. Слабо))

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

Пирамидальная сортировка

Алгоритм пирамидальной сортировки (heapsort) — один из самых быстрых алгоритмов сортировки.


Program heapsort;   
   
{$APPTYPE CONSOLE}   
   
type   
  tkey = integer;   
  int = integer;   
   
const N = 10;     
   
var a,b : array [0..N+1] of tkey;   
   
function parent(x : int) : int;   
begin   
  result:=x shr 1;   
end;   
   
function left(x : int) : int;   
begin   
  result := x shl 1;   
  if result > a[0] then result := N+1;   
end;   
   
function right(x:int):int;   
begin   
  result := x shl 1 + 1;   
  if result > a[0] then result := N+1;   
end;   
   
procedure swap(i,j : int);   
var temp : tkey;   
begin   
  temp := a[i];   
  a[i] := a[j];   
  a[j] := temp;   
end;   
   
procedure moveup(x : int);   
begin   
  while (a[x] > a[parent(x)]) and (parent(x) > 0)  do begin   
    swap(x, parent(x));   
    x := parent(x);   
  end;   
end;   
   
procedure movedown(x : int);   
var max : integer;   
begin   
  if a[left(x)] > a[right(x)] then max := left(x)   
  else max := right(x);   
  while (a[max] > a[x]) and (max <= a[0]) do begin   
    swap(max, x);   
    x := max;   
    if a[left(x)] > a[right(x)] then max := left(x)   
    else max := right(x);   
  end;   
end;   
   
   
procedure update(x : int; k : tkey);   
begin   
  a[x] := k;   
  moveup(x);   
  movedown(x);   
end;   
   
procedure add(k : tkey);   
begin   
  inc(a[0]);   
  update(a[0], k);   
end;   
   
procedure delete(x : int);   
begin   
  swap(x, a[0]);   
  dec(a[0]);   
  update(x, a[x]);   
end;   
   
procedure hsort;   
var i:int;   
begin   
  a[0] := 1;   
  a[1] := b[1];   
  for i := 2 to N do   
    add(b[i]);   
  for i := 1 to N do   
    delete(1);   
end;   
   
var i : int;   
   
begin   
  randomize;   
  fillchar(a, sizeof(a), 0);   
  fillchar(b, sizeof(b), 0);     
   
  for i := 1 to N do   
    b[i] := random(10);   
   
  writeln('Non-sorted elements');   
  for i := 1 to N do   
    write(b[i], ' ');   
  writeln;   
   
  hsort;   
   
  writeln('Sorted elements');   
  for i := 1 to N do   
    write(a[i], ' ');   
  readln;   
end.  

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

Многострочная подсказка (Hints)


unit MHint;  
  
interface  
  
uses  
  SysUtils, WinTypes, WinProcs, Messages,  
  Classes, Graphics, Controls, Forms, Dialogs;  
    
type  
  TMHint = class(TComponent)  
  private  
    ScreenSize: Integer;  
    FActive: Boolean;  
    FSeparator: Char;  
    FOnShowHint: TShowHintEvent;  
  protected  
    procedure SetActive(Value: Boolean);  
    procedure SetSeparator(Value: char);  
    procedure NewHintInfo(var HintStr: string;   
      var CanShow: Boolean;  
      var HintInfo: THintInfo);  
  public  
    constructor Create(AOwner: TComponent); override;  
  published  
    property Active: Boolean  
      read FActive write SetActive;  
    property Separator: Char  
      read FSeparator write SetSeparator;  
  end;  
  
procedure Register;  
  
implementation  
  
constructor TMHint.Create(AOwner: TComponent);  
  
begin  
  inherited Create(AOwner);  
  FActive := True;  
  FSeparator := '@';  
  Application.OnShowHint := NewHintInfo;  
  ScreenSize := GetSystemMetrics(SM_CYSCREEN);  
end;  
  
procedure TMHint.SetActive(Value: Boolean);  
begin  
  FActive := Value;  
end;  
  
procedure TMHint.SetSeparator(Value: Char);  
begin  
  FSeparator := Value;  
end;  
  
procedure TMHint.NewHintInfo(var HintStr: string;   
  var CanShow: Boolean;  
  var HintInfo: THintInfo);  
var   
  I: Byte;  
begin  
  if FActive then  
   begin  
      I := Pos(FSeparator, HintStr);  
      while I > 0 do  
        begin  
          HintStr[I] := #13;  
          I := Pos(FSeparator, HintStr);  
        end;  
      if HintInfo.HintPos.Y+10 > ScreenSize then  
        HintInfo.HintPos.Y := ScreenSize-11;  
    end;  
end;  
  
procedure Register;  
begin  
  RegisterComponents('MyComponents', [TMHint]);  
end;  
end. 

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

Изучаем ассемблер в Delphi

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

Основное направление статьи, это познакомиться с использованием ассемблера в Object Pascal. Однако, не будем пропускать и те аспекты программирования, которые будут требовать пояснения для конкретных примеров, приведённых в этой статье.

Использование Ассемблера в Борландовком Delphi
Перед тем, как начать, хотелось бы определиться с уровнем знаний, необходимых для нормального усвоения данного материала. Необходимо быть знакомым со встроенными средствами отладки в Delphi. Так же необходимо иметь представление о таких терминах как тип реализации (instantiation), null pointer и распределение памяти. Если в чём-то из вышеупомянутого Вы сомневаетесь, то постарайтесь быть очень внимательны и осторожны при воплощении данного материала на практике. Кроме того, будет обсуждаться только 32-битный код, так что понадобится компилятор не ниже Delphi 2.0.

Зачем использовать Ассемблер?
На мой взгляд, Object Pascal, это инструмент, позволяющий генерировать быстрый и эффективный код, однако использование ассемблера в некоторых случаях позволяет решать некоторые задачи более эффективно. За всю работу с Delphi, я пришёл к выводу, что использование низкоуровневого кода необходимо в двух случая.

(1) Обработка большого количества данных. Nb. В данный случай не входит ситуация, когда используется язык запроса данных.

(2) В высокоскоростных подпрограммах работы с дисплеем. Nb. Имеется ввиду использование простых процедур на чистом паскале, но никак не внешних библиотек и DirectX.

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

Что такое Ассемблер?
Надеюсь, что Все читатели этой статьи имеют как минимум поверхностное представление о работе процессора. Грубо говоря, это калькулятор с большим объёмом памяти. Память, это не более чем упорядоченная последовательнось двоичных цифр. Каждая такая цифра является байтом. Каждый байт может содержать в себе значение от 0 до 255, а так же имеет свой уникальный адрес, при помощи которого процессор находит нужные значения в памяти. Процессор так же имеет набор регистров (это можно расценить как глобальные переменные). Например eax,ebx,ecx и edx, это универсальные 32-битные регистры. Это значит, что самое большое число, которое мы можем записать в регистр eax, это 2 в степени 32 минус 1, или 4294967295.

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

05/0a/00/00/00
Однако, такая запись абсолютно не читабельна и, как следствие, не пригодна при отладке программы. Так вот Ассемблер, это простое представление машинных команд в более удобном виде. Теперь давайте посмотрим, как будет выглядеть прибавление 10 к eax в ассемблерном представлении:

add eax,10 {a := a + 10}

А вот так выглядит вычитаение значения ebx из eax

sub eax,ebx {a := a - b }

Чтобы сохранить значние, можно просто поместить его в другой регистр

mov eax,ecx {a := c }

или даже лучше, сохранить значение по определённому адресу в памяти

mov [1536],eax {сохраняет значение eax по адресу 1536}

и конечно же взять его от туда

mov eax,[1536]

Однако, тут есть важный момент, про который забывать не желательно. Так как регистр 32-битный(4 байта), то его значение будет записано сразу в четыре ячейки памяти 1536, 1537, 1538 и 1539.

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

Count := 0;

Для компилятора это означает, что надо просто запомнить значение. Следовательно, компилятор генерирует код, который сохраняет значение в памяти по определённому адресу и следит, чтобы не произошло никаких накладок, и обзывает этот адрес как 'Count'. Вот как выглядит такой код

mov eax,0 
mov Count,eax

Компилятор не может использовать строку типа

mov Count,0

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

Count := Count + 1;

то её ассемблерное представление будет выглядеть как

mov eax,Count
add eax,1
mov Count,eax

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

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


function Sum(X,Y:integer):integer;   
begin   
 Result := X+Y;   
end; 

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


function Sum(X,Y:integer):integer;   
begin   
 asm  
  mov eax,X  
  add eax,Y  
  mov Result,eax  
 end;  
end;  

Этот код прекрасно работает, однако он не даёт нам преимущества в скорости, а так же потерялось восприятие кода. Но не стоит огорчаться, так как те немногие знания, которые Вы почерпнули из этого материала, можно использовать с большей пользой. Допустим, нам необходимо преобразовать явные значения Red,Green, и Blue в цвета типа TColor, подходящие для использования в Delphi. Тип TColor описан как 24-битный True Colour хранящийся в формате целого числа, то есть четыре байта, старший из которых равен нулю, а далее по порядку красный, зелёный, синий.


function GetColour(Red,Green,Blue:integer):TColor;   
begin   
 asm  
{ecx будет содержать значение TColor}  
  mov ecx,0   
{начинаем с красной компоненты}  
  mov eax,Red   
{необходимо убедиться, что красный находится в диапазоне 0<=Red<=255}  
  and eax,255   
{сдвигаем значение красного в правильное положение}  
  shl eax,16   
{выравниваем значение TColor}  
  xor ecx,eax   
{проделываем тоже самое с зелёным}  
  mov eax,Green   
  and eax,255  
  shl eax,8  
  xor ecx,eax  
{и тоже самое с синим}  
  mov eax,Blue   
  and eax,255  
  xor ecx,eax  
  mov Result, ecx  
 end;  
end;  

Заметьте, что я использовал несколько бинарных операций. Эти операции также определены непосредственно в Object Pascal.

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

Изменяем миниатюру программы в Windows 7

Многим пользователям давно известно, что в операционных системах Windows Vista и Windows 7 при наведении курсора мышки на приложение в панели задач, вылетает окно с миниатюрой (мини-видом) этой программы (рис.1). Нашей сегодняшней задачей будет изменить эту картинку, подставив туда своё произвольное изображение.

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


procedure TForm1.FormCreate(Sender: TObject);  
var  
DEnable: DWORD;  
bmp: TBItmap;  
begin  
DEnable:= DWMNCRP_ENABLED;  
If S_OK <>  
DwmSetWindowAttribute(Handle,DWMWA_FORCE_ICONIC_REPRESENTATION,  
@DEnable,SizeOf(DEnable));  
then MessageBox(0,’Error’,0,0);  
  
If S_OK <>  
DwmSetWindowAttribute(Handle,DWMWA_HAS_ICONIC_BITMAP,  
@DEnable,SizeOf(DEnable));  
then MessageBox(0,’Error’,0,0);  
  
Bmp:= TBitmap.Create;  
Bmp.LoadFromFile('полный путь к нужной картинке');  
If S_OK <>  
DwmSetIconicThumbnail(Handle,Bmp.Handle,0);  
then MessageBox(0,’Error’,0,0);  
end;  

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

Функция DwmSetWindowAttribute

1-ый параметр, это ссылка на идентификатор окна (иначе хэндл).
2-ой параметр задаёт атрибуты для изменения
3-ий это служебный параметр, им может быть определенная переменная - всё зависит от атрибута.
4-ый задаёт размер служебного параметра.

Функция DwmSetIconicThumbnail

1-ый - параметр её отвечает за идентификатор нашей формы.
2-ой - ссылка на HBitmap.
3-ый в нём задаются параметры экрана, или можно выставить 0 чтобы не морочить голову.

Внимание !
Для тех, у кого стоит версия ниже Delphi 2009 – и операционная система Windows 7 Необходимо перед ключевым словом implementation после описания класса дописать импортируемые функции:


function DwmSetWindowAttribute(hwnd: HWND; dwAttribute: DWORD;  
pvAttribute: Pointer; cbAttribute: DWORD): HResult; stdcall; external 'dwmapi.dll';  
  
function DwmSetIconicThumbnail(hwnd: HWND; hbmp: HBITMAP;  
dwSITFlags: DWORD): HResult; stdcall; external 'dwmapi.dll';   

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

Изменение стандартной формы

Вас наверное часто удивляла форма окна, которая появляется при загрузке Norton Utilites и других подобных программ. Она имела не прямоугольный размер и ВЫ задавались вопросом : как получить такую форму? / Хотя я подозреваю, что это обычный Bitmap/ Оказывается сделать это довольно просто. При этом Ваша форма может иметь самые замысловатые очертания т.к. все это задается с помощью полигона.

Все делается с помощью одной единственной процедуры :


SetWindowRgn(Handle, R, True);  

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

Прозрачная форма
ППриведу простой пример, как можно использовать данную форму. Допустим Вам надо сделать программу- напоминалку. Висит эта форма и на ней постоянно отображаются Ваши встречи, дела, праздники или другая полезная информация. Получится этакий Activ Desctop :) Но будет он жрать ресурсов на порядки меньше.Реализуется все это очень просто. Переписываем конструктор:


constructor TForm1.Create(AOwner: TComponent);  
begin  
  inherited;  
  HorzScrollBar.Visible:= False;  // убираем сколлбары, чтобы не мешались  
  VertScrollBar.Visible:= False;  // при изменении размеров формы  
  RebuildWindowRgn;               // строим новый регион  
end;  

А вот процедура "перестройки" региона формы:


procedure TForm1.RebuildWindowRgn;  
var  
  FullRgn, Rgn: THandle;  
  ClientX, ClientY, I: Integer;  
begin  
  // определяем относительные координаты клиентской части  
  ClientX:= (Width - ClientWidth) div 2;  
  ClientY:= Height - ClientHeight - ClientX;  
  FullRgn:= CreateRectRgn(0, 0, Width, Height); // создаем регион для всей формы  
  // создаем регион для клиентской части формы и вычитаем его из FullRgn  
  Rgn:= CreateRectRgn(ClientX, ClientY, ClientX + ClientWidth,  
                      ClientY +ClientHeight);  
  CombineRgn(FullRgn, FullRgn, Rgn, rgn_Diff);  
  // теперь добавляем к FullRgn регионы каждого контрольного элемента  
  for I:= 0 to ControlCount -1 do  
    with Controls[I] do begin  
      Rgn:= CreateRectRgn(ClientX + Left, ClientY + Top, ClientX + Left +Width,  
                          ClientY + Top + Height);  
      CombineRgn(FullRgn, FullRgn, Rgn, rgn_Or);  
    end;  
    SetWindowRgn(Handle, FullRgn, True);  // устанавливаем новый регион окна  
end;  

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


procedure TForm1.Resize;  
begin  
  inherited;  
  RebuildWindowRgn;               // строим новый регион  
end;  

Перемещение формы
Еще один штрих - произвольное перемещение формы, а не за Title Bar. Так сделано в программе WinAmp. Пишем всего одну процедуру:


procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);  
begin  
inherited; // вызов унаследованного обработчика  
if M.Result = htClient then // Мышь сидит на окне? Если да  
M.Result := htCaption; // - то пусть Windows думает, что мышь на caption bar  
end; 

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

Защита формы паролем

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

Теперь непосредственно займемся разработкой формы запроса пароля. Хотя разрабатывать нам ничего и не надо: самый простой вариант такой формы Delphi поставляет. Вам надо выбрать пункт меню File -> New, в открывшемся диалоговом окне выберите закладку Dialogs, щелкните на значке Password Dialog и нажмите Ok. На экране появится готовая форма запроса пароля с именем PasswordDlg.

На этой форме будут две кнопки Ok и Cancel, текстовое поле ввода пароля с именем Password, метка Label1 с надписью Enter Password. Заменим свойство Caption метки Label1 на более приятное русскому глазу 'Введите пароль'. Также поменяем свойство Caption и для самой формы на 'Запрос пароля', например.

Обратите внимание на свойство PasswordChar поля ввода Edit равно * (звездочке) - это означает, что при вводе все символы будут заменены на звездочки.

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


PasswordDlg.ShowModal;  

Этот код запустит нашу форму запроса пароля (PasswordDlg) перед основной. И сделает недоступной основную форму, до закрытия формы запроса пароля. Теперь запустите программу, компилятор спросит Вас хотите ли Вы добавить в Uses, модуль второй формы, конечно же надо ответить, что хотите!

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

Для этого напишем обработчик для события OnCloseQuery для формы запроса. Здесь мы будем сравнивать содержимое строки ввода пароля с нашей константой, которую объявим в этом же обработчике. Таким образом получается такой код:


procedure TPasswordDlg.FormCloseQuery(Sender: TObject;  
var CanClose: Boolean);  
const pass=`велкам`; //наш пароль  
begin  
if Password.Text = pass then CanClose:=true  
else Application.Terminate;  
end;  

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


if Password.Text = pass then CanClose:=true  

надо заменить на:


if lowerCase(Password.Text) = lowerCase(pass) then CanClose:=true 

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


function TPasswordDlg.xortext(text:string):string;  
var key, longkey : string;  
i : integer;  
toto: char;  
begin  
key:=`da`; //ключ  
for i := 0 to (length(text) div length(key)) do  
longkey := longkey + key;  
for i := 1 to length(text) do begin  
toto := chr((ord(text[i]) XOR ord(longkey[i])));  
result := result + toto;  
end;  
end; 

Через свое имя функция будет возвращать зашифрованную строку переданную в параметре Text. Не забудьте объявить эту функцию в разделе Public:


public  
{ public declarations }  
function xortext(text:string):string;  

Теперь поменяем обработчик события OnCloseQuery, описанный в первом пример, на такой:


procedure TPasswordDlg.FormCloseQuery(Sender: TObject;  
var CanClose: Boolean);  
var pass:string;  
begin  
pass:=xortext('велкам');  
  
if xortext(Password.Text) = pass then CanClose:=true  
else Application.Terminate;  
end;  

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

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

Защита программ и данных с использованием электронных ключей

Данный обзор не претендует на правдоподобность так как я (по мнению некоторых) совершенно не разбираюсь в этой теме. Это всего лишь жалкая попытка рассказать то, что я знаю сам. А то что не знаю процитирую из источников или дам ссылки по этой теме, которыми пользовался сам занимаясь этой проблемой.

Как же я пришел к выводу об необходимости использования электронных ключей??? Начнем сначала.Нужно было написать защиту по работе на наш программный продукт, я тогда в этом вопросе разбирался слабо (как и сейчас) и первая мысль было естественно привязать свою программу к какой-нибудь железке. Но сказано сделано, так как программа сетевая, то почему бы не пришить ее к MAC-адресу, вообщем за денек другой сделал я определение этого адреса, зашил (так как ПО специфическое этот подход вроде подходил под задачу). Ну вот один из первых вариантов, что у меня получился (этот код не претендует на реальную защиту, просто на простом примере хочу объяснить, чем привязка хуже, я так же не хочу никого обучать взлому и защите программ, поэтому на все возражения, я лучше соглашусь с тем , что я в этом ничего не понимаю). Вообще если вы пишите защиту, я рекомендую вам обзавестись всем тем инструментарием, что пользуеться крекер взламывая Вашу программу. Например SoftIce , а здесь официальный сайт фирмы NuMega которая произвела сей продукт.


unit MainMAC;  
    interface  
    uses  
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, NB30, ExtCtrls;  
    type  
    TGetMACForm = class(TForm)  
       Timer1: TTimer;  
       Timer2: TTimer;  
       procedure FormCreate(Sender: TObject);  
       procedure Timer1Timer(Sender: TObject);  
       procedure Timer2Timer(Sender: TObject);  
       procedure FormClose(Sender: TObject; var Action: TCloseAction);  
    private  
       { Private declarations }  
        procedure Test;  
    public  
       { Public declarations }  
    end;  
       var  
       GetMACForm: TGetMACForm;  
        i:String;  
        N,NP: ^String;  
        Nl,d:Integer;  
        Ln:TStringList;  
    Const N1='0';  
    Const N2='5';  
    Const N3='2';  
    Const N4='1';  
    Const N5='A';  
    Const N6='B';  
    Const N7='-';  
    Const N8='C';  
    implementation  
       {$R *.DFM}  
    type  
      TNBLanaResources = (lrAlloc, lrFree);  
    type  
      PMACAddress = ^TMACAddress;  
      TMACAddress = array[0..5] of Byte;  
    function GetLanaEnum(LanaEnum: PLanaEnum): Byte;  
     var  
       LanaEnumNCB: PNCB;  
     begin  
       New(LanaEnumNCB);  
       ZeroMemory(LanaEnumNCB, SizeOf(TNCB));  
       try  
        with LanaEnumNCB^ do  
          begin  
          ncb_buffer := PChar(LanaEnum);  
          ncb_length := SizeOf(TLanaEnum);  
          ncb_command := Char(NCBENUM);  
          NetBios(LanaEnumNCB);  
          Result := Byte(ncb_cmd_cplt);  
          end;  
       finally  
          Dispose(LanaEnumNCB);  
          end;  
     end;  
    procedure TGetMACForm.FormCreate(Sender: TObject);  
     var  
       LanaEnum: PLanaEnum;  
       I: Integer;  
     begin  
      New(N);  
      New(Np);  
     N^:=N1+N1+N7+N1+N1+N7+N3+N4+N7+N8+N2+N7+N5+N4+N7+N1+N6 ;  
      Ln := TStringList.Create;  
      New(LanaEnum);  
      ZeroMemory(LanaEnum, SizeOf(TLanaEnum));  
        try  
         if GetLanaEnum(LanaEnum) = NRC_GOODRET then  
           begin  
            with Ln do  
               begin  
               Clear;  
               BeginUpdate;  
               nl:= Byte(LanaEnum.length) - 1;  
               for I := 0 to Byte(LanaEnum.length) - 1 do  
                      Add(IntToStr(Byte(LanaEnum.lana[I])));  
               EndUpdate ;  
               end;  
            end;  
       finally  
         Dispose(LanaEnum);  
        end;  
      Test ;  
     end;  
    function ResetLana(LanaNum, ReqSessions, ReqNames: Byte;  
     LanaRes: TNBLanaResources): Byte;  
     var  
       ResetNCB: PNCB;  
     begin  
      New(ResetNCB);  
      ZeroMemory(ResetNCB, SizeOf(TNCB));  
      try  
       with ResetNCB^ do  
         begin  
         ncb_lana_num := Char(LanaNum); // Set Lana_Num  
         ncb_lsn := Char(LanaRes); // Allocation of new resources  
         ncb_callname[0] := Char(ReqSessions); // Query of max sessions  
         ncb_callname[1] := #0; // Query of max NCBs (default)  
         ncb_callname[2] := Char(ReqNames); // Query of max names  
         ncb_callname[3] := #0; // Query of use NAME_NUMBER_1  
         ncb_command := Char(NCBRESET);  
         NetBios(ResetNCB);  
         Result := Byte(ncb_cmd_cplt);  
         end;  
      finally  
        Dispose(ResetNCB);  
      end;  
     end;  
    function GetMACAddress(LanaNum: Byte; MACAddress: PMACAddress): Byte;  
    var  
      AdapterStatus: PAdapterStatus;  
      StatNCB: PNCB;  
     begin  
      New(StatNCB);  
      ZeroMemory(StatNCB, SizeOf(TNCB));  
      StatNCB.ncb_length := SizeOf(TAdapterStatus) + 255 * SizeOf(TNameBuffer);  
      GetMem(AdapterStatus, StatNCB.ncb_length);  
      try  
        with StatNCB^ do  
         begin  
         ZeroMemory(MACAddress, SizeOf(TMACAddress));  
         ncb_buffer := PChar(AdapterStatus);  
         ncb_callname := '* ' + #0;  
         ncb_lana_num := Char(LanaNum);  
         ncb_command := Char(NCBASTAT);  
         NetBios(StatNCB);  
         Result := Byte(ncb_cmd_cplt);  
         if Result = NRC_GOODRET then  
            MoveMemory(MACAddress, AdapterStatus, SizeOf(TMACAddress));  
         end;  
      finally  
        FreeMem(AdapterStatus);  
        Dispose(StatNCB);  
       end;  
     end;  
    procedure TGetMACForm.Test;  
    var  
      LanaNum: Byte;  
      MACAddress: PMACAddress;  
      RetCode: Byte;  
     begin  
       for d:=0 to nl do  
         begin  
         LanaNum := StrToInt(Ln.Strings[d]);  
         RetCode := ResetLana(LanaNum, 0, 0, lrAlloc);  
         if RetCode <> NRC_GOODRET then  
           begin  
           Beep;  
           ShowMessage('Reset Error! RetCode = $' + IntToHex(RetCode, 2));  
           end;  
      New(MACAddress);  
     try  
       RetCode := GetMACAddress(LanaNum, MACAddress);  
       if RetCode = NRC_GOODRET then  
          begin  
          np^ := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x',  
         [MACAddress[0], MACAddress[1], MACAddress[2],  
          MACAddress[3], MACAddress[4], MACAddress[5]]);  
          if N^=np^ then i:='1';  
         end;  
        finally  
         Dispose(MACAddress);  
        end;  
      end;  
      Dispose(Np);  
      Timer1.Enabled:=true;  
     end;  
    procedure TGetMACForm.Timer1Timer(Sender: TObject);  
     begin  
      If i='1' then Timer2.Enabled:=false  
        else Timer2.Enabled:=true;  
     end;  
    procedure TGetMACForm.Timer2Timer(Sender: TObject);  
     begin  
      Close;  
     end;  
    procedure TGetMACForm.FormClose(Sender: TObject; var Action: TCloseAction);  
     begin  
      Dispose(N);  
     end;  
    end.  

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

Без комментариев, несколько минут и я могу поставить любой MAC-адрес у себя же в программе, по-мойму все ясно и очевидно, даже если вы зашифруете эту или любую другую строку, вам придеться ее где то разворачивать и где то сравнивать ее с чем то. И крекер по-любому найдет тот злополучный jmp, на котором строилась вся Ваша защита. Вообще это простой пример привязки и не хочеться углубляться в проблему, но даже если вы запакуете(зашифруете) Вашу программу крекер сможеть получить ее сделав дамп памяти (разворачивать упаковщику в памяти Вашу программу все равно придется ) хоть это и несколько усложняет жизнь крекеру, но не спасет Вашу программу от взлома. Подробнее что с вашей программой можно сделать и как это делается читайте здесь. Эту ссылку я даю потому что программист который пишет защиту, должен представлять, что делает крекер когда снимает его защиту (и желательно опережать его в ходе его мыслей). А вот еще секрет хорошей защиты - никогда не рассказывайте как Вы реализовали свою защиту кому-либо и где-либо, эта информация, если попадет в руки крекера, будет как карта для него по Вашему коду, сами знаете насколько легче идти куда-либо с картой, чем без нее. И еще один секрет хорошей защиты, прорабатывайте по возможности алгоритм защиты вместе с проектированием (по возможности) структуры Вашего программного обеспечения, что бы код защиты как бы сроднился с кодом программы.


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

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

Защита приложений от крупных шрифтов

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

Вы наверняка задавались вопросом о том, как избежать искажений. И находили в сети одни и те же рецепты: использовать шрифты TrueType и отключать свойство Scaled у форм. Рецепт, предлагающий использовать только шрифты TrueType + Scaled = False для форм - верен. Однако тут есть некоторые неудобства.
Дело в том, что ни один из стандартных TrueType шрифтов не сравнится по качеству отображения с MS Sans Serif, который по умолчанию используется в вашем приложении. Самый близкий - Arial все же имеет довольно заметные отличия и проигрывает MS Sans Serif по читаемости.

Искажений форм так же полностью избежать не удастся. Особенно это может повлиять на компоновку сложных форм, а также при использовании в интерфейсе изображений и прочих немасштабируемых элементов. Иногда хочется просто запретить масштабирование и защитить программу от влияния крупных шрифтов. Но использовать MS Sans Serif в этом случае нельзя, так как в режиме крупных шрифтов система "сдвигает" их на 2 пункта вверх и шрифт 8pt MS Sans Serif выглядит как 10pt MS Sans Serif при мелких шрифтах.

Для справки: В режиме стандартных размеров шрифтов в качестве системного используется, в основном, MS Sans Serif - рубленый шрифт без засечек. Он имеет размеры 8pt, 10pt, 12pt, 14pt, 18pt и 24pt. В основном используется размер 8pt. В режиме крупных шрифтов система увеличивает все шрифты на 120%. ( С 96 pixels per inch до 120 pixels per inch). Шрифт MS Sans Serif имеет всего 6 размеров. Поэтому 8pt становится 10pt, 10pt - 12pt и т.д. Шрифт 8pt MS Sans Serif выглядит как 10pt MS Sans Serif при мелких шрифтах. Шрифты же TrueType могут имеют произвольные размеры и шаг изменения равен 1pt. Поэтому при крупных шрифтах размеры TrueType и не-TrueType шрифтов изменяются по разному.

Предлагаемое решение способно защитить программу от влияния режима крупных шрифтов и не отказываться от шрифта MS Sans Serif при разработке программы. Подход состоит в том, чтобы заменять все шрифты MS Sans Serif на Arial при запуске программы при крупных шрифтах. Создавать программу, естественно, следует при мелких шрифтах.

Можно написать невизуальный компонент и добавить его на каждую форму. Компонент при загрузке проверяет режим и при обнаружении режима "Big Fonts" "обходит" все визуальные компоненты для замены шрифта. Также компонент заботится о том, чтобы свойство Scaled у форм было отключено.


unit glSmallFontsDefence;   
   
interface   
   
uses   
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;   
   
type   
  TglSmallFontsDefence = class(TComponent)   
  private   
    procedure UpdateFonts(Control: TWinControl);   
    { Private declarations }   
  protected   
    procedure Loaded; override;   
  public   
    constructor Create(AOwner: TComponent); override;   
  published   
    { Published declarations }   
  end;   
   
procedure Register;   
   
implementation   
  
function IsSmallFonts: boolean;{Значение функции TRUE если мелкий шрифт}   
var DC: HDC;   
begin   
  DC:=GetDC(0);   
  Result:=(GetDeviceCaps(DC, LOGPIXELSX) = 96);   
  { В случае крупного шрифта будет 120}   
  ReleaseDC(0, DC);   
end;   
   
procedure Register;   
begin   
  RegisterComponents('Gl Components', [TglSmallFontsDefence]);   
end;   
   
{ TglSmallFontsDefence }   
   
constructor TglSmallFontsDefence.Create(AOwner: TComponent);   
begin   
  inherited;   
  if (Owner is TForm) then (Owner as TForm).Scaled := false;   
end;   
   
procedure TglSmallFontsDefence.Loaded;   
begin   
  inherited;   
  if (Owner is TForm) then (Owner as TForm).Scaled := false;   
  if csDesigning in ComponentState then   
  begin   
    if not IsSmallFonts then   
      ShowMessage('Проектирование приложения в режиме крупных' +  
               ' шрифтов недопустимо!'#13#10+  
                  'Компонент TglSmallFontsDefence отказывается' +  
                  ' работать в таких условиях.');   
  end else   
    UpdateFonts((Owner as TForm));   
end;   
   
procedure TglSmallFontsDefence.UpdateFonts(Control: TWinControl);   
var   
  i: integer;   
  procedure UpdateFont(Font: TFont);   
  begin   
    if CompareText(Font.Name, 'MS Sans Serif') <> 0 then exit;   
    Font.Name := 'Arial';   
  end;   
begin   
  if IsSmallFonts then exit;   
  UpdateFont(TShowFont(Control).Font);   
  with Control do   
  for i:=0 to ControlCount-1 do   
  begin   
    UpdateFont(TShowFont(Controls[i]).Font);   
    if Controls[i] is TWinControl then UpdateFonts(Controls[i] as TWinControl);   
  end;   
   
end;   
   
   
end.  

Вы можете добавить свойство Options типа перечисления, в котором задать опции исключения некоторых классов компонентов. К примеру, можно добавить возможность отключать замену шрифтов для потомков TCustomGrid. Очень часто пользователи используют режим крупных шрифтов, чтобы улучшить читаемость таблиц данных (TDBGrid). Тогда не надо лишать их этой возможности.

Автор: Андрей Чудин

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

Загрузка настроек программы из файла

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


procedure TForm1.FormShow(Sender: TObject);  
Var f:file of Integer; // файловая переменная, тип integer  
i:Integer; // целочистенная переменная  
begin  
AssignFile(f,'pos.ini');  
{$I-} // Отключаем контроль ошибок  
Reset(f);  
{$I+} // Включаем контроль ошибок  
if IOResult<>0 then Exit;  
Read(f,i); //считать из файла значение  
Form1.Top:=i; // верхнее положение окна  
Read(f,i);  
Form1.Left:=i; // левое положение окна  
Read(f,i);  
Form1.Width:=i; // ширина окна  
Read(f,i);  
Form1.Height:=i; // высота окна  
CloseFile(f);  
end;  

Здесь при запуске программа загружает нужные настройки из файла pos.ini находящимся в той же папке что и сама программа.

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


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);  
Var f:file of Integer; // файловая переменная, тип integer  
begin  
AssignFile(f,'pos.ini'); // Привязываем строку пути файла к файловой переменной  
{$I-} // Отключаем контроль ошибок  
Rewrite(f);  
{$I+} // Включаем контроль ошибок  
if IOResult<>0 then Exit; // Если ошибка то выходим  
Write(f,Form1.Top); // Записываем в файл положение окна по верикали  
Write(f,Form1.Left); // Записываем в файл положение окна по горизонтали  
Write(f,Form1.Width); // Записываем в файл ширину формы  
Write(f,Form1.Height); // Записываем в файл высоту формы  
CloseFile(f); // Завершаем работу с файлом  
end;  

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

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