VPF::Арсенал форумистов - Форум программистов

p0s0l

Дата 15.4.2004, 00:04 (ссылка)

(нет голосов)

Загрузка ...

Г-н Посол

Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

Репутация: 58
Всего: 112

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

Единственное правило - в этой теме не флеймить, тут оставлять только краткое описание модулей и ссылки к ним.

Можно скинуть мне на мыло (кнопка E-Mail под моим постом) файл, и я его прикреплю к вашему сообщению при первой же возможности...

--------------------

С уважением, г-н Посол.

V0LT

Дата 12.5.2012, 11:30 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2

Простой класс для работы с базой Firebird позволяет организовать запрос в минимум строк
Бонус: автоматически создающаяся и удаляющаяся транзакция, отличное быстродействие, отличная замена IBQuery, юзается на крупном проекте smile

Пример

Код


{
var
  SQL: TIBSQLWT;}
{...}
{параметры юзать так - SQL.ParamByName('PARAMNAME').AsInteger}

  SQL := TIBSQLWT.Create(MainDB);
  SQL.SQL.CommaText := 'SELECT NAME FROM DOCS';
  SQL.ExecQuery;
  while not SQL.Eof do
  begin
    str := SQL.Current.ByName('NAME').AsTrimString;
    SQL.Next;
  end;
  SQL.Free;

Реализация класса

Код

unit IBSQLWTUnit;

interface

uses IBSQL, IBDatabase;

type
  TIBSQLWT = class(TIBSQL) // IBSQL потребляет меньше памяти чем IBQuery
  private                         // но немного урезан по функциональности
    TransactionNum: Integer;
  public
    constructor Create(inDatabase: TIBDatabase); reintroduce;
    destructor Destroy; override;
  end;

implementation

{ Реализация IBSQLWT }

//------------------------------------------------------------------------------

{ Конструктор создаёт и добавляет транзакцию
  Вход:
     inDatabase - экземпляр TIBDatabase }
constructor TIBSQLWT.Create(inDatabase: TIBDatabase);
begin
  inherited Create(inDatabase);
  Database := inDatabase;
  Transaction :=  TIBTransaction.Create(Database);
  Transaction.AddDatabase(Database);
  TransactionNum := Database.AddTransaction(Transaction);
  Transaction.StartTransaction();
end;


//------------------------------------------------------------------------------

{ Деструктор выполняет подтверждение и уничтожение транзакции }
destructor TIBSQLWT.Destroy;
begin
  Transaction.Commit();
  Database.RemoveTransaction(TransactionNum);
  Transaction.Free;
  inherited;
end;

end.

Это сообщение отредактировал(а) V0LT - 9.10.2012, 11:53

san46

Дата 12.5.2012, 11:59 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 15
Регистрация: 30.11.2006

Репутация: нет
Всего: нет

Цитата

Простой класс для работы с базой Firebird

Да, неплохо. А если надо откатить транзакцию, то как это делается с применением представленного класса?

V0LT

Дата 12.5.2012, 15:25 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2

По хорошему я бы это написал в данный класс но мне это потребовалось лишь однажды
... а можно переделать конструктор так, что бы в деструкторе производилось либо commit либо rollback

Код


{
var
  SQL: TIBSQLWT;}
{...}
{параметры юзать так - SQL.ParamByName('PARAMNAME').AsInteger}

  SQL := TIBSQLWT.Create(MainDB);

  SQL.SQL.CommaText := 'SELECT NAME FROM DOCS';
  SQL.ExecQuery;
  while not SQL.Eof do
  begin
    str := SQL.Current.ByName('NAME').AsTrimString;
    SQL.Next;
  end;

  SQL.Transaction.Rollback();// или Commit();
  SQL.SQL.Clear;
  SQL.Close;
  SQL.Transaction.StartTransaction();

