Форум 'Delphi & Builder' на RSDN

Lazarus, Linux, Android

Sat, 16 Aug 2025 06:19:06 GMT

А что, реально на Linux (Ubuntu) с помощью Lazarus делать Android-приложения?

У кого есть положительный опыт?

Увличить лимит активаций

Mon, 02 Jun 2025 06:28:56 GMT

Добрый день.

Получилось у кого-то последнее время увеличить лимит активаций Delphi/C++ Builder обращением в поддержку Idera/Embarcadero (или как они правильно счас)? Написал 2 дня назад — пока ни ответа, ни привета. В форумах пишут, что они требуют для этого активной подписки, тогда это жесть: купленный продукт нельзя активировать при переустановке!

New! RAD studio 12.2

Fri, 13 Sep 2024 17:26:20 GMT

FYI.
RAD Studio 12.2 is out!
Explore what’s great about the latest update to the RAD Studio toolset,
available since September 2024.
Konstantin.

Что нового сейчас есть в Delphi?

Thu, 18 Jul 2024 04:28:46 GMT

Давно пишу на Delphi XE8, и тут обнаружилась неприятная проблема – баг компилятора из-за которого программа иногда не компилируется (ошибка F2084 Internal error: C2359). Хорошо бы перейти на Delphi поновее, или может быть Lazarus. Хочу спросить, какие фичи есть в новых версиях, и нет ли в них частности такого:
1) Очень не хватает возможности назвать то, на что ссылается блок with. Т.е. нужно обозначение вроде this или it, аналогичное self для класса. Это не только моя мысль, я видел такой запрос в инете, так что можно надеяться идея дошла до разработчиков;
2) Хорошо что в XE появились процедуры и функции к рекордам, т.е. инкапсуляция для рекордов, а нельзя ли ещё наследование (понятно что нельзя полиморфизм, а инкапсуляция и наследование вполне);
3) Хотелось бы иметь быстрые классы без лишней вспомогательной информации. Я имею в виду, что классы включают в себя таблицу виртуальных методов, информацию о классе вроде его названия и пр., поэтому не очень хочется превращать в класс разную мелочь (трата ресурсов компьютера). Может быть, то что я предлагаю можно реализовать только за счёт отказа от полиморфизма, ну пусть хотя бы так. В принципе сейчас можно для этого заменять классы указателями на рекорды, но опять же не хватает наследования;
4) Как там в новых Delphi с Firemonkey и поддержкой Linux, Mac, Android? Они хотя бы скомпилировали Delphi на FMX?
5) Метапрограммирование, макросы – есть сейчас что-то такое?
6) Я давно предлагаю поэтапную компиляцию: сначала превратить исходник в более быстрый (размноженный), например в котором инлайновые функции заинлайнились и их удобнее отлаживать. Вряд ли это кто-то сделал, но вдруг...

Странный баг Delphi XE8

Fri, 25 Aug 2023 07:22:59 GMT

Я что-то поменял в коде, и мой проект перестал запускаться. Стала срабатывать ошибка range check error в коде, где такой ошибки не может быть.
Вернул предыдущий код проекта — снова всё работает. Попытался подменить часть модулей последним кодом — снова перестало работать. После этого вернул эти же модули предыдущими — снова не работает; но если обновить все коды проекта, снова вернуть предыдущий вариант — работает.
Попробовал установить Delphi на другом компьютере, скомпилировал — такая же ошибка.
Заметил ещё одну странность: на одном из модулей (возможно это как раз проблемный модуль, с которого всё пошло) после нажатия F9 возникает синий breakpoint на самой верхней строчке (где название модуля). Убираю этот breakpoint, нажимаю F9 — снова он появляется.
Кто-нибудь с таким сталкивался?

Медленная работа связки ADO с MS SQL Server

Wed, 09 Aug 2023 11:58:51 GMT

Доброго времени и мое почтение старожилам!

