FAQ VCL
Разное

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как открыть CHM справку на нужной странице?

// Способ первый (для Delphi 2006 и выше)
procedure TForm1.Button1Click(Sender: TObject);
begin
  HtmlHelp(0, 'mk:@MSITStore:file.chm::/path/file.html', HH_DISPLAY_TOPIC, 0);
  // или
  // HtmlHelp(0, 'file.chm::/path/file.html', HH_DISPLAY_TOPIC, 0);
  //   file.chm - файл справки
  //   /path/file.html - путь к файлу внутри справки
  //   Еисл в качестве первого параметра вместо 0 передать Handle,
  //   то справка будет отображаться поверх указанного окна.
  //   В любом случае справка будет закрываться вместе с приложением.
end;

// Способ второй (для всех версий Delphi)
uses
  {...,} ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute(Handle, 'open', 'C:\WINDOWS\hh.exe', 'file.chm::/path/file.html', nil, SW_SHOWNORMAL);
  // Справка не будет закрываться вместе с приложением.
end;


Как программно закрыть другое приложение без вывода сообщений о необходимости сохранения?

procedure TForm1.Button1Click(Sender: TObject);
begin
   PostMessage(FindWindow(nil, 'Заголовок окна'), WM_QUIT, 0, 0);
end;


Как конвертировать римское число в арабское?

// Способ первый
function RomanToDec(const Value: string): Integer;
var
  i, lastValue, curValue: Integer; 
begin 
  Result := 0;
  lastValue := 0;
  for i := Length(Value) downto 1 do
  begin
    case UpCase(Value[i]) of
      'I': curValue := 1;
      'V': curValue := 5;
      'X': curValue := 10;
      'L': curValue := 50;
      'C': curValue := 100;
      'D': curValue := 500;
      'M': curValue := 1000;
    else
      raise Exception.CreateFmt('Invalid character: %s', [Value[i]]);
    end;
    if curValue < lastValue then
      Dec(Result, curValue)
    else
      Inc(Result, curValue);
    lastValue := curValue;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(RomanToDec('XVIII')));
end;

// Способ второй
function RomanToInt(num: string): Integer;
const
  N = 13;
  vals: array [1..N] of Word =
    (4, 9, 40, 90, 400, 900, 1, 5, 10, 50, 100, 500, 1000);
  roms: array [1..N] of string[2] =
    ('IV', 'IX', 'XL', 'XC', 'CD', 'CM', 'I', 'V', 'X', 'L', 'C', 'D', 'M');
var
  i: Integer;
begin
  Result := 0;
  while Length(num) > 0 do
  begin
    for i := Low(roms) to High(roms) do
      if AnsiUpperCase(Copy(num, 1, Length(roms[i]))) = roms[i] then
      begin
        Inc(Result, vals[i]);
        Delete(num, 1, Length(roms[i]));
        Break;
      end;
  end;
end;

// Способ третий
function Arabic(s: string): Integer;
const
  R: array[1..13] of string[2] =
    ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
  A: array[1..13] of Integer =
    (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
var
  i, p: Integer;
begin
  Result := 0;
  i := 13;
  p := 1;

  while p <= Length(s) do
  begin
    while Copy(s, p, Length(R[i])) <> R[i] do
    begin
      Dec(i);
      if i = 0 then
        Exit;
    end;
    Result := Result + A[i];
    p := p + Length(R[i]);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(Arabic('LXXXI')));
end;

// Способ четвертый
function RomanToInt(const s: string): Longint;
const
  RomanChars = ['C', 'D', 'I', 'L', 'M', 'V', 'X'];
  RomanValues: array['C'..'X'] of Word =
    (100, 500, 0, 0, 0, 0, 1, 0, 0, 50, 1000,
     0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 10);
var
  Index, Next: Char;
  i: Integer;
  Negative: Boolean;