{с новыми силами оформляем запрос}

  SQL.SQL.CommaText := 'SELECT NAME FROM DOCS';
  SQL.ExecQuery;
  while not SQL.Eof do
  begin
    str := SQL.Current.ByName('NAME').AsTrimString;
    SQL.Next;
  end;

  SQL.Free;

... и ещё, так же деструктор класса возможно лучше обернуть в try ... except и в except добавил бы Rollback пример ниже
не люблю я try ... except smile

Код


  destructor TSimpleSQLQuery.Destroy;
  begin
    try
      Transaction.Commit();
    except
      Transaction.Rollback();
    end;
    Database.RemoveTransaction(TransactionNum);
    Transaction.Free;
    inherited;
  end;

Это сообщение отредактировал(а) V0LT - 12.5.2012, 15:37

V0LT

Дата 12.5.2012, 15:44 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2

Новый TIBSQLWT - теперь банановый с rollback'ом

Код


{...}
  SQL := TIBSQLWT.Create(MainDB); // перед Free будет Commit
{...}

Код


{...}
  SQL := TIBSQLWT.Create(MainDB, True); // перед Free будет Rollback
{...}

Код


unit IBSQLWTUnit;

interface

uses IBSQL, IBDatabase;

type
  TIBSQLWT = class(TIBSQL) // IBSQL потребляет меньше памяти чем IBQuery
  private                         // но немного урезан по функциональности
    RollbackOnFree: Boolean;
    TransactionNum: Integer;
  public
    constructor Create(inDatabase: TIBDatabase; inRollbackOnFree: Boolean = False); reintroduce;
    destructor Destroy; override;
  end;

implementation

{ Реализация IBSQLWT }

//------------------------------------------------------------------------------

{ Конструктор создаёт и добавляет транзакцию в очередь
  Вход:
     inDatabase - экземпляр TIBDatabase }
constructor TIBSQLWT.Create(inDatabase: TIBDatabase; inRollbackOnFree: Boolean);
begin
  inherited Create(inDatabase);
  RollbackOnFree := inRollbackOnFree;
  Database := inDatabase;
  Transaction :=  TIBTransaction.Create(Database);
  Transaction.AddDatabase(Database);
  TransactionNum := Database.AddTransaction(Transaction);
  Transaction.StartTransaction();
end;


//------------------------------------------------------------------------------

{ Деструктор выполняет подтверждение и уничтожение транзакции }
destructor TIBSQLWT.Destroy;
begin
  if not RollbackOnFree then
    Transaction.Commit()
  else
    Transaction.Rollback();
  Database.RemoveTransaction(TransactionNum);
  Transaction.Free;
  inherited;
end;

end.

Это сообщение отредактировал(а) V0LT - 12.5.2012, 16:00

san46

Дата 12.5.2012, 15:58 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 15
Регистрация: 30.11.2006

Репутация: нет
Всего: нет

Цитата

не люблю я try ... except

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

Это сообщение отредактировал(а) san46 - 12.5.2012, 15:59

V0LT

Дата 12.5.2012, 16:04 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2

всегда пожалуйста smile

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

V0LT

Дата 3.10.2012, 17:01 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2

И снова обновление класса TIBSQLWT smile

Использовать так ... и никак иначе

Код

procedure TForm1.Button1Click(Sender: TObject);
begin
  TIBSQLWT.IterateExecQuery(IBDatabase1,
  'SELECT SHORTNAME FROM LOGINS ORDER BY ID', Iter);
end;

procedure TForm1.Iter(Current: TIBXSQLDA);
begin
  Memo1.Lines.Add(Current.ByName('NAME').AsTrimString);
end;

А тем временем в классе ...

Код

TIBSQLWTProc = procedure(Current: TIBXSQLDA) of object;

class function TIBSQLWT.IterateExecQuery(inDatabase: TIBDatabase;
                                         inQuery: string;
                                         Callback: TIBSQLWTProc;
                                         inRollbackOnFree: Boolean = False): Boolean;