На новой работе свела судьба некрокомпонентом TBetterAdoDataset и соответственнно кровавым легаси.
Есть довольно большой продукт, написанный на DelphiXE 10.3 но использующий ADO и вышеупомянутый некроморф. БД — MS SQL Server.
С недавних пор, один из клиентов жалуется что данное приложение работает неприлично медленно.
Под неприлично медленно имеется ввиду: 3 примитивных запроса типа "SELECT Field1, Field2 FROM TableName WHERE ID=Value" выполняются порядка 5 секунд.
Запросы возвращают одну запись.
В редких случаях, вылетает исключение с таймаутом.

Можно списать на плохую сетевую инфраструктуру, НО:
Другое приложение, также написанное на Delphi + TBetterAdoDataset, работающее с этой же самой базой, на этом же самом ПК, таких проблем не имеет и работает с нормальной скоростью.
К сожалению исходники второго приложения нам недоступны.

Я понимаю что это очень тупой вопрос, но:
может у кого-то есть идеи, куда можно посмотреть?
Мы рассматриваем абсолютно любую зацепку. Даже за мысли вслух будем благодарны.

Всем заранее спасибо!

Devexpress

Tue, 27 Jun 2023 11:06:46 GMT

Devexpress не хотят продавать подписку в компанию, хоть как-то, по их мнению связанную с РФ.

Никто не сталкивался как приобрести в современных условиях?

Не открывается файл в Win11 (drive cannot be found)

Tue, 13 Jun 2023 17:27:51 GMT

Два пользователя моей программы написали, что в Windows 11 моя программа не работает, точнее не открывает файл через File/Open. Если они пытаются открыть файл, выдаётся ошибка "The drive cannot be found". При этом я не могу у себя воспроизвести эту ошибку, в том числе когда запускаю программу на ноутбуке с Windows 11 (у меня всё открывается нормально).
Один из них написал, что ошибка пропала после того как он обновил GPU drive, но потом она появилась снова.
Странная ситуация, подскажите что делать.

Список открытых окон проводника

Wed, 15 Mar 2023 14:42:41 GMT

Доброго времени.
Собственно пытаюсь получить открытые окна проводника. Возникает ошибка при обращении к Item.
Что не так?

Debugger Exception Notification
---------------------------
Project Project4.exe raised exception class $C0000005 with message 'access violation at 0x00c6fd3c: read of address 0x00000000'.
---------------------------
Break Continue Copy Help
---------------------------

uses SHDocVw;

Function GetCurrentExplorerDirectory: String;
var
  ShellWindows: IShellWindows;
  i: Integer;
  h: HWND;
begin
  Result := '';

  {Explorer - глобальная переменная для доступа ко всем откр.окнам Explorer}
  ShellWindows := CoShellWindows.Create;

  {Цикл прохода по всем откр.в настоящий момент окнам Explorer}
  for i := 0 to ShellWindows.Count - 1 do
    {Если очередное окно пребывает сейчас в фокусе}
    if GetForegroundWindow = (ShellWindows.Item(i) as IWebbrowser2).HWND then <----------------------------------- ВОТ ТУТ ОШИБКА
    begin
      {Получаем его Handle (дескриптор окна) }
      h := (ShellWindows.Item(i) as IWebbrowser2).HWND; 
    end;
end;

Получение списка файлов из буфера обмена

Mon, 13 Mar 2023 06:45:56 GMT

Делаю выборку форматов, и если попадается CF_HDROP пытаюсь забрать из него список файлов.
Получаю либо какой то мусор, либо строку, обрезанную слева.
Утилиты для просмотра содержимого буфера обмена показывают все правильно.
Что я делаю не так?

uses ShlObj, Clipbrd;

function TForm2.Get_ClipboardFiles: String;
var
  len, fmt: integer;
  tmp: array of Byte;

  Data: THandle;
  DataPtr: Pointer;
  DataLen: integer;

  pFormatName: String;
  sTmp: WideString;

