Dialog Wizard в Delphi

Задался вопросом создания "мастера" для чего нибудь.

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

Страница приветствия

Рабочая страница

Итак, что мы делаем. На форму кидаем TopPanel (TPanel), pcWizard (TPageControl), Bevel1 (TBevel) и ActionList. Для начала разберемся с верхней панелью. Я поместил там lblCaption и lblHint (TLabel), а также картинку.
В pcWizard создаем 3 закладки: tsWelcome, tsFinish, tsPage1. Первые две будут очень похожие, даже одинаковые, только текст будет разный. На них помещает текст приветствия и какую-нибудь подходящую картинку. Картинка желательно большего размера по высоте.
В ActionList создаем 3 события (Action): acNext, acBack, acCancelDone.
В TBevel размещаем 3 кнопки: "Назад", "Далее", "Отмена". И присваиваем им соответствующие события из ActionList.
На странице tsPage1 для демонстрации разместим один CheckBox. Переход далее будет осуществляться только если он отмечен.

Ну вот и все с дизайном. Переходим к коду.

При старте нашей формы нам нужно убрать шапки с закладок. В FormCreate напишем.

type
  TDialogWizard = class(TForm)
   .....
  public  
    procedure CheckWhenPageActive;
...
 end;

procedure TDialogWizard.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to pcWizard.PageCount - 1 do
    pcWizard.Pages[i].TabVisible := False;
  pcWizard.ActivePage := tsWelcome;
  CheckWhenPageActive;
end;

Здесь мы скрыли все заголовки со страниц, установили стартовую и запустили процедуру CheckWhenPageActive. Она отвечает за отображение верхней панели, текста на ней и отображение кнопок навигации. Вот ее код:

var
  DialogWizard: TDialogWizard;
  PNextPage, PPrevPage: ^TTabSheet;

.....

procedure TDialogWizard.CheckWhenPageActive;
var
  PPage : ^TTabSheet;
begin
  PPage := @(pcWizard.ActivePage);
  if PPage^ = tsWelcome then
    begin
      TopPanel.Visible := false;
      PNextPage := @tsPage1;
      PPrevPage := nil;
    end;

  if PPage^ = tsFinish then
    begin
      TopPanel.Visible := false;
      PNextPage := nil;
      PPrevPage := nil;
      acCancelDone.Caption := 'Готово';
    end;

  if PPage^ = tsPage1 then
    begin
      TopPanel.Visible := true;
      PNextPage := @tsFinish;
      PPrevPage := nil;
      lblCaption.Caption := '';
      lblHint.Caption := '';
    end;

  acNext.Visible := PNextPage <> nil;
  acBack.Visible := PPrevPage <> nil;
end;

В процедуре проверяем какая страница активна. Для каждой страницы нам необходимо указать предыдущую страницу и следующую (указатели PNextPage, PPrevPage: ^TTabSheet). Можно было бы и просто менять с помощью SelectNextPage, но тогда их надо в дизайнере отсортировать по очередности. А если надо пропустить? Я решил указывать это для каждой страницы. Если какая-либо ссылка не указана, то и соответствующая кнопка не будет видна. Например: tsWelcome - видна кнопка далее, следующая страница tsPage1. А у tsPage1, появилась возможность отображать заголовок и комментарий к странице. TopPanel.Visible := true - говорит, о том, что верхняя панель будет показана.

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

procedure TDialogWizard.acNextExecute(Sender: TObject);
begin
  if AllowChangePage then
   begin
    pcWizard.ActivePage := PNextPage^;
    CheckWhenPageActive;
   end;
end;

Функция AllowChangePage проверяет, можно ли переходить к следующей странице. Если она принимает значение TRUE, то переходим к следующей странице. Вот ее код:

type
  TDialogWizard = class(TForm)
   .....
  private
    function AllowChangePage: boolean;
    .....
end;

function TDialogWizard.AllowChangePage: boolean;
var
  PPage : ^TTabSheet;