var
  SQLQuery: TIBSQLWT;
begin
  SQLQuery := TIBSQLWT.Create(inDatabase, inRollbackOnFree);
  try
    SQLQuery.SQL.Add(inQuery);
    SQLQuery.ExecQuery;
    while not SQLQuery.Eof do
    begin
      if Assigned(Callback) then Callback(SQLQuery.Current);
      SQLQuery.Next;
    end;
  finally
    FreeAndNil(SQLQuery);
  end;
end;

Это сообщение отредактировал(а) V0LT - 9.10.2012, 11:55

Akella

Дата 3.10.2012, 22:09 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329

Статьи и примеры на русском DevExpress, cxGrid

V0LT

Дата 9.10.2012, 11:55 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2

Исходник класса TIBSQLWT - для выполнения SQL запросов (Firebird)

Это сообщение отредактировал(а) V0LT - 9.10.2012, 11:56

Присоединённый файл ( Кол-во скачиваний: 9 )

uIBSQLWT.pas 4,62 Kb

CynicRus

Дата 1.3.2013, 08:29 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 248
Регистрация: 31.5.2012

Репутация: нет
Всего: 5

Сей модуль был написан мной на Delphi XE, но должен без проблем скомпилироваться в любой другой версии дельфей , для Lazarus+FPC будет необходимо внести небольшие коррективы. Модуль реализует функциональность 'human-like mouse movements', тоесть движения мышью как человеческие. Модуль будет полезен для тех, кто разрабатывает всяческих ботов для игр или интернет казино\покера. Не требует никаких дополнительных модулей кроме Windows.pas.

В архиве собственно юнит и небольшая демка.

Присоединённый файл ( Кол-во скачиваний: 11 )

HumanMouse.zip 94,37 Kb

ЧеловекБорща

Дата 25.6.2013, 19:03 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 94
Регистрация: 5.6.2010

Репутация: нет
Всего: нет

Доброго времени.

Сетевой компонент для работы с HTTP протоколом.
В основу лег довольно простой, без наворотов, Synapse THTTPSend, вместе с этим каждый раз нужно дико нагромождать кода, для тойже отправи TMultipartformdataStream куда-либо, что не айс.
Потому написал для этого наворот.
Естественно, я некоторые вещи улучшил в наследнике(THTTPSendEx).

Основные отличия от оригинала:

Несколько вариаций конструктора класса, которые позволяют задать User-Agent и версию HTTP протокола, по умолчанию используется User-Agent мазилы и HTTP 1.1(В оригинале, HTTP 1.0 и пустой User-Agent)
БОгатое наличие GET/POST вариаций и передаваемых в/из функцию/метод параметров в основном это string, TStrings, TStream, TMultipartformdataStream и все наследуемые от них.
Наличие самописной реализации TMultipartformdataStream, писалось для удобной отправки файлов/данных ну и пара POST-методов с участием этого типа данных.
Наличие событий аналогичных TidHTTP(Indy Project), таких как: OnWorkBegin, OnWork, OnWorkEnd из которых можно получить информацию о передаваемых размерах данных(всего, текущее значение), скорости передачи, остатке времени.
Методы загрузки файлов DownloadFile и DowndloadFileToTemp думаю из названия ясно =)
Функции URLIsAlive(Ответ = 200), URLIsDead(Ответ = 404)
ЧеловекоПонятные свойства IsRedirect, IsSuccessfull, IsntFound в отличии от аналогов(ErrorCode = 301) or (ErrorCode = 302), (ErrorCode = 200), (ErrorCode = 404). В случае IsRedirect в свойстве класса Location будет ссылка перенаправления.
Метод ClearAll, в отличии от стандартного он так же очищает и Cookies класса, т.к. стандартный Clear метод класса этого не делает.
Событие OnSocketStatus, на тот случай если используя THTTPSendEx вам нужно событие THTTPSendEx.Socket.OnStatus ,но т.к. THTTPSendEx его уже занял для реаизации OnWork* событий, то данное событие быстро исправит ситуацию(прототип тот же).