begin
  Result := '';

  Clipboard.Open;
  try
    fmt := EnumClipboardFormats(0);
    while (fmt > 0) do
    begin
      Data := GetClipboardData(fmt);
      if Data <> 0 then
      begin
        DataPtr := GlobalLock(Data);
        if DataPtr <> nil then
          try
            DataLen := GlobalSize(Data);
            if DataLen > 0 then
            begin
              SetLength(pFormatName, 255);
              len := GetClipboardFormatName(fmt, @pFormatName[1], 255);
              SetLength(pFormatName, len);

              if fmt = CF_HDROP then
                SetString(Result, PFileGroupDescriptor(DataPtr)^.fgd[0].cFileName, Length(PFileGroupDescriptor(DataPtr)^.fgd[0].cFileName));
            end;
          finally
            GlobalUnlock(Data);
          end;
      end;
      fmt := EnumClipboardFormats(fmt);
    end;
  finally
    Clipboard.Close;
  end;
end;

Generics под капотом

Sat, 21 Jan 2023 09:49:57 GMT

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

	Код1
	`TStringMap = TDictionary<string,string>; class TMyClass FMap : TStringMap; constructor Create; end; constructor TMyClass.Create; begin inherited; FMap := TStringMap.Create; end;`

или

	Код2
	`class TMyClass; FMap : TDictionary<string,string>; constructor Create; end; constructor TMyClass.Create; begin inherited; FMap := TDictionary<string,string>.Create; end;`

Проблема в том , что заканчивается память при компиляции из среды (bds.exe доходит до предела 3Гб).
Программа порядка 1,8 млн строк (только своих) + сторонние компоненты.
Около 2500 только своих модулей
Delphi 10.4.2

Подозреваю что больше всего нагружает компилятор циклические зависимости между модулями (но они почти все разрулены) и сложные конструкции с Generics.
В программе много кода в стиле типа такого

Код3

procedure TfrmTopGraphDM.actSaveNearestGIds4ShRPExecute(Sender: TObject);
type
  RPair = record
    nb1, nb2: TNB;
  end;
var
  sch: TSchemeSet;
  lPairs: TRStream<String>;
begin
  sch := App.SDEDocs.Active;
  if not Assigned(sch) then exit;

  lPairs :=
    TRStream<TNB>.stream<Integer>(sch.Techs)
      .map<TNB>(
        procedure (aNB: TNB; var aMap: TProc<TNB>)
        begin
          if (aNB.IsChildOrEqual(ttcPowerTransformer) and TCEAPI.isShRP(aNB)) then
            aMap(aNB);
        end)
      .map<RPair>(
        procedure (aNB: TNB; var aMap: TProc<RPair>)
        var
          lSwitch: TCE;
          lPair: RPair;
        begin
          lSwitch := TRStream<TNB>
            .just(aNB)
            .map<TCE>(TCeAPI.ce)
            .map(TCeAPI.find(TCERules.windingExtraTerminalsRules,
                  function (aCe: TCE): Boolean
                  begin
                    Result := aCe.IsChildOrEqual(ttcSwitch) and not TCEAPI.isCandle(aCE) and (TCEAPI.globalId(aCE) <> '');
                  end, True))
            .first
            .toArray()
            .firstItem;
          if Assigned(lSwitch) then
          begin
            lPair.nb1 := aNB;
            lPair.nb2 := lSwitch;
            aMap(lPair);
          end;
        end)
      .map<String>(
        procedure (aPair: RPair; var aMap: TProc<String>)
        begin
          aMap(TTopGraphUtils.SaveNB(aPair.nb1) + CSV_DELIMETER + TTopGraphUtils.SaveNB(aPair.nb2));
        end);

  TRIO.saveToFile(lPairs);
end;

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

Как на Lazarus скомпилировать Linux-код

Fri, 30 Dec 2022 09:46:08 GMT

У меня есть код моей программы на Lazarus в Windows, который можно компилировать. Теперь пытаюсь скомпилировать его для Linux. Сначала я пытался поставить Lazarus на моём Linux-ноутбуке, и столкнулся с разными ужосами: дистрибутив Lazarus c .deb инсталлятором выдаёт ошибку "the following packages have unmet dependencies", а другой дистрибутив с каталогами usr/bin даёт ошибку "Ссылка испорчена". После этого я проинсталлировал Lazarus (более старая версия) через терминал, но он ничего не компилирует. Тогда я попробовал просто скомпилировать Linux программу (. ) в моём Windows-Лазарусе. Выдалась ошибка "Не найден system.ppu" или "Fatal: Невозможно найти system, используемый в fcllaz пакета FCL.". Подскажите как решить эту задачу.

