Модераторы: Poseidon, Snowy, bems, MetalFan

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Арсенал форумистов, Выкладывайте свои работы! 
:(
    Опции темы
p0s0l
Дата 15.4.2004, 00:04 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Г-н Посол
****


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

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



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

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

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



--------------------
С уважением, г-н Посол.
PM   Вверх
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
PM MAIL ICQ   Вверх
san46
Дата 12.5.2012, 11:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

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



Цитата
Простой класс для работы с базой Firebird
Да, неплохо. А если надо откатить транзакцию, то как это делается с применением представленного класса?
PM MAIL   Вверх
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
PM MAIL ICQ   Вверх
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
PM MAIL ICQ   Вверх
san46
Дата 12.5.2012, 15:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



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

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



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

Это сообщение отредактировал(а) san46 - 12.5.2012, 15:59
PM MAIL   Вверх
V0LT
Дата 12.5.2012, 16:04 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


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

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



всегда пожалуйста smile 
... я думаю было бы полезно обмениваться не только громоздкими исходниками новейших классов, но и различными надстройками над классами 
PM MAIL ICQ   Вверх
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
PM MAIL ICQ   Вверх
Akella
Дата 3.10.2012, 22:09 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


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

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



PM MAIL   Вверх
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
PM MAIL ICQ   Вверх
CynicRus
Дата 1.3.2013, 08:29 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


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

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



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

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

Присоединённый файл ( Кол-во скачиваний: 10 )
Присоединённый файл  HumanMouse.zip 94,37 Kb
PM MAIL   Вверх
ЧеловекБорща
  Дата 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), таких как: OnWorkBeginOnWorkOnWorkEnd из которых можно получить информацию о передаваемых размерах данных(всего, текущее значение), скорости передачи, остатке времени.
  • Методы загрузки файлов 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
PM MAIL   Вверх
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 и жрущем паскалевскую библиотеку билдере.
PM MAIL   Вверх
Beltar
Дата 30.10.2013, 22:01 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


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

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



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

Присоединённый файл ( Кол-во скачиваний: 8 )
Присоединённый файл  Release.rar 710,76 Kb


--------------------
Опытный программист на C++ легко решает любые не существующие в Паскале проблемы. smile(с) я, хотя может и нет
Пищущий на C++ мужик. Даже если это мужик сидит в написанном на Delphi и жрущем паскалевскую библиотеку билдере.
PM MAIL   Вверх
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
PM MAIL   Вверх
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
PM MAIL   Вверх
Google
  Дата 21.5.2019, 06:33 (ссылка)  





  Вверх
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Общие вопросы"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи


Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.

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


 




[ Время генерации скрипта: 0.1737 ]   [ Использовано запросов: 23 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.