Пока вроде бы все...
В планах реализовать автоматическую поддержку GZIP ну и с Cookies что-то придумать..

Требования к использованию:

Среда разработки Delphi не ниже 2009 версии.
Наличие установленного стандартного набора классов Synapse у меня не альтернатива, а всего лишь некоторое дополнение для уже существующего.

Проект развивается и обитает тут
Предложения, комментарии, критика и исправления - приветствуются на сайте или email.

Это сообщение отредактировал(а) ЧеловекБорща - 25.6.2013, 19:04

Присоединённый файл ( Кол-во скачиваний: 13 )

clHTTPSendEx_0.0.0.8.zip 6,98 Kb

Beltar

Дата 30.10.2013, 22:00 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 627
Регистрация: 11.1.2006

Репутация: 3
Всего: 7

Lines на доске из шестиугольников, зачем и почему оно сделано никто не знает. Для отрисовки использовался сей двиг.

http://www.afterwarp.net/asphyre/files/AsphyreSphinx304.rar

Сырец XE3.

Технически ничего интересного, несложная рисовка с помощью готового DirectX движка, чтобы игра не занимала проц на 100% есть ограничение fps. Алгоритм Дейкстры и самопальный алгоритм определения клика по шестиугольной клетке. Была идея сделать уничтожение нескольких типов фигур, как в Lines 98, но так и не сделано.

Это сообщение отредактировал(а) Beltar - 30.10.2013, 22:05

Присоединённый файл ( Кол-во скачиваний: 5 )

Asphyre_HexLines.rar 122,61 Kb

--------------------

Опытный программист на C++ легко решает любые не существующие в Паскале проблемы. smile

(с) я, хотя может и нет
Пищущий на C++ мужик. Даже если это мужик сидит в написанном на Delphi и жрущем паскалевскую библиотеку билдере.

Beltar

Дата 30.10.2013, 22:01 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 627
Регистрация: 11.1.2006

Репутация: 3
Всего: 7

Сама откомпилированная игра.

Присоединённый файл ( Кол-во скачиваний: 8 )

Release.rar 710,76 Kb

--------------------

Опытный программист на C++ легко решает любые не существующие в Паскале проблемы. smile

CynicRus

Дата 11.4.2014, 11:51 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 248
Регистрация: 31.5.2012

Репутация: нет
Всего: 5

Класс для получения хэндлов с контролов формы, самих окон. Очень часто использую.

Код


unit DTM_HandlePicker;

interface
   uses
    System.Classes,System.SysUtils,Vcl.Controls,Vcl.Graphics,
    Vcl.Forms,Winapi.Windows;
type
 THandlePicker = class
   private
    FHandle: HDC;
    FHasPicked: Boolean;
   public
    property Handle: HDC read FHandle write FHandle;
    property HasPicked: Boolean read FHasPicked write FHasPicked;
    constructor Create;
    procedure Reset;
    procedure Drag;
 end;

implementation

{ THandlePicker }

constructor THandlePicker.Create;
begin
 Reset;
end;

procedure THandlePicker.Drag;
var
  TargetRect: TRect;
  Region : HRGN;
  Cursor : TCursor;
  TempHandle : Hwnd;
  DragForm : TForm;
  EdgeForm : TForm;
  Style : DWord;
  W,H: integer;
const
  EdgeSize =4;
  WindowCol = clred;