begin
  Result := 0;
  i := 0;
  Negative := (Length(s) > 0) and (s[1] = '-');
  if Negative then
    Inc(i);
  while (i < Length(s)) do
  begin
    Inc(i);
    Index := UpCase(S[i]);
    if Index in RomanChars then
    begin
      if Succ(i) <= Length(s) then
        Next := UpCase(s[i+1])
      else
        Next := #0;
      if (Next in RomanChars) and (RomanValues[Index] < RomanValues[Next]) then
      begin
        Inc(Result, RomanValues[Next]);
        Dec(Result, RomanValues[Index]);
        Inc(i);
      end
      else
        Inc(Result, RomanValues[Index]);
    end
    else
    begin
      Result := 0;
      Exit;
    end;
  end;
  if Negative then
    Result := -Result;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(RomanToInt('LXXXI')));
end;


Как очистить папку документы в меню "Пуск"?

uses
  {...,} ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SHAddToRecentDocs(SHARD_PATH, nil);
end;


Как открыть редактора реестра на нужной ветви?

uses
  {...,} ShellAPI, Registry;

function OpenRegEditAndJumpToKey(const KeyName: String): Boolean;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    Result := OpenKey('Software\Microsoft\Windows\CurrentVersion\Applets\Regedit', False);
    if Result then
    try
      try
        WriteString('LastKey', KeyName);
      except
        Result := False;
        Exit;
      end;
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
  Result := ShellExecute(0, 'open', 'regedit.exe', nil, nil, SW_SHOWNORMAL) > HINSTANCE_ERROR;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not OpenRegEditAndJumpToKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Cdrom') then
    RaiseLastOSError;
end;


Как уведомить все приложения, что реестр был изменён?

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,
              LongInt(PChar('RegistrySection')));
end;

// Вместо 'RegistrySection' укажите ту секцию реестра,
// которую вы изменили.


Как задать шаг в цикле for?

for i := 0 to Maximum do
  if i mod Step = 0 then
  begin
    // Какие-то действия
  end;


Как быстро обменять значения 2х переменных?

// Способ первый
procedure SwapVars(var u, v; Size: Integer);
var
  x: Pointer;
begin
  GetMem(x, Size);
  try
    System.Move(u, x^, Size);
    System.Move(v, u, Size);
    System.Move(x^, v, Size);
  finally
    FreeMem(x);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  a, b: Integer;
begin
  a := 1;
  b := 2;
  SwapVars(a, b, SizeOf(Integer));
  ShowMessage(Format('%d, %d', [a, b]));
end;

// Способ второй
procedure SwapVars(var Source, Dest; Size: Integer);
asm
  push edi
  push esi
  mov esi, Source
  mov edi, Dest
  mov ecx, Size
  cld
  @1:
  mov al, [edi]
  xchg [esi], al
  inc si
  stosb
  loop @1
  pop esi
  pop edi
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  a, b: Integer;
begin
  a := 8;
  b := 4;
  SwapVars(a, b, SizeOf(Integer));
  ShowMessage(Format('%d, %d', [a, b]));
end;


Как добавить документ в меню "Пуск - Документы"?

uses
  {...,} ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
begin
  s := 'Здесь пишем полный путь к файлу';
  SHAddToRecentDocs(SHARD_PATH, PChar(s));
end;


Как преобразовать .swf в .exe?

// S = Путь к преобразовываемому .swf файлу
// D = Путь к выходному .exe файлу
// F = Путь к проигрывателю "Flash Player"
function Swf2Exe(S, D, F: string): Boolean;
var
  SourceStream, DestinyStream, LinkStream: TFileStream;
  Flag: Cardinal;
  SwfFileSize: Integer;
begin
  Result := false;
  DestinyStream := TFileStream.Create(D, fmCreate);
  try
    LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive);
    try
      DestinyStream.CopyFrom(LinkStream, 0);
    finally
      LinkStream.Free;
    end;

    SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive);
    try
      DestinyStream.CopyFrom(SourceStream, 0);
      flag := $FA123456;
      DestinyStream.WriteBuffer(Flag, SizeOf(Integer));
      SwfFileSize := SourceStream.Size;
      DestinyStream.WriteBuffer(SwfFileSize, SizeOf(Integer));
      Result := True;
    finally
      SourceStream.Free;
    end;
  finally
    DestinyStream.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not Swf2Exe('C:\somefile.swf', 'C:\somefile.exe',
                 'D:\Program Files\Flash 5\Players\FlashPla.exe') then
    ShowMessage( 'Преобразование не выполнено...' );
end;

При использовании материала - ссылка на сайт обязательна