begin
  result := true;
  PPage := @(pcWizard.ActivePage);

   if PPage^ = tsPage1 then
    begin
      result := CheckBox1.Checked;
    end;
end;

Помните на tsPage1 мы кидали CheckBox. Так вот эта функция проверяет отмечен он или нет, и либо разрешает, либо запрещает переход.

С переходом назад проще. Просто переходим назад.

procedure TDialogWizard.acBackExecute(Sender: TObject);
begin
  pcWizard.ActivePage := PPrevPage^;
  CheckWhenPageActive;
end;

Осталась кнопка "Отмена/Готово". Тут тоже все просто.

procedure TDialogWizard.acCancelDoneExecute(Sender: TObject);
begin
  if pcWizard.ActivePage <> tsFinish then
    close
  else
    begin
      // Тут что-то делаем.
      close;
    end;
end;

Если страница не последняя (tsFinish), то закрываем мастер, а нет можем выполнить отмену произведенных операций к примеру и закрыть.

Ну вот и все. Подведет итог.
Мы имеем 2 процедуры в которых отрабатывается страница:
CheckWhenPageActive - Определяем что показывать, а что нет. + Навигация.
AllowChangePage - Делаем проверку на странице.

Что-то делать в мастере можно по ходу выполнения в процедуре AllowChangePage, либо создать еще страницу, ну скажем tsProgress и делать все на ней. Но опять же в процедуре AllowChangePage. Можно организовать отмену каких-либо операций в процедуре acCancelDoneExecute.

Ну что же, удачи.

Исходник проекта DialogWizard

Сохранение размера и позиции формы в Delphi

Часто в приложении требуется сохранить размер и положение окна (формы). Встроенной технологии в Delphi нет. В интернете можно найти различные способы хранения как в INI так и в реестре. Я предлагаю другой вариант. Использовать TPersistant.
Для удобства я поместил все в DLL.


library swpas;

{  SWPAS - Save Windows Position And Size

   Библиотека для сохранения размера и положения формы.
   24.09.2014  Кутовой Максим

   После создания формы загружаем ее размеры и положение из файла. Если его нет,
   то размеры и положение будут как при разработке приложения. После закрытия
   формы сохраняем ее размер и положения в файл. Если не указать имя файла, то
   все будет сохранено в файл <ИМЯ_ФОРМЫ>.frm

     Формат вызова процедур в программе
     procedure LoadFormPositionAndSize(AForm: TForm; APath : string = ''); external 'swpas.dll';
     procedure SaveFormPositionAndSize(AForm: TForm; APath : string = ''); external 'swpas.dll';

     procedure LFPAS(AForm: TForm; APath : string = ''); external 'swpas.dll';
     procedure SFPAS(AForm: TForm; APath : string = ''); external 'swpas.dll';


     Использование в программе:

     procedure TForm1.Button1Click(Sender: TObject);
     var
       NewForm : TForm;
     begin
      NewForm := TForm2.Create(self);
      LFPAS(NewForm);
      NewForm.ShowModal;
      SFPAS(NewForm);
      FreeAndNil(NewForm);
     end;
   }


uses
  System.SysUtils,
  System.Classes,
  VCL.Forms;

{$R *.res}

{
 ****
 ****  КЛАСС для сохранения свойств формы
 ****
}

type
  TSavedForm = class(TPersistent)
  private

    FHeight: Integer;
    FLeft: Integer;
    FTop: Integer;
    FWidth: Integer;

    {Установка свойств}
    procedure SetHeight(const Value: integer);
    procedure SetLeft(const Value: Integer);
    procedure SetTop(const Value: Integer);
    procedure SetWidth(const Value: integer);

    {Получение свойств}
    function GetHeight: integer;
    function GetLeft: Integer;
    function GetTop: Integer;
    function GetWidth: integer;
  public
    {Конструктор}
    constructor Create;

  published
    Property Left: Integer read GetLeft write SetLeft;
    property Top: Integer read GetTop write SetTop;
    property Width: integer read GetWidth write SetWidth;
    property Height: integer read GetHeight write SetHeight;

  end;