Lazarus vs Code Typhon

Fri, 16 Dec 2022 11:12:31 GMT

Я уже писал что мне нужно на Lazarus скомпилировать программу с графиками, стандартного teechart там нет, но тут написано что он есть на Code Typhon. Скачал Code Typhon 7.9, проинсталлировал Win64-версию, и сразу обнаружилось что я ничего в нём не понимаю. У меня проект с головным файлом .lpr, а в Typhon на Файл/Открыть не открываются файлы с таким расширением. Как открыть мой Lazarus-проект в Typhon? И ещё непонятный момент — в Typhon я начал новый проект, поместил на Form1 компоненты, а потом случайно закрыл окно и с тех пор не знаю, как редактировать код этого проекта (когда выбираю Вид/редактор исходного кода или Вид/обозреватель кода, ничего не меняется).
В связи с этим вопрос — что лучше, Lazarus 2.2.2 или Code Typhon 7.9? Не окажется ли что второй с багами?
По ссылке было написано что в Typhon есть teechart, но вроде если добавить на форму график, это будет TAChart который есть и в Lazarus. А как использовать Teechart в Typhon? И если есть его исходники, может быть можно перенести teechart на Lazarus?

Кроссплатформенный tchart в Delphi и Lazarus

Thu, 15 Dec 2022 07:48:33 GMT

Мне казалось, что лучшим решением будет использовать steema teechart, чуть поправив его для компиляции в Lazarus, как написано здесь:

https://habr.com/ru/post/534466/

Но поставить бесплатно исходники steema teechart не получилось, возможно авторы проапгрейдили защиту (активация онлайн). Может быть, стоит купить исходники steema teechart за 600 долларов? Если это возможно в России.

Clipboard в Lazarus

Thu, 10 Nov 2022 09:39:57 GMT

Когда я перевёл свой проект с Delphi на Lazarus, перестали работать функции вставки из клипбоарда. Когда срабатывает функция TClipboard.GetAsText, ошибка происходит на это функции TClipboard.GetFormat:

  Result:=false;
  if Stream=nil then exit;
  if FormatID=0 then exit;
  if CanReadFromCache then begin
    if Assigned(FOnRequest) then begin
      FOnRequest(FormatID,Stream);
      Result:=true;
    end else begin
      i:=IndexOfCachedFormatID(FormatID,false);
      if i<0 then
        Result:=false
      else begin
        FData[i].Stream.Position:=0;
        if Stream is TMemoryStream then
          TMemoryStream(Stream).SetSize(Stream.Position+FData[i].Stream.Size);
        Stream.CopyFrom(FData[i].Stream,FData[i].Stream.Size);
        Result:=true;
      end;
    end;
  end else begin
    // not the clipboard owner -> request data
    Result:=ClipboardGetData(ClipboardType,FormatID,Stream);
  end;

Здесь IndexOfCachedFormatID возвращает -1 и далее процедура обрывается. Как это можно исправить? Может быть есть другие библиотеки для поддержки клипбоарда, если стандартная не работает?

Как вы изучаете Lazarus?

Sat, 17 Sep 2022 16:24:18 GMT

Мне надо портировать мою программу с Delphi на Lazarus, и это весьма сложная задача, я уже столкнулся с подводными камнями и проблемами, ответы на которые толком не гуглятся, также я задаю вопросы на форумах и не всегда мне дают ответ. Купил книгу "Основы программирования в среде Lazarus" Мансурова, начал читать, и по моему там нет ничего из того что мне нужно. Как вы находите для себя информацию про программированию в Lazarus?

Документация по Indy 10

Wed, 07 Sep 2022 17:32:49 GMT

Прошу прощения за наверное наивный вопрос...
Можно где-то скачать (хоть в каком-то формате) или посмотреть документацию по Indy10 ?

Та что была на старом сайте похоже похоронена хостером, на e-iter дает ошибки 404 на массе страниц.

Спасибо !

Delphi + запись в COM-порт

Mon, 22 Aug 2022 13:45:42 GMT

Здравствуйте, уважаемые форумчане.

Написал простенькую программу на Delphi:

{$APPTYPE CONSOLE}
program wr;

uses Windows;

var
  port: THandle;
  cfg: TDCB;

  s: AnsiString;
  n: Cardinal;

begin
  port := CreateFile(
    'COM4',
    GENERIC_READ or GENERIC_WRITE,
    0,
    nil,
    OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL,
    0
  );
  cfg.DCBlength := SizeOf(TDCB);
  cfg.BaudRate := 9600;
  cfg.ByteSize := 8;
  cfg.Parity := NoParity;
  cfg.StopBits := OneStopBit;
  cfg.Flags := 0;
  SetCommState(port, cfg);

  s := #$01#$02#$03#$04#$05;
  WriteFile(port, s, Length(s), n, nil);
  WriteLn(n);

  CloseHandle(port);
  ReadLn;
end.

Она открывает COM4 и пишет туда строку размером в 5 байт: 01 02 03 04 05.
Однако, на принимающей стороне, приходят байты: 0C 00 41 00 00.
Подскажите, в чём может быть дело? Порт открывается в режиме 8N1 9600 бод.

На принимающей стороне читаю так:

#include <stdio.h>
#include <fcntl.h>
#include <termios.h>
#include <unistd.h>
#include <stdlib.h>
#include <stdint.h>
#include <sys/ioctl.h>

int main(int argc, char **argv) {

  int fd, n;
  struct termios options;

        const char *fn = "/dev/ttyUSB0";
  if (argc > 1) fn = argv[1];
  fd = open(fn, O_RDWR | O_NOCTTY);
  if (fd < 0) {
    printf("Unable to open %s\n", fn);
    return -1;
  }

  fcntl(fd, F_SETFL, FNDELAY);
  tcgetattr(fd, &options);
  cfsetspeed(&options, B9600);
  options.c_iflag = 0;
  options.c_oflag = 0;
  options.c_lflag = 0;
  options.c_cflag = 0 ;
  options.c_cflag = CS8;
  options.c_cc[VMIN] = 0;
  options.c_cc[VTIME] = 0;
  tcsetattr(fd, TCSANOW, &options);

  printf("\n");
  unsigned char c;
  for (;;) {
    int n = read(fd, &c, 1);
    if (n > 0)
    printf(" %02X\n", c);
  }
  printf("\n");

  close(fd);
  return 0;
}

Физически, приём-передача ведётся через обычные FT232R (USB).

ID3D11Texture2D -> DIBSection

Mon, 18 Jul 2022 20:47:20 GMT

Есть рабочий код из Desktop Duplication API. Он переводит ID3D11Texture2D в TBitmap:

function TDesktopDuplicationWrapper.DrawFrame(var Bitmap: TBitmap): Boolean;
var
  Desc: TD3D11_TEXTURE2D_DESC;
  Temp: ID3D11Texture2D;
  Resource: TD3D11_MAPPED_SUBRESOURCE;
  i: Integer;
  p: PByte;
begin
  Result := True;

  FTexture.GetDesc(Desc);

  if Bitmap = nil then
    Bitmap := TBitmap.Create;

  Bitmap.PixelFormat := pf32Bit;
  Bitmap.SetSize(Desc.Width, Desc.Height);

  Desc.BindFlags := 0;
  Desc.CPUAccessFlags := Ord(D3D11_CPU_ACCESS_READ) or Ord(D3D11_CPU_ACCESS_WRITE);
  Desc.Usage := D3D11_USAGE_STAGING;
  Desc.MiscFlags := 0;

  //  READ/WRITE texture
  FError := FDevice.CreateTexture2D(@Desc, nil, Temp);
  if Failed(FError) then
  begin
    FTexture := nil;
    FDuplicate.ReleaseFrame;

    Result := False;
    Exit;
  end;

  // copy original to the RW texture
  FContext.CopyResource(Temp, FTexture);

  // get texture bits
  FContext.Map(Temp, 0, D3D11_MAP_READ_WRITE, 0, Resource);
  p := Resource.pData;

  // copy pixels - we assume a 32bits bitmap !
  for i := 0 to Desc.Height - 1 do
  begin
    Move(p^, Bitmap.ScanLine[i]^, 4 * Desc.Width);
    Inc(p, 4 * Desc.Width);
  end;

  FTexture := nil;
  FDuplicate.ReleaseFrame;
end;

Мне нужно переделать так, чтобы писалось не в TBitmap, а в DIBSection (а именно в pBits), созданную таким путем:

procedure CreateBitmapData;
begin
  sWidth := GetSystemMetrics(SM_CXSCREEN);
  sHeight := GetSystemMetrics(SM_CYSCREEN);

  hDeskWin := GetDesktopWindow;
  hScrDC := GetDC(hDeskWin);
  with bitmap_info.bmiHeader do
  begin
    biSize := sizeof(BITMAPINFOHEADER);
    biWidth := sWidth;
    //Use negative height to scan top-down.
    biHeight := -sHeight;
    biPlanes := 1;
    biBitCount := GetDeviceCaps(hScrDC, BITSPIXEL);
    biCompression := BI_RGB;
  end;
  pBits := nil;
  hBmp := CreateDIBSection(hScrDC, bitmap_info, DIB_RGB_COLORS, pBits, 0, 0);
//  hBmp := CreateCompatibleBitmap(hScrDC, sWidth, sHeight);
  hMemDC := CreateCompatibleDC(hScrDC);
end;

Как это реализовать напрямую, без TBitmap -> BitBlt?

Скриншот части экрана через DirectX

Sun, 10 Jul 2022 11:19:15 GMT

Доброго времени.
Имеется рабочая процедура, которая делает скриншот всего экрана целиком. Необходимо ее переделать, чтобы она брала именно нужную часть. При замене везде Width и Height к примеру на 100х100, в итоге получается черный экран.
Код взят отсюда
Что я пропустил?

Рабочий код

procedure TImageCatcher.GetDirectXData();
var
  BitsPerPixel: Byte;
  pD3D: IDirect3D9;
  pSurface: IDirect3DSurface9;
  g_pD3DDevice: IDirect3DDevice9;
  D3DPP: TD3DPresentParameters;
  ARect: TRect;
  LockedRect: TD3DLockedRect;
  BMP: VCL.Graphics.TBitmap;
  i, p: Integer;
  x, y: integer;
  w, h: integer;
  res: BOOL;
begin
  GetTargetDimensions(w, h); //Возвращает ширину и высоту экрана

  GetTargetPosition(x, y);
  BitsPerPixel := 32;
  FillChar(d3dpp, SizeOf(d3dpp), 0);
  with D3DPP do
  begin
    Windowed := True;
    Flags := D3DPRESENTFLAG_LOCKABLE_BACKBUFFER;
    SwapEffect := D3DSWAPEFFECT_DISCARD;
    BackBufferWidth := Screen.Width;
    BackBufferHeight := Screen.Height;
    BackBufferFormat := D3DFMT_X8R8G8B8;
  end;
  pD3D := Direct3DCreate9(D3D_SDK_VERSION);
  pD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, GetDesktopWindow, D3DCREATE_SOFTWARE_VERTEXPROCESSING, @ D3DPP, g_pD3DDevice);
  g_pD3DDevice.CreateOffscreenPlainSurface(Screen.Width, Screen.Height, D3DFMT_A8R8G8B8, D3DPOOL_SCRATCH, pSurface, nil);
  g_pD3DDevice.GetFrontBufferData(0, pSurface);
  ARect := Screen.DesktopRect;
  pSurface.LockRect(LockedRect, @ ARect, D3DLOCK_NO_DIRTY_UPDATE or D3DLOCK_NOSYSLOCK or D3DLOCK_READONLY);
  BMP := VCL.Graphics.TBitmap.Create;
  BMP.Width := Screen.Width;
  BMP.Height := Screen.Height;
  case BitsPerPixel of
    8: BMP.PixelFormat := pf8bit;
    16: BMP.PixelFormat := pf16bit;
    24: BMP.PixelFormat := pf24bit;
    32: BMP.PixelFormat := pf32bit;
  end;
  p := Cardinal(LockedRect.pBits);
  for i := 0 to Screen.Height - 1 do
  begin
    CopyMemory(BMP.ScanLine[i], Ptr(p), Screen.Width * BitsPerPixel div 8);
    p := p + LockedRect.Pitch;
  end;
  Bitmap.SetSize(w, h);
  res := BitBlt(Bitmap.Canvas.Handle, 0, 0, w, h, BMP.Canvas.Handle, x, y, SRCCOPY);
  BMP.Free;
  pSurface.UnlockRect;