begin;
  Cursor:= Screen.Cursor;
  Screen.Cursor:= crCross;
  TempHandle := GetDesktopWindow;
  EdgeForm := TForm.Create(nil);
  EdgeForm.Color:= WindowCol;
  EdgeForm.BorderStyle:= bsNone;


  DragForm := TForm.Create(nil);
  DragForm.Color:= WindowCol;
  DragForm.BorderStyle:= bsNone;
  Style := GetWindowLong(DragForm.Handle, GWL_EXSTYLE);
  SetWindowLong(DragForm.Handle, GWL_EXSTYLE, Style or WS_EX_LAYERED or WS_EX_TRANSPARENT);
  SetLayeredWindowAttributes(DragForm.Handle, 0, 100, LWA_ALPHA);

  try
  while GetAsyncKeyState(VK_LBUTTON) <> 0 do
  begin;

    Handle:= WindowFromPoint(Mouse.CursorPos);
    if (Handle <> TempHandle) and (Handle <> EdgeForm.Handle) then
    begin;
      EdgeForm.Show;
      DragForm.Show;
      GetWindowRect(Handle, TargetRect);
      W :=TargetRect.Right - TargetRect.Left+1;
      H :=TargetRect.Bottom - TargetRect.Top+1;
      DragForm.SetBounds(TargetRect.Left,TargetRect.top,W,H);

      SetWindowRgn(EdgeForm.Handle,0,false);
      Region := CreateRectRgn(0,0,w-1,h-1);
      CombineRgn(Region,Region,CreateRectRgn(EdgeSize,EdgeSize,w-1-(edgesize),h-1-(edgesize)),RGN_XOR);
      SetWindowRgn(edgeform.Handle,Region,true);
      EdgeForm.SetBounds(TargetRect.Left,TargetRect.top,W,H);
      TempHandle  := Handle;
    end;
    Application.ProcessMessages;
    Sleep(30);
  end;
  Handle := TempHandle;
  haspicked:= true;
  Screen.Cursor:= cursor;
  finally
  DragForm.Hide;
  DragForm.Free;
  EdgeForm.Hide;
  EdgeForm.Free;
  end;
end;

procedure THandlePicker.Reset;
begin
  HasPicked:=false;
  Handle:=0;
end;

end.

Как использовать - создаем экземпляр класса, и в обработчике MouseDown - вызываем метод Drag. В свойстве Handle - будет тот хэндл, который мы выделили.

Это сообщение отредактировал(а) CynicRus - 11.4.2014, 13:32

CynicRus

Дата 12.4.2014, 13:55 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 248
Регистрация: 31.5.2012

Репутация: нет
Всего: 5

Только что закончил, класс для создания скриншотов. Умеет снимать с помощью Winapi, DirectX,DirectDraw. Написан на Delphi XE3, проверен в Win7 x32\64.

Код


unit DTM_ImageCatcher;

interface
  uses
   System.Classes,System.SysUtils,Vcl.Controls,Vcl.Graphics,
    Vcl.Forms,Winapi.Windows,Winapi.D3DX9,Direct3D9,DirectDraw;

  type
    TCatchType = (ctWinapi = 0,ctDirectX = 1,ctDDraw);
    TImageCatcher = class
      private
        FBitmap: Vcl.Graphics.TBITMAP;
        FCatchType: TCatchType;
        FTargetHandle: HWND;
        procedure GetTargetRect(out Rect: TRect);
        procedure GetDDrawData();
        procedure GetDirectXData();
        procedure GetWinapiData();
        procedure GetTargetDimensions(out w, h: integer);
        procedure GetTargetPosition(out left, top: integer);
      public
        constructor Create;
        procedure Reset;
        destructor Destroy;override;

        procedure GetScreenShot();
        procedure ActivateTarget;
        property Bitmap: Vcl.Graphics.TBITMAP read FBitmap write FBitmap;
        property CatchType: TCatchType read FCatchType write FCatchType;
        property TargetHandle: HWND read FTargetHandle write FTargetHandle;
    end;
implementation

{ TImageCather }

procedure TImageCatcher.ActivateTarget;
begin
 SetForegroundWindow(TargetHandle);
end;