{ AForm }

constructor TSavedForm.Create;
begin
  inherited;
end;

function TSavedForm.GetHeight: integer;
begin
  result := FHeight;
end;

function TSavedForm.GetLeft: Integer;
begin
  result := FLeft;
end;

function TSavedForm.GetTop: Integer;
begin
  result := FTop
end;

function TSavedForm.GetWidth: integer;
begin
  result := FWidth;
end;

procedure TSavedForm.SetHeight(const Value: integer);
begin
  FHeight := Value;
end;

procedure TSavedForm.SetLeft(const Value: Integer);
begin
  FLeft := Value;
end;

procedure TSavedForm.SetTop(const Value: Integer);
begin
  FTop := Value;
end;

procedure TSavedForm.SetWidth(const Value: integer);
begin
  FWidth := Value;
end;


{
  ***
  ***  Процедуры для сохранения объекта  в файл
  ***  Можно вынести в отдельный модуль или библиотеку.
  ***
}

type
  TObjWriter = class(TWriter)
  end;
  TObjReader = class(TReader)
  end;


procedure WriteObj(obj: TPersistent; st: TStream);
begin
  with TObjWriter.Create(st, 64) do
  begin
    WriteProperties(obj);
    FlushBuffer; Free;
  end;
end;


procedure ReadObj(obj: TPersistent; st: TStream);
begin
  with TObjReader.Create(st, 1) do
  begin
    while st.Position < st.Size do
    try ReadProperty(obj); except Continue; end;
    Free;
  end;
end;


procedure SaveObjToFile(obj: TPersistent; FileName: string);
var fs: TFileStream;
begin
  try
    fs := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite);
    try
      WriteObj(obj, fs);
    finally
      fs.Free;
    end;
  except end;
end;


procedure LoadObjFromFile(obj: TPersistent; FileName: string);
var fs: TFileStream;
begin
  if FileExists(FileName) then try
    fs := TFileStream.Create(FileName, fmShareDenyWrite);
    try
      ReadObj(obj, fs);
    finally
      fs.Free;
    end;
  except end;
end;



{
 ***
 ***  Процедуры для работы
 ***
}


// Загрузка позиции и размеров формы
procedure LoadFormPositionAndSize(AForm: TForm; APath: string);
var
  F : TSavedForm;
  fn : string;
begin
  F:= TSavedForm.Create;
  if APath = '' then
    fn := ExtractFilePath(ParamStr(0)) + AForm.Name + '.frm'
  else
    fn := APAth;
  if FileExists(fn) then begin
     LoadObjFromFile(F, fn);
     AForm.Height := F.Height;
     AForm.Width := F.Width;
     AForm.Top := F.Top;
     AForm.Left := F.Left;
  end;
  FreeAndNil(F);
end;

// Сохранение позиции и размеров формы
procedure SaveFormPositionAndSize(AForm: TForm; AFileName: string);
var
  F : TSavedForm;
  fn : string;
begin
  F := TSavedForm.Create;
  F.Height :=  AForm.Height;
  F.Width :=  AForm.Width;
  F.Top :=  AForm.Top;
  F.Left :=  AForm.Left;
  if AFileName =  '' then
    fn := ExtractFilePath(ParamStr(0)) + AForm.Name + '.frm'
  else
     fn := AFileName;
  SaveObjToFile(F, fn);
  FreeAndNil(F);
end;

// Теже процедуры но с сокращенным именем.
procedure SFPAS(AForm: TForm; AFileName: string);
begin
  SaveFormPositionAndSize(AForm, AFileName);
end;

procedure LFPAS(AForm: TForm; AFileName: string);
begin
  LoadFormPositionAndSize(AForm, AFileName);
end;



exports
   SaveFormPositionAndSize, LoadFormPositionAndSize, SFPAS, LFPAS;

begin
end.

Готовую DLL можно взять здесь: swpas.dll

Раскраска элементов TreeView

Легко: обрабатывай OnCustomDrawItem, в котором и назначай цвет:

Код Delphi
1 2 3 4 5 6 7 8 9 10 procedure TForm1.TreeView1CustomDrawItem(Sender: TCustomTreeView;   Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean); begin    case Integer(Node.Data) of       1 : Sender.Canvas.Font.Color := clRed;       2 : Sender.Canvas.Font.Color := clBlue;       else          Sender.Canvas.Font.Color:= clBlack;    end; end;

, и добавляй свои элементы в дерево. Цвет будет зависеть от значения поля Data:

Код Delphi

1 2 3 4 5 6 7 8 9 10 11 procedure TForm1.Button1Click(Sender: TObject); begin    with TreeView1.Items.AddChild(nil, 'First red') do       Data := Pointer(1);    with TreeView1.Items.AddChild(nil, 'Second red') do       Data := Pointer(1);    with TreeView1.Items.AddChild(nil, 'First blue') do       Data := Pointer(2);    with TreeView1.Items.AddChild(nil, 'Black') do       Data := Pointer(0); end;

http://www.cyberforum.ru/delphi-beginners/thread728793.html

Автозагрузка приложения при старте Windows

Пишем библиотеку:

library autorun;

uses
  Windows,
  Registry;

{$R *.res}


procedure RunOnWinStart(Flag:boolean; NameParam, Path:String);
var Reg:TRegistry;
begin
  if Flag then
  begin
     Reg := TRegistry.Create;
     Reg.RootKey := HKEY_CURRENT_USER;
     Reg.OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Run', false);
     Reg.WriteString(NameParam, Path);
     Reg.Free;
  end
  else
  begin
     Reg := TRegistry.Create;
     Reg.RootKey := HKEY_CURRENT_USER;
     Reg.OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Run',false);
     Reg.DeleteValue(NameParam);
     Reg.Free;
  end;
end;

exports
  RunOnWinStart;

begin
end.

Далее в программе делаем ее динамическое выполнение:

procedure SetRunOnStart(const Value: boolean);

var

  LibHandle:Integer;

  Fc_AutoRun: procedure(Flag:boolean; NameParam, Path:String);

begin

  FRunOnStart := Value;

    LibHandle := LoadLibrary('autorun.dll');

      if LibHandle >=32 then

        begin

          @Fc_AutoRun := GetProcAddress(LibHandle, 'RunOnWinStart');

          Fc_autoRun(Value, Application.title, paramstr(0));

        end;

    FreeLibrary(LibHandle);

end;

Передача данных в DLL (Статическая загрузка DLL)

Код:

library Project2;

uses
  Windows,
  SysUtils;

type
  TCallbackProc = function: Integer; stdcall;

var
  GetValue: TCallbackProc;

procedure Init(const ACallback: TCallbackProc); stdcall;
begin
  GetValue := ACallback;
end;

function DoSomething: Integer; stdcall;
begin
  Result := GetValue * 2;
end;

exports
  DoSomething,
  Init;

end.





Код:

unit Unit1;

...

type
  TCallbackProc = function: Integer; stdcall;

procedure Init(const ACallback: TCallbackProc); stdcall; external 'Project2.dll';
function DoSomething: Integer; stdcall; external 'Project2.dll';

...

function Callback: Integer; stdcall;
begin
  Result := Form1.Tag;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Init(Callback);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Tag := 5;
  Caption := IntToStr(DoSomething); // выведет '10'
end;

Передача данных в DLL (Динамическая загрузка DLL)

Рыдаю. Просто рыдаю.

Волшебное слово - Callback (a.k.a. функция обратного вызова).

Код:

library Project2;

uses
  Windows,
  SysUtils;

type
  TCallbackProc = function: Integer; stdcall;

var
  GetValue: TCallbackProc;

procedure Init(const ACallback: TCallbackProc); stdcall;
begin
  GetValue := ACallback;
end;

function DoSomething: Integer; stdcall;
begin
  Result := GetValue * 2;
end;

exports
  DoSomething,
  Init;

end.

Код:

unit Unit1;

...

function Callback: Integer; stdcall;
begin
  Result := Form1.Tag;
end;

procedure TForm1.Button1Click(Sender: TObject);
type
  TCallbackProc = function: Integer; stdcall;
  TInitProc = procedure(const ACallback: TCallbackProc); stdcall;
  TDoSomethingProc = function: Integer; stdcall;
var
  Lib: HMODULE;
  Init: TInitProc;
  DoSomething: TDoSomethingProc;
begin
  Lib := LoadLibrary('Project2.dll');  
  Win32Check(Lib <> 0);
  try
    Init := GetProcAddress(Lib, 'Init');
    Win32Check(Assigned(Init));
    Init(Callback);
    DoSomething := GetProcAddress(Lib, 'DoSomething');
    Win32Check(Assigned(DoSomething));

    Tag := 5;
    Caption := IntToStr(DoSomething); // выведет '10'
  finally
    FreeLibrary(Lib);
  end;
end;

Динамическая загрузка функции из DLL

{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

var      Form1: TForm1;      GetSimpleText: function(LangRus: Boolean): PChar;      LibHandle: THandle;procedure Button1Click(Sender: TObject);begin  {"Чистим" адрес функции от "грязи"}  @GetSimpleText := nil;  {Пытаемся загрузить библиотеку}  LibHandle := LoadLibrary('MYDLL.DLL');  {Если все OK}  if LibHandle >= 32 then begin    {...то пытаемся получить адрес функции в библиотеке}    @GetSimpleText := GetProcAddress(LibHandle,'GetSimpleText');    {Если и здесь все OK}    if @GetSimpleText <> nil then      {...то вызываем эту функцию и показываем результат}      ShowMessage(StrPas(GetSimpleText(True)));  end;  {И не забываем освободить память и выгрузить DLL}  FreeLibrary(LibHandle);end;

ПРИМЕЧАНИЕ: Следует воздерживаться от использования типа string в библиотечных функциях, т.к. при его использовании существуют проблемы с "разделением памяти". Подробней об этом можно прочитать (правда, на английском) в тексте пустого проекта DLL, который создает Delphi (File -> New -> DLL). Так что лучше используйте PChar, а затем при необходимости конвертируйте его в string функцией StrPas.


Еще вариант

procedure TOptions.SetRunOnStart(const Value: boolean);
var
  LibHandle:Integer;
  Fc_AutoRun: procedure(Flag:boolean; NameParam, Path:String);

begin
  FRunOnStart := Value;
    LibHandle := LoadLibrary('autorun.dll');
      if LibHandle >=32 then
        begin
          @Fc_AutoRun := GetProcAddress(LibHandle, 'RunOnWinStart');
          Fc_autoRun(Value, Application.title, paramstr(0));
        end;
    FreeLibrary(LibHandle);

end;

Версия файла. DLL

Библиотека для определения версии файла


library fileversion;
uses
  System.SysUtils,
  System.Classes,
  Winapi.Windows;
{$R *.res}
function GetFileVersionToStr(FileName: string): string; stdcall;
var
  Size, Handle: DWORD;
  Buffer: TBytes;
  FixedPtr: PVSFixedFileInfo;
begin
  Size := GetFileVersionInfoSize(PChar(FileName), Handle);
  if Size = 0 then
    RaiseLastOSError;
  SetLength(Buffer, Size);
  if not GetFileVersionInfo(PChar(FileName), Handle, Size, Buffer) then
    RaiseLastOSError;
  if not VerQueryValue(Buffer, '\', Pointer(FixedPtr), Size) then
    RaiseLastOSError;
  Result := Format('%d.%d.%d.%d',
    [LongRec(FixedPtr.dwFileVersionMS).Hi,  //major
     LongRec(FixedPtr.dwFileVersionMS).Lo,  //minor
     LongRec(FixedPtr.dwFileVersionLS).Hi,  //release
     LongRec(FixedPtr.dwFileVersionLS).Lo]) //build
end;
exports
   GetFileVersionToStr;
begin
end.

Версия своей программы

Вариант №1

Предлагаю вариант кода, позволяющий быстро и просто узнать версию своей программы.
Обычно используют общий код, для извлечения версии, пробега по полям и т.д... Но, если нужно узнать номер версии своей программы, то всё гораздо проще. Версия программы хранится в ресурсах. VERSIONINFO своей программы можно извлечь из ресурса с именем '#1'. В данном ресурсе версия программы всегда хранится по смещению 49. Вот пример кода, который достаёт версию из себя:

function GetMyVersion:string;
type
  TVerInfo=packed record
    Nevazhno: array[0..47] of byte; // ненужные нам 48 байт
    Minor,Major,Build,Release: word; // а тут версия
  end;
var
  s:TResourceStream;
  v:TVerInfo;
begin
  result:='';
  try
    s:=TResourceStream.Create(HInstance,'#1',RT_VERSION); // достаём ресурс
    if s.Size>0 then begin
      s.Read(v,SizeOf(v)); // читаем нужные нам байты
      result:=IntToStr(v.Major)+'.'+IntToStr(v.Minor)+'.'+ // вот и версия...
              IntToStr(v.Release)+'.'+IntToStr(v.Build);
    end;
  s.Free;
  except; end;
end;

Вариант №2





function MyVersion(Files: string): string;
var
  Buffer: string;
  fInfoSize: DWORD;





function InitVersion: boolean;
var
    FilenamePointer: PChar;
begin
    Result := True;
    FilenamePointer := PChar(Files);
    fInfoSize := GetFileVersionInfoSize(FilenamePointer, fInfoSize);
    if fInfoSize > 0 then
    begin
      SetLength(Buffer, fInfoSize);
      if not GetFileVersionInfo(FilenamePointer, 0, fInfoSize, PChar(Buffer))
        then
      begin
        Result := False;
      end;
    end; //if
end; //InitVersion



function GetVersion(whatToGet: string): string;
var
    tmpVersion: string;
    Len, Len2: DWORD;
    Value: PChar;
    temp: PLongInt;
    tempStr: string;

begin
    Result := '';
    if fInfoSize > 0 then
    begin
      SetLength(tmpVersion, 200);
      Value := @tmpVersion;
      VerQueryValue(PChar(Buffer), '\VarFileInfo\Translation', Pointer(temp),
        Len2);
      tempStr := Format('%s%.4x%.4x\%s%s', ['\StringFileInfo\', LoWord(temp^),
        HiWord(temp^), whattoget, #0]);
      if VerQueryValue(PChar(Buffer), PChar(tempStr), Pointer(Value), Len) then
        Result := Value;
    end; // if
end; //getversion




begin
  Buffer := '';
  try
    InitVersion;
    result := GetVersion('FileVersion');
  except
    Result := '';
  end;
end;

Вариант №3

function GetFileVersionToStr(FileName: string): string; stdcall;
var

  Size, Handle: DWORD;
  Buffer: TBytes;
  FixedPtr: PVSFixedFileInfo;
begin
  Size := GetFileVersionInfoSize(PChar(FileName), Handle);
  if Size = 0 then
    RaiseLastOSError;
  SetLength(Buffer, Size);
  if not GetFileVersionInfo(PChar(FileName), Handle, Size, Buffer) then
    RaiseLastOSError;
  if not VerQueryValue(Buffer, '\', Pointer(FixedPtr), Size) then
    RaiseLastOSError;
  Result := Format('%d.%d.%d.%d',
    [LongRec(FixedPtr.dwFileVersionMS).Hi,  //major
     LongRec(FixedPtr.dwFileVersionMS).Lo,  //minor
     LongRec(FixedPtr.dwFileVersionLS).Hi,  //release
     LongRec(FixedPtr.dwFileVersionLS).Lo]) //build
end;