end;

Измененный нерабочий код

procedure TImageCatcher.GetDirectXData();
var
  BitsPerPixel: Byte;
  pD3D: IDirect3D9;
  pSurface: IDirect3DSurface9;
  g_pD3DDevice: IDirect3DDevice9;
  D3DPP: TD3DPresentParameters;
  ARect: TRect;
  LockedRect: TD3DLockedRect;
  BMP: VCL.Graphics.TBitmap;
  i, p: Integer;
  x, y: integer;
  w, h: integer;
  res: BOOL;
begin
  GetTargetDimensions(w, h);

//  w := 50;
//  h := 50;

  GetTargetPosition(x, y);
  BitsPerPixel := 32;
  FillChar(d3dpp, SizeOf(d3dpp), 0);
  with D3DPP do
  begin
    Windowed := True;
    Flags := D3DPRESENTFLAG_LOCKABLE_BACKBUFFER;
    SwapEffect := D3DSWAPEFFECT_DISCARD;
    BackBufferWidth := 100; //Screen.Width;
    BackBufferHeight := 100; //Screen.Height;
    BackBufferFormat := D3DFMT_X8R8G8B8;
  end;
  pD3D := Direct3DCreate9(D3D_SDK_VERSION);
  pD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, GetDesktopWindow, D3DCREATE_SOFTWARE_VERTEXPROCESSING, @ D3DPP, g_pD3DDevice);
  g_pD3DDevice.CreateOffscreenPlainSurface(100 {Screen.Width}, 100 {Screen.Height}, D3DFMT_A8R8G8B8, D3DPOOL_SCRATCH, pSurface, nil);
  g_pD3DDevice.GetFrontBufferData(0, pSurface);
  ARect := Rect(0, 0, 100, 100);  //Screen.DesktopRect;
  pSurface.LockRect(LockedRect, @ ARect, D3DLOCK_NO_DIRTY_UPDATE or D3DLOCK_NOSYSLOCK or D3DLOCK_READONLY);
  BMP := VCL.Graphics.TBitmap.Create;
  BMP.Width := 100; //Screen.Width;
  BMP.Height := 100; //Screen.Height;
  case BitsPerPixel of
    8: BMP.PixelFormat := pf8bit;
    16: BMP.PixelFormat := pf16bit;
    24: BMP.PixelFormat := pf24bit;
    32: BMP.PixelFormat := pf32bit;
  end;
  p := Cardinal(LockedRect.pBits);
  for i := 0 to 100 {Screen.Height} - 1 do
  begin
    CopyMemory(BMP.ScanLine[i], Ptr(p), 100 {Screen.Width} * BitsPerPixel div 8);
    p := p + LockedRect.Pitch;
  end;
  Bitmap.SetSize(w, h);
  res := BitBlt(Bitmap.Canvas.Handle, 0, 0, w, h, BMP.Canvas.Handle, x, y, SRCCOPY);
  BMP.Free;
  pSurface.UnlockRect;
end;