constructor TImageCatcher.Create;
begin
 Reset;
 FBitmap:=Vcl.Graphics.TBitmap.Create;
 FBitmap.PixelFormat:=pf24bit;
end;

destructor TImageCatcher.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited;
end;

procedure TImageCatcher.GetDDrawData();
var
  DDSCaps: TDDSCaps;
  DesktopDC: HDC;
  DirectDraw: IDirectDraw;
  Surface: IDirectDrawSurface;
  SurfaceDesc: TDDSurfaceDesc;
  x, y, w, h: integer;
begin
  GetTargetDimensions(w, h);
  GetTargetPosition(x, y);
  if DirectDrawCreate(nil, DirectDraw, nil) = DD_OK then
    if DirectDraw.SetCooperativeLevel(GetDesktopWindow, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN or DDSCL_ALLOWREBOOT) = DD_OK then
    begin
      FillChar(SurfaceDesc, SizeOf(SurfaceDesc), 0);
      SurfaceDesc.dwSize := Sizeof(SurfaceDesc);
      SurfaceDesc.dwFlags := DDSD_CAPS;
      SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
      SurfaceDesc.dwBackBufferCount := 0;
      if DirectDraw.CreateSurface(SurfaceDesc, Surface, nil) = DD_OK then
      begin
        if Surface.GetDC(DesktopDC) = DD_OK then
          try
            Bitmap.Width := Screen.Width;
            Bitmap.Height := Screen.Height;
            BitBlt(Bitmap.Canvas.Handle, 0, 0, W, H, DesktopDC, x, y, SRCCOPY);
          finally
            Surface.ReleaseDC(DesktopDC);
          end;
      end;
    end;
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;
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);
  BitBlt(Bitmap.Canvas.Handle, 0, 0, w, h, BMP.Canvas.Handle, x, y, SRCCOPY);
  BMP.Free;
  pSurface.UnlockRect;
end;

procedure TImageCatcher.GetScreenShot();
begin
  case CatchType of
    ctWinapi: GetWinapiData();
    ctDirectX: GetDirectXData();
    ctDDraw: GetDDrawData();
  end;
  SetForegroundWindow(Application.Handle);
end;

procedure TImageCatcher.GetTargetDimensions(out w, h: integer);
var
  Rect: TRect;
begin
  GetTargetRect(rect);
  w := Rect.Right - Rect.Left;
  h := Rect.Bottom - Rect.Top;
end;

procedure TImageCatcher.GetTargetPosition(out left, top: integer);
var
  Rect: TRect;
begin
  GetTargetRect(rect);
  left := Rect.Left;
  top := Rect.Top;
end;

procedure TImageCatcher.GetTargetRect(out Rect: TRect);
begin
  GetWindowRect(TargetHandle, Rect);
end;

procedure TImageCatcher.Reset;
begin
  CatchType := ctWinapi;
  TargetHandle := 0;
end;

procedure TImageCatcher.GetWinapiData();
var
  hWinDC: THandle;
  w, h: integer;
begin
  GetTargetDimensions(w, h);
  hWinDC := GetWindowDC(TargetHandle);
  Bitmap.Width := w;
  Bitmap.Height := h;
  hWinDC := GetWindowDC(TargetHandle);
  BitBlt(Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, hWinDC, 0, 0, SRCCOPY);
  ReleaseDC(TargetHandle, hWinDC);
end; 

end.

Как использовать:
Создать экземляр класса, скормить в TargetHandle - HWND требуемого окна,выставить режим снятия скриншота(ctWinapi,ctDDraw,ctDirectX), затем при нажатии кнопки выполнить метод класса ActivateClient; После GetScreenShot; и в поле Bitmap будет находится скрин окна.
Внимание:
Использовать режим ctDDraw Только для снятия скрина с видеоплееров и т.д. С простыми окнами оно не будет работать как надо.

Это сообщение отредактировал(а) CynicRus - 12.4.2014, 15:15

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »