FAQ VCL
Разное

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

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

:: MVP ::

:: RSS ::

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

Как изменить значение константы в runtime?

// Способ первый
const
{$J+}
  N: Byte = 10;
{$J-}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Inc(N, 10);
  ShowMessage(IntToStr(N));
end;

// Способ второй
const
  N: Integer = 10;
  S: string = 'text sample';

procedure ChangeConst(const Constant; var Value; Size: Integer);
begin
  Move((@Value)^, (@Constant)^, Size);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  NewN: Integer;
  NewS: string;
begin
  // String Demo:
  NewS := 'new text';
  ChangeConst(S, NewS, SizeOf(string));
  ShowMessage(S);
  // Integer Demo:
  NewN := 20;
  ChangeConst(N, NewN, SizeOf(Integer));
  ShowMessage(IntToStr(N));
end;


Как передать часть массива в процедуру в качестве параметра?

procedure TForm1.Button1Click(Sender: TObject);

  procedure Report(a: array of Integer);
  var
    i: Integer;
    Msg: string;
  begin
    Msg := '';
    for i := 0 to Length(a)-1 do
      Msg := Format('%s a[%d] = %d ', [Msg, i, a[i]]);
    ShowMessage(Msg);
  end;

type
  TMyType = array[0..4] of Integer;
  PMyType = ^TMyType;
var
  MyArray: TMyType;
begin
  MyArray[0] := 0;
  MyArray[1] := 1;
  MyArray[2] := 2;
  MyArray[3] := 3;
  MyArray[4] := 4;

  Report(Slice(PMyType(@MyArray[2])^, 2));
end;


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

// Способ первый
uses
  {...,} System.DateUtils;

procedure TForm1.Button1Click(Sender: TObject);
var
  Start, Stop: TDateTime;
begin
  Start := Now;
  Sleep(1000); // Выполняем что-либо
  Stop := Now;
  // Время в секундах
  ShowMessage((MilliSecondsBetween(Start, Stop) / 1000).ToString);
end;

// Способ второй
uses
  {...,} System.DateUtils;

procedure TForm1.Button1Click(Sender: TObject);
var
  Start, Stop: Cardinal;
begin
  Start := GetTickCount;
  Sleep(1000); // Выполняем что-либо
  Stop := GetTickCount;
  // Время в секундах
  ShowMessage(((Stop-Start) / 1000).ToString);
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime, EndTime, Freq: Int64;
begin
  QueryPerformanceFrequency(Freq);
  QueryPerformanceCounter(StartTime);
  Sleep(1000); // Выполняем что-либо
  QueryPerformanceCounter(EndTime);
  // Время в секундах
  ShowMessage(FloatToStrF((EndTime - StartTime) / Freq, ffFixed, 10, 3));
end;

// Способ четвертый
uses
  {...,} System.Diagnostics;

procedure TForm1.Button1Click(Sender: TObject);
var
  Stopwatch: TStopwatch;
begin
  Stopwatch := TStopwatch.Create;
  Stopwatch.Start;
  Sleep(1000); // Выполняем что-либо
  Stopwatch.Stop;
  ShowMessage((Stopwatch.ElapsedMilliseconds / 1000).ToString);
end;


Как сгенерировать случайное значение с заданной вероятностью?

type
  TValue = record
    Name: string;
    Weight: Integer;
  end;
  TValues = array of TValue;

function SmartRandom(const Val: TValues): Integer;
var
  i, r, Summ: Integer;
  Interval: array of Integer;
begin
  if Length(Val) = 0 then
    raise Exception.Create('Массив значений пуст.');

  Summ := 0;

  // Формирование массива с интервалами
  SetLength(Interval, Length(Val));
  for i := Low(Val) to High(Val) do
  begin
    Inc(Summ, Val[i].Weight);
    Interval[i] := Summ;
  end;

  // Случайное число от 0 до суммы
  // всех весовых коэффициентов
  r := Random(Summ+1);

  // Найти интервал, в который попадает
  // случайное число
  for i := Low(Interval) to High(Interval) do
    if r <= Interval[i] then
      Exit(i);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
  Val: TValues;
begin
  // Формирование массива значений и весовых коэффициентов
  SetLength(Val, 3);
  Val[0].Weight := 3; Val[0].Name := 'Купить';
  Val[1].Weight := 6; Val[1].Name := 'Заказать';
  Val[2].Weight := 1; Val[2].Name := 'Приобрести';

  for i := 1 to 10 do
    ShowMessage(Val[SmartRandom(Val)].Name);
end;


Как включить/выключить Just-In-Time debugging?

function IsDebugEnable: Boolean;
begin
  Result := False;
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    if OpenKeyReadOnly('Software\Microsoft\Windows Script\Settings') then
    begin
      if ValueExists('JITDebug') then
        Result := ReadInteger('JITDebug') <> 0;
      CloseKey;
    end;
  finally
    Free;
  end;
end;

function SetDebug(const Enable: Boolean): Boolean;
const
  Value: array[Boolean] of Integer = (0, 1);
begin
  Result := False;
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    if OpenKey('Software\Microsoft\Windows Script\Settings', True) then
    try
      try
        WriteInteger('JITDebug', Value[Enable]);
        Result := True;
      except
      end;
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;


Как перебрать соседние клетки на двухмерном ограниченном поле?

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    FArea: array of array of Boolean;
    function CountWithBorder(ARow, AColumn, ATotlaRows, ATotalColumns: Integer): Integer;
  end;

implementation

const
  AREA_ROWS = 5;
  AREA_COLUMNS = 7;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetLength(FArea, AREA_ROWS, AREA_COLUMNS);
end;

function TForm1.CountWithBorder(ARow, AColumn, ATotlaRows,
  ATotalColumns: Integer): Integer;
var
  RowDelta, ColumnDelta: Integer;
  CurRow, CurColumn: Integer;
begin
  Result := 0;

  for RowDelta := -1 to 1 do
    for ColumnDelta := -1 to 1 do
    begin
      if (RowDelta = 0) and (ColumnDelta = 0) then
        Continue;

      CurRow := ARow + RowDelta;
      CurColumn := AColumn + ColumnDelta;

      //if (0 <= CurColumn) and (CurColumn < ATotalColumns) and
      //   (0 <= CurLine) and (CurLine < ATotlaLines) then
      if (CurColumn in [0..ATotalColumns-1]) and (CurRow in [0..ATotlaRows-1]) then
        if FArea[CurRow, CurColumn] then
          Inc(Result);
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(CountWithBorder(0, 0, AREA_ROWS, AREA_COLUMNS)));
end;


Как перебрать соседние клетки на двухмерном неограниченном поле?

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    FArea: array of array of Boolean;
    function CountWithoutBorder(ARow, AColumn, ATotlaRows, ATotalColumns: Integer): Integer;
  end;

implementation

const
  AREA_ROWS = 5;
  AREA_COLUMNS = 7;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetLength(FArea, AREA_ROWS, AREA_COLUMNS);
end;

function TForm1.CountWithoutBorder(ARow, AColumn, ATotlaRows,
  ATotalColumns: Integer): Integer;

  function ModEx(a, b: Integer): Integer;
  begin
    Result :=  a - Floor(a/b) * b;
  end;

var
  RowDelta, ColumnDelta: Integer;
  CurRow, CurColumn: Integer;
begin
  Result := 0;

  for RowDelta := -1 to 1 do
    for ColumnDelta := -1 to 1 do
    begin
      if (RowDelta = 0) and (ColumnDelta = 0) then
        Continue;

      CurRow := ModEx(ARow + RowDelta, ATotlaRows);
      CurColumn := ModEx(AColumn + ColumnDelta, ATotalColumns);

      if FArea[CurRow, CurColumn] then
       Inc(Result);
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage(IntToStr(CountWithBorder(0, 0, AREA_ROWS, AREA_COLUMNS)));
end;


Как вывести элементы словаря отсортированными по ключу?

uses
  Generics.Collections;

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
  i, j: Integer;
  LArray: TArray;
  LDict: TDictionary;
begin
  LDict := TDictionary.Create;
  try
    Randomize; // Generate some values

    for i := 0 to 20 do
    begin
      j := Random(1000);
      LDict.AddOrSetValue(j, Format('The Value : %d', [j]));
    end;

    s := '';
    for i in LDict.Keys do
      s := s + LDict.Items[i] + #13;
    ShowMessage(s);

    // Sort
    s := '';
    LArray := LDict.Keys.ToArray;
    TArray.Sort(LArray);
    for i in LArray do
      s := s + LDict.Items[i] + #13;
    ShowMessage(s);
  finally
    LDict.Free;
  end;
end;


Как преобразовать TStream в IStream?

uses
  Winapi.ActiveX;

procedure TForm1.Button1Click(Sender: TObject);
var
  COMStream: IStream;
  ResStream: TResourceStream;
begin
  ResStream := TResourceStream.Create(HInstance, '...', RT_RCDATA);
  try
    COMStream := TStreamAdapter.Create(ResStream, soReference);
    try
      {...}
    finally
      COMStream := nil;
    end;
  finally
    ResStream.Free;
  end;
end;


Как создать невидимый (пустой) курсор?

var
  Cur: TCursor;
  MaskAnd: array [0..0] of Byte = ($FF);
  MaskXor: array [0..0] of Byte = ($00);

procedure TForm1.Button1Click(Sender: TObject);
begin
  Cur := CreateCursor(0, 0, 0, 1, 1, @MaskAnd[0], @MaskXor[0]);
end;

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