Захват скриншота точно по границе окна.

[Sharfik]

Так как-бы именно это я и сделал ...

У меня лежит Gear 360 она делает снимок с двух камер, который потом обрабатывается и специальная программа может сделать обзор круговой. Формат как бы общепринятый jpg, но в Windows штатный просмотровщик фоток пока не может крутить и сшивать. Только если это видео, а фотки облом. В будущем, я бы обратился чтобы кто то помог сделать такой компонент для просмотра. Сейчас, если интересно, могу только образец файлов дать(просто увидел тему близкую к идее).

[Alex2013]

Давай, посмотрю !
А сфера под текстуру генерируется очень просто...

Код: Выделить всё

//  Function to Create a sphere
procedure CreateSphere(CX, CY, CZ, Radius : glFloat;
          N: Integer; NDX, NDY:Single; var SphereDL:GlInt );
// N = precision
var I, J ,N2: Integer;
    theta1,theta2,theta3 : glFloat;
    X, Y, Z, px, py, pz : glFloat;
begin
  SphereDL :=glGenLists(1);
  glNewList(SphereDL, GL_COMPILE);

    if Radius < 0 then Radius :=-Radius;
    if n < 0 then n := -n;
    if (n < 4) OR (Radius <= 0) then
    begin
      glBegin(GL_POINTS);
        glVertex3f(CX, CY, CZ);
      glEnd();
      exit;
    end;

    for J :=0 to N DIV 2 -1 do
    begin
      theta1 := (J*2*PI/N - PI/2) /ndy;
      theta2 := ((J+1)*2*PI/n - PI/2)  /ndy;;
      glBegin(GL_QUAD_STRIP);

  For I :=N downto 0 do
        begin
          theta3 := (i*2*PI/N)/NDX;
          x := cos(theta2) * cos(theta3);
          y := sin(theta2);
          z := cos(theta2) * sin(theta3);
          px := CX + Radius*x;
          py := CY + Radius*y;
          pz := CZ + Radius*z;

  //        glNormal3f(X, Y, Z);
          glTexCoord2f(1-I/n, 2*(J+1)/n);
          glVertex3f(px,py,pz);

          X := cos(theta1) * cos(theta3);
          Y := sin(theta1);
          Z := cos(theta1) * sin(theta3);
          px := CX + Radius*X;
          py := CY + Radius*Y;
          pz := CZ + Radius*Z;

  //        glNormal3f(X, Y, Z);
          glTexCoord2f(1-i/n, 2*j/n);
          glVertex3f(px,py,pz);
        end;
      glEnd();
    end;
  glEndList();
end;


CX, CY, CZ - Центр
Radius - ясный пень Радиус
N - число вершин решётки 40-50 достаточно .
NDX, NDY - моя модификация "кривизна" 1.0,1.0 полная сфера если больше сегмент разной конфигурации
SphereDL - ID-шник дисплейного списка

Текстура накладывается без проблем ...
procedure AAA0( Tex : integer);
begin
glEnable(GL_TEXTURE_2D);
glBindTexture(GL_TEXTURE_2D, Tex);
glCallList(BK_Sphere);
glDisable(GL_TEXTURE_2D);
end;
BK_Sphere - ID-шник дисплейного списка сферы

Создание текстуры тоже проще не бывает

Код: Выделить всё

function  LoadTextureBMP(const FileName: String ): GLuint;
var
  i, j: Integer;
  bmp: TBitmap;
    texID : GLuint;
begin
  bmp := TBitmap.Create;
  try

    bmp.LoadFromFile(FileName); // Загрузка рисунка в битовую матрицу.
    // Создадим текстуру
       glEnable(GL_TEXTURE_2D);
       glGenTextures( 1, @texID );
       glBindTexture( GL_TEXTURE_2D, texID );
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);

       glTexImage2D(GL_TEXTURE_2D, 0, 3, bmp.Width,  bmp.Height,
       0, GL_BGR_EXT,GL_UNSIGNED_BYTE, bmp.RawImage.Data);

       gluBuild2DMipmaps (GL_TEXTURE_2D, GL_RGB, bmp.Width, bmp.Height,
          GL_BGR_EXT, GL_UNSIGNED_BYTE,bmp.RawImage.Data);

  finally
    Result := texID;
    bmp.Free; // По окончанию не забыть удалить битовую матрицу.
  end;
end;


*Удаляется перед загрузкой новой через glDeleteBuffers(1,@texID);

Добавлено спустя 7 часов 1 минуту 31 секунду:
Зы
Полная версия создания текстуры ...

Код: Выделить всё

procedure AAA0( Tex : integer);
  begin
   glEnable(GL_TEXTURE_2D);
glPixelStorei(GL_UNPACK_ALIGNMENT, 1);
glTexParameteri ( GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR );
glTexParameteri ( GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR );
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT); // Спасибо тов. Cheb's
   glBindTexture(GL_TEXTURE_2D, Tex);
   glCallList(BK_Sphere);
   glDisable(GL_TEXTURE_2D);
  end;



[Sharfik]

Давай, посмотрю !

https://disk.yandex.ru/d/iQcdlxRfW5lFKw?w=1
Три примера залил в облако
*Можно самому через "google просмотровщик улиц", но там их серверве склеивает много обычных фото и не всегда удачно.

[Alex2013]

28994ART004_500.jpg

Не идеально но работает . (Можно еще кривизну по оси Y подкрутить... )
В общем качай мою техно-демку и пробуй сам.

[Sharfik]

Я в этой теме не увидел ссылок на исходники, подумал что "свое дорогое" и не стал наглеть.
Где искать?

**Увидел мячик, подумал что можно предложить домохозяйкам мебель расставлять)))

[Alex2013]

Исходники не выкладываю не из за "коммерческой тайны " просто их в текущем виде выкладывать смысла нет ... Вот например мой "рендер сцены", монго-ли с этого "спагетти кода" проку?
(Кстати все самые интересные модули load3e, OBJLoader, unit6... я так или иначе выкладывал на форуме)

Код: Выделить всё

unit my_Renderer;
    {$mode Delphi}{$H+}
interface

uses
Windows,SysUtils,FileUtil, Classes,
Math3D, Graphics, Controls,ExtCtrls,
GL,GLExt, glu,  load3e, OBJLoader,unit6;

  type
   TGLTexture = record
    Height: Integer;
    Width: Integer;
    Data: array of Byte;
  end;
  const
  FPS: Single = 0;

  // Кривизна ФС
  R_BK_SphereCurve  : Boolean= False;
  R_BK_SphereCurveX : Single = 3.0;
  R_BK_SphereCurveY : Single = 3.0;

  //Радиус ФС
  R_BK_SphereR : integer = 50;

  //Поворот ФС
  R_BK_SphereRX : integer = 0;
  R_BK_SphereRY : integer = 0;
  R_BK_SphereRZ : integer = 0;
  //OffsetKvaziStereo
  R_BK_SphereOffsetKvaziStereo : Boolean= False;
  R_BK_SphereOffsetKvaziStereoSet :Single=0.0;


  ViewSHA:Boolean= True;    // Флаг показа схемы
  rLoadObj:Boolean= False;  // Флаг загрузки Obj
  VirtScreen:Boolean= True;    // Флаг Вирт Экрана 1
  VirtScreen_2:Boolean= False; // Флаг Вирт Экрана 2
  Crosshairs:Boolean = False;  // Флаг "Прицела"
  VR_MK_Ctrl:Boolean = False;  // Флаг включения контроля для ВиАр
  VR_Run:Boolean = False;      // Флаг вкюльченного Vr рендера
                               //*(сйчас неиспользуется)
  rCapture:Boolean = False;    // Флаг захавата
  rT_GUI_1:Boolean = False;    // Флаг эмуляции GUI
  rT_GUI_Set: integer=20;      // Прозрачность для эмуляции GUI
  R_Stereo:Boolean = False;    // Флаг SВS режима
  R_BK_Sphere:Boolean = False; // Флаг вклюьчения сферического фона.
  R_BK_Capture:Boolean = False;// Флаг захвата для сферического фона.
// VR_GetSelect:Boolean = False;
  M_X:Real=0;
  M_Y:Real=0;
  M_Z:Real=0;
  v_x : integer=0;
  v_y : integer=0;
  R_W : integer=500;
  R_H : integer=300;
  BK_Sphere:GlInt=-1;

  FRender:Byte=0;
   FR_L=1;
   FR_R=2;
   FR_W=0;
  CMIN = -3;
  CMAX = 3;
  MS_X:Real=0;
  MS_Y:Real=0;
  MS_Z:Real=0;
  Tbmp: TBitmap = nil;
  Tbmp_2: TBitmap = nil;
  SBK_bmp: TBitmap = nil;
  TbmpRL: TBitmap = nil;
  TbmpR: TBitmap = nil;
  TbmpL: TBitmap = nil;
  T_I : TImage  = nil;

  var
  VR_ViewS, VR_ProjS: TMatrix4f;
  viewport00 : array[0..3] of integer;
  ScreenWidth, ScreenHeight: glInt; //Переменные в которых будут храниться размеры экрана
  WorldX,WorldY,WorldZ,WorldA : glInt; //Мировые координаты
  WorldX_on,WorldY_on,WorldZ_on : glInt; //Признак вращения вокруг оси
  WorldWidth, WorldHeight, WorldDepth : glInt;
  CameraX,CameraY,CameraZ,CameraA,CameraTargetX,CameraTargetY,CameraTargetZ: GLFloat; //Камера координаты
  CameraX2,CameraY2,CameraZ2,CameraA2,CameraTargetx2,CameraTargetY2: GLFloat; //Камера координаты
  CameraX_on,CameraY_on,CameraZ_on : glInt; //Признак вращения вокруг оси
  DuloA, VetryakA : glInt; //Угол на который поднято/опущено дуло танка
  TankX,TankY,TankZ,TankA,TankSpeed : GLFloat;

  s : PChar; //Переменная для хранения кода нажатой клавиши

  Ground,Sky, TankBase,TankDulo,Tank,grass, kolodec,stone,vetryak,truba : glInt;


//Procedure NoVRRender;
Procedure MyRender(var BaseA: Single;mode : GLEnum; m3d:boolean);
procedure DrawLine(Var BB:TBitmap; x1,y1, x2,y2: Integer;C:Integer );
Function BitmapTest(var TB:TBitmap; Mode:TPixelFormat;
   F_Free:Boolean=true):Boolean ;
Procedure RGR2BGR(Var Bitmap: TBitmap);


implementation
uses vr;


{}


procedure InitRenderer;

var
  I, J, K: Integer;

begin
  glClearColor(0, 0, 0.2, 1);
end;

var
MM1,MM2,MM3,MM4:glInt;



procedure MirrorVert(Const Src: TBitmap);
var dest:TBitmap;
    w,h,x,y:integer;
    pd,ps:pbytearray;
begin
  w:=Src.width;
  h:=Src.height;
  dest:=TBitmap.Create;
  dest.SetSize(w,h);
  dest.pixelformat:=pf24bit;
  //Src.pixelformat:=pf24bit;
  for y:=0 to h-1 do begin
   dest.BeginUpdate(False);
   pd:=dest.scanline[y];
   ps:=Src.scanline[h-1-y];
   for x:=0 to w-1 do begin
     pd[x*3]:=ps[x*3];
     pd[x*3+1]:=ps[x*3+1];
     pd[x*3+2]:=ps[x*3+2];
     end;
   dest.EndUpdate(False);
   end;
  Src.assign(dest);
  dest.free;
end;

// Загрузка текстур из файла.
// Негатив 2

Procedure RGR2BGR(Var Bitmap: TBitmap);
Type
RGB1=Record  b,g,r  : byte; end;
var
X, Y: Integer;
PixelPtr: PInteger;
PixelRowPtr: PInteger;
BytePerPixel: Integer;
BW:Byte;
PRGB:^RGB1;
begin
try
   Bitmap.BeginUpdate(False);
   PixelRowPtr := PInteger(Bitmap.RawImage.Data);
   BytePerPixel := Bitmap.RawImage.Description.BitsPerPixel div 8;
   for Y := 0 to Bitmap.Height - 1 do begin
     PixelPtr := PixelRowPtr;
     for X := 0 to Bitmap.Width - 1 do begin
      PRGB:=Pointer(PixelPtr);
      With PRGB^ do begin
       bw:=R; R:=B;  B:= BW;
      ///R:=not r; G:=not g; B:=not b ;
                    end;
       Inc(PByte(PixelPtr), BytePerPixel);
     end;
     Inc(PByte(PixelRowPtr),Bitmap.RawImage.Description.BytesPerLine);
   end;
finally
   Bitmap.EndUpdate(False);
end;
end;

Function BitmapTest(var TB:TBitmap; Mode:TPixelFormat;
   F_Free:Boolean=true):Boolean ;
   Var
   CB:TBitmap;
   Begin
    Result:= tb.PixelFormat=mode ;
   if not Result then
   begin
   CB:=TBitmap.Create;
   cb.PixelFormat:=Mode;
   cb.SetSize(tb.Width,tb.Height);
   Cb.Canvas.Draw(0,0,TB);
   if F_Free then tb.free;
   Tb:=CB;
   end
   end;

Function InR(AA,B,C:Longint):Boolean;
begin
InR:=((AA>=B) And (AA<=C));
End;


function  LoadTextureBMP(const FileName: String ): GLuint;
var
  i, j: Integer;
  bmp: TBitmap;
    texID : GLuint;
begin
  bmp := TBitmap.Create;
  try

    bmp.LoadFromFile(FileName); // Загрузка рисунка в битовую матрицу.
    //BitmapTest(bmp,Pf24bit); RGR2BGR(bmp);
    // Создадим текстуру
       glEnable(GL_TEXTURE_2D);
       glGenTextures( 1, @texID );
       glBindTexture( GL_TEXTURE_2D, texID );
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
       glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);

       glTexImage2D(GL_TEXTURE_2D, 0, 3, bmp.Width,  bmp.Height,
       0, GL_BGR_EXT,GL_UNSIGNED_BYTE, bmp.RawImage.Data);

       gluBuild2DMipmaps (GL_TEXTURE_2D, GL_RGB, bmp.Width, bmp.Height,
          GL_BGR_EXT, GL_UNSIGNED_BYTE,bmp.RawImage.Data);

  finally
    Result := texID;
    bmp.Free; // По окончанию не забыть удалить битовую матрицу.
  end;
end;

(**)
Const
    texID1 : GLuint=0;
    texID2 : GLuint=0;
    texID3 : GLuint=0;

       OW1 : GLuint=0;
       OH1 : GLuint=0;

       OW2 : GLuint=0;
       OH2 : GLuint=0;

       OW3 : GLuint=0;
       OH3 : GLuint=0;

      FST1:Boolean= True;
      FST2:Boolean= True;
      FST3:Boolean= True;

function  CapTextureBMP(Var T_bmp:Tbitmap; var  texID : GLuint;
   var OW : GLuint; var OH : GLuint;Var FST:Boolean;RW,RH: GLuint ): GLuint;
//  Const
   //bmp: TBitmap =Nil;

begin
try
if (T_bmp = nil) then  Exit;


if FST or (( OW <> RW) or (OH <>RH)) then begin
if not FST then  glDeleteBuffers(1,@texID);
FST:=False;
glEnable(GL_TEXTURE_2D);
  glGenTextures( 1, @texID );
  glBindTexture( GL_TEXTURE_2D, texID );
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);

  glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB,
                  T_bmp.Width , T_bmp.Height,
                  0, GL_RGB, GL_UNSIGNED_BYTE, nil
                  );

  glDisable(GL_TEXTURE_2D);
end ;



glEnable(GL_TEXTURE_2D);

glBindTexture( GL_TEXTURE_2D, texID );
glPixelStorei(GL_UNPACK_ALIGNMENT, 1);
glPixelStorei(GL_UNPACK_ROW_LENGTH,t_bmp.Width);

glTexSubImage2D ( GL_TEXTURE_2D, 0, 0, 0,
T_bmp.Width, T_bmp.Height,
       GL_BGR
        , GL_UNSIGNED_BYTE, T_bmp.RawImage.Data );

glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
glDisable(GL_TEXTURE_2D);


  finally
    Result := texID;
    OW:=RW; oh:=RH;
  end;

  end;

{----------------------------}

var
Scale : glfLoat;  // X, Y, Z extents;

Texture1  : GLuint;
Texture2  : GLuint;
Texture3  : GLuint;
Texture4  : GLuint;
Texture5  : GLuint;
Texture6  : GLuint;

M :TModel ;

procedure GetMinMax(var M : TModel);
var MinC, MaxC : TCoord;
     I : Integer;
begin
   FillChar(MinC, 3, 0);
   FillChar(MaxC, 3, 0);

   // Find the min and max in each coordinate system
   with M do
   begin
     For I :=1 to Vertices do
     begin
       if Vertex[I].X < MinC.X then MinC.X := Vertex[I].X
       else if Vertex[I].X > MaxC.X then MaxC.X := Vertex[I].X;

       if Vertex[I].Y < MinC.Y then MinC.Y := Vertex[I].Y
       else if Vertex[I].Y > MaxC.Y then MaxC.Y := Vertex[I].Y;

       if Vertex[I].Z < MinC.Z then MinC.Z := Vertex[I].Z
       else if Vertex[I].Z > MaxC.Z then MaxC.Z := Vertex[I].Z;
     end;
   end;

   // find the max distance between the min and max
   MaxC.X :=(MaxC.X - MinC.X);
   MaxC.Y :=(MaxC.Y - MinC.Y);
   MaxC.Z :=(MaxC.Z - MinC.Z);

   // Let scale = Max distance
   if MaxC.X > MaxC.Y then
     Scale :=MaxC.X
   else
     Scale :=MaxC.Y;
   if Scale > MaxC.Z then
     Scale :=MaxC.Z
end;

//  Function to Create a sphere
//----------------------------------
procedure CreateSphere(CX, CY, CZ, Radius : glFloat;
          N: Integer; NDX, NDY:Single; var SphereDL:GlInt );
// N = precision
var I, J ,N2: Integer;
    theta1,theta2,theta3 : glFloat;
    X, Y, Z, px, py, pz : glFloat;
begin
  SphereDL :=glGenLists(1);
  glNewList(SphereDL, GL_COMPILE);

    if Radius < 0 then Radius :=-Radius;
    if n < 0 then n := -n;
    if (n < 4) OR (Radius <= 0) then
    begin
      glBegin(GL_POINTS);
        glVertex3f(CX, CY, CZ);
      glEnd();
      exit;
    end;

    for J :=0 to N DIV 2 -1 do
    begin
      theta1 := (J*2*PI/N - PI/2) /ndy;
      theta2 := ((J+1)*2*PI/n - PI/2)  /ndy;;
      glBegin(GL_QUAD_STRIP);

  For I :=N downto 0 do
        begin
          theta3 := (i*2*PI/N)/NDX;
          x := cos(theta2) * cos(theta3);
          y := sin(theta2);
          z := cos(theta2) * sin(theta3);
          px := CX + Radius*x;
          py := CY + Radius*y;
          pz := CZ + Radius*z;

  //        glNormal3f(X, Y, Z);
          glTexCoord2f(1-I/n, 2*(J+1)/n);
          glVertex3f(px,py,pz);

          X := cos(theta1) * cos(theta3);
          Y := sin(theta1);
          Z := cos(theta1) * sin(theta3);
          px := CX + Radius*X;
          py := CY + Radius*Y;
          pz := CZ + Radius*Z;

  //        glNormal3f(X, Y, Z);
          glTexCoord2f(1-i/n, 2*j/n);
          glVertex3f(px,py,pz);
        end;
      glEnd();
    end;
  glEndList();
end;



procedure InitScene;
  var AT:TGLTexture;
  begin

    Texture1 :=   LoadTextureBMP ('dataL1.bmp');// tex2.tga
    Texture2 :=   LoadTextureBMP ('dataR1.bmp');

   M :=LoadModel('soccerball.obj');

    GetMinMax(M);
  end;

procedure AAA0( Tex : integer);
  begin
   glEnable(GL_TEXTURE_2D);
//glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
//glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
glPixelStorei(GL_UNPACK_ALIGNMENT, 1);
glTexParameteri ( GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR );
glTexParameteri ( GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR );
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
   glBindTexture(GL_TEXTURE_2D, Tex);
   glCallList(BK_Sphere);
   glDisable(GL_TEXTURE_2D);
  end;


  procedure AAA1( Tex : integer);
  begin
   glEnable(GL_TEXTURE_2D);
    glBindTexture(GL_TEXTURE_2D, Tex);

    glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL);
    glBegin(GL_QUADS);
    glTexCoord2f(0, 1);  glVertex3f( -2.0*2,  2.0,  2.0*2); // 1
    glTexCoord2f(0, 0);  glVertex3f( -2.0*2, -2.0,  2.0*2); // 2
    glTexCoord2f(1, 0);  glVertex3f(  2.0*2, -2.0,  2.0*2); // 3
    glTexCoord2f(1, 1);  glVertex3f(  2.0*2,  2.0,  2.0*2); // 4
    glEnd();
  glDisable(GL_TEXTURE_2D);
  end;

  procedure AAA4( Tex : integer);
  begin
   glEnable(GL_TEXTURE_2D);
    glBindTexture(GL_TEXTURE_2D, Tex);
    glPixelStorei(GL_UNPACK_ALIGNMENT, 1);
glTexParameteri ( GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR );
glTexParameteri ( GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR );
    glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL);
    glBegin(GL_QUADS);

    if R_Stereo and (FRender in [1,2])then
     begin
    if FRender = 1 then begin
    glTexCoord2f(0, 1);  glVertex3f( -2.0*2,  2.0,  2.0*2); // 1
    glTexCoord2f(0, 0);  glVertex3f( -2.0*2, -2.0,  2.0*2); // 2
    glTexCoord2f(0.5, 0);  glVertex3f(  2.0*2, -2.0,  2.0*2); // 3
    glTexCoord2f(0.5, 1);  glVertex3f(  2.0*2,  2.0,  2.0*2); // 4
    glEnd();

     end else begin
    glTexCoord2f(0.5, 1);  glVertex3f( -2.0*2,  2.0,  2.0*2); // 1
    glTexCoord2f(0.5, 0);  glVertex3f( -2.0*2, -2.0,  2.0*2); // 2
    glTexCoord2f(1, 0);  glVertex3f(  2.0*2, -2.0,  2.0*2); // 3
    glTexCoord2f(1, 1);  glVertex3f(  2.0*2,  2.0,  2.0*2); // 4
    glEnd();

     end
     end
     else begin


    glTexCoord2f(0, 1);  glVertex3f( -2.0*2,  2.0,  2.0*2); // 1
    glTexCoord2f(0, 0);  glVertex3f( -2.0*2, -2.0,  2.0*2); // 2
    glTexCoord2f(1, 0);  glVertex3f(  2.0*2, -2.0,  2.0*2); // 3
    glTexCoord2f(1, 1);  glVertex3f(  2.0*2,  2.0,  2.0*2); // 4
    glEnd();
   end;


    glDisable(GL_BLEND);

    glDisable(GL_TEXTURE_2D);
  end;

procedure AAA5( Tex : integer);
begin
glEnable(GL_TEXTURE_2D);

glEnable(GL_BLEND);

glBindTexture(GL_TEXTURE_2D, Tex);

if rT_GUI_1 then begin
glBlendFunc (GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
glShadeModel (GL_FLAT);
glColor4f(0.4,0.5 ,0.4,1-rT_GUI_Set/100);
end;

   glBegin(GL_QUADS);
    glTexCoord2f(0, 1);  glVertex3f( -2.0*2,  2.0,  2.0*2); // 1
    glTexCoord2f(0, 0);  glVertex3f( -2.0*2, -2.0,  2.0*2); // 2
    glTexCoord2f(1, 0);  glVertex3f(  2.0*2, -2.0,  2.0*2); // 3
    glTexCoord2f(1, 1);  glVertex3f(  2.0*2,  2.0,  2.0*2); // 4
  glEnd();

  glDisable(GL_BLEND);
  glDisable(GL_TEXTURE_2D);


  end;

  procedure AAA2( Tex : integer);
  begin

    glBindTexture(GL_TEXTURE_2D, Tex);
    glBegin(GL_QUADS);


    glTexCoord2f(0, 1);  glVertex3f( -2.0,  2.0,  4.0); // 1
    glTexCoord2f(0, 0);  glVertex3f( -2.0, -2.0,  4.0); // 2
    glTexCoord2f(1, 0);  glVertex3f(  2.0, -2.0,  4.0); // 3
    glTexCoord2f(1, 1);  glVertex3f(  2.0,  2.0,  4.0); // 4
    glEnd();
  end;
  { viewport to world coordinates translation }
  procedure v2w0( vx, vy : integer; var wx, wy, wz : real);
  var
     viewport : array[0..3] of integer;
     modelview : array[0..15] of real;
     var x, y, z : real;
     projection : array[0..15] of real;

  begin
     glGetDoublev(GL_MODELVIEW_MATRIX, @modelview);     //get the modelview info
     glGetDoublev(GL_PROJECTION_MATRIX, @projection); //get the projection matrix info
     glGetIntegerv(GL_VIEWPORT, @viewport);           //get the viewport info

    gluUnProject(vx, viewport[3]-vy-1, 0,
       @modelview, @projection, @viewport, @wx, @wy, @wz);
  end;

   procedure v2w( vx, vy : integer; var wx, wy, wz : real);
  var
     viewport : array[0..3] of integer;
     modelview : array[0..15] of real;
     var x, y, z : real;
     projection : array[0..15] of real;
     Const
//       GLdouble projection[16]={8.77, 0, 0, 0, 0, 8.77, 0, 0, 0, 1, -1, 0, 0, 0, 0};
     GLdouble: array[0..15] of real=(8.77, 0, 0, 0, 0, 8.77, 0, 0, 0, 1, -1, 0, 0, 0, 0,0);

  begin
     glGetDoublev(GL_MODELVIEW_MATRIX, @modelview);     //get the modelview info
     glGetDoublev(GL_PROJECTION_MATRIX, @projection); //get the projection matrix info
     glGetIntegerv(GL_VIEWPORT, @viewport);           //get the viewport info

    if FRender=FR_W then    begin
    gluUnProject(vx, viewport[3]-vy-1, 0,
       @modelview, @projection, @viewport, @wx, @wy, @wz);
    MS_X:=Wx;    MS_y:=Wy;    MS_z:=Wz;
    end
    else
     begin
    //   gluUnProject(vx, viewport00[3]-vy-1, 0,
     //  @VR_viewS, @VR_ProjS, @viewport00, @wx, @wy, @wz);

      gluUnProject(vx, viewport00[3]-vy-1, 0,
       @modelview, @projection, @viewport, @wx, @wy, @wz);
     Wx:=WX+abs(MS_X-WX);WY:=WY+MS_Y-WY; Wz:=Wz-abs(Wz-MS_z);
     end;
  end;

   Const
   // Lighting
  LightPos : Array[0..3] of glFloat = ( 0.0, 4.0, 6.0, 1.0);   // Light Position
  LightAmb : Array[0..3] of glFloat = ( 0.2, 0.2, 0.2, 1.0);   // Ambient Light Values
  LightDif : Array[0..3] of glFloat = ( 0.6, 0.6, 0.6, 1.0);   // Diffuse Light Values
  LightSpc : Array[0..3] of glFloat = ( 0.1, 0.1, 0.1, 1.0);   // Specular Light Values
  xAngle :Single=0;
  xSpeed:Single=0.25;
  yAngle:Single=0;
  ySpeed:Single=0.25;

Procedure MyRender(var BaseA: Single;mode : GLEnum; m3d:boolean);
  const
    TS:TStringList=nil;
    TS2:TStringList=nil;

  CL:TM_RGB=(R:1;G:0;B:1);
  CR:TM_RGB=(R:0;G:1;B:0);
  CL1:TM_RGB=(R:0.7;G:0.8;B:0.1);
  CR1:TM_RGB=(R:0.2;G:0.7;B:0.1);
  SHintOld: LongInt=-1;
  SF_BL: Boolean = False;
var
   vx, vy : integer;
   X1,Y1,Z1,X2,Y2,Z2:Real;
   MyQuadratic :   PGLUquadric;
begin
// Texture4:=-1;
  //Иницализация для модуля Load3e
   if ts=nil then begin
    InitScene;
     Load3eInit;

      if  m3d then  begin // Модель
      TS:=TStringList.Create;
        TS.LoadFromFile('TOR.ASC');
        load3e.ParsingSL( TS, TS);
        MM1:= GenList_OGL_DrawLoad3e(0,0,0);
        TS.Free;
        ///MM2:= GenList_OGL_LoadSHA_Test01('datatest.txt',0,0,0,100);

        //Мерцание шестиренки отключено
        TS:=TStringList.Create;
         TS.LoadFromFile('HILO.ASC');
         load3e.ParsingSL( TS, TS);
       if FRender= FR_L  then  M_RGB:=CL else M_RGB:=cr;
         MM2:= GenList_OGL_DrawLoad3e(2,2.8,1);
        TS.Free;

        //Мерцание шестиренки
        TS:=TStringList.Create;
        TS.LoadFromFile('HILO.ASC');//'TOR.ASC'
        load3e.ParsingSL( TS, TS);

        end;

       // Загрузка схемы
         TS2:=TStringList.Create;
         TS2.LoadFromFile('datatest.txt');
         MM3:=-1;

        end;

   // Создать текстуру и диспленый список для фоновой сферы
    If R_BK_Sphere and (BK_Sphere = -1) then begin
          glDeleteBuffers(1,@Texture6);
          BitmapTest(SBK_bmp,pf24bit);
          //MirrorVert(SBK_bmp); // ??
          ow3:=-1;
          Texture6:=CapTextureBMP(SBK_bmp,texID3 ,ow3,oh3,FST3,
                                SBK_bmp.Width,SBK_bmp.Height);
      if  R_BK_SphereCurve then
       CreateSphere(0,0,0,R_BK_SphereR,48,R_BK_SphereCurveX,
                          R_BK_SphereCurveY,BK_Sphere )
        else
          CreateSphere(0,0,0,R_BK_SphereR ,48,1,1,BK_Sphere );;
      end;
   //============================

IF mode=gl_render then  begin
// Отимзация
If  SHintOld <> SHint then  begin // Модель
//  SF_BL :=F_BL;F_BL:=True;
  if MM3<>-1 then  glDeleteLists(MM3,1);
    MM3:=glGenLists(10000);
     glNewList (MM3, GL_COMPILE);//_AND_EXECUTE Создаем новый список
          modeX :=GL_Render;;
          Draw_OGL_LoadSHA_Test01(0,0,0,100,TS2);
       glEndList();

   // F_BL:= SF_BL;

   SHintOld := SHint;
end;

   if FRender= FR_L  then  M_RGB:=CL else M_RGB:=cr;

  if  m3d then  begin  //!!! Внешняя модель

    glPushMatrix();
      glTranslatef(-2,1.5,-1);
      glRotatef((pi/180)*90+BaseA*100,1.0,0.0,0.0);
      glCallList(MM1);
     glPopMatrix();

   glPushMatrix();
     glTranslatef(0,1.5,0);
     glScalef(0.5,0.5,0.5);
     glRotatef( BaseA*100, 0,1.0, 0);
     glRotatef(90,1.0,0.0,0.0);

     if F_BL then
     OGL_DrawLoad3e(2,2.8,1) else glCallList(MM2);

     glPopMatrix();
    end;

//Прицел ----------------------------
  if   Crosshairs  then begin
    glPushMatrix();
    glLoadIdentity();
         glColor3f(1,0 ,0);
    glBindTexture(GL_TEXTURE_2D,3);
    glBlendFunc(GL_ONE,GL_SRC_ALPHA);
    glEnable(GL_BLEND);
    //===========================
    glTranslatef(0.0,0.0,-0.1);
    glBegin( GL_LINE_STRIP  );
       glVertex3f(-0.005,0.0,0);
       glVertex3f(0.005,0.0,0);
      GlEnd();
     glBegin( GL_LINE_STRIP  );
       glVertex3f(0.0,-0.005,0);
       glVertex3f(0.0,0.005,0);
      glEnd();
    glDisable(GL_BLEND);
    glPopMatrix();

//Курсор Мыши в ВиАр
    glPushMatrix();
    glLoadIdentity();
    glColor3f(1,1 ,0);
    glBindTexture(GL_TEXTURE_2D,3);
    glBlendFunc(GL_ONE,GL_SRC_ALPHA);
    glEnable(GL_BLEND);


   v2w(v_x,v_y,m_x,m_y,m_z);

    glTranslatef(m_x,m_y,m_z{-0.1});
    glBegin( GL_LINE_STRIP  );
       glVertex3f(-0.005,0.0,0);
       glVertex3f(0.005,0.0,0);
      GlEnd();
     glBegin( GL_LINE_STRIP  );
       glVertex3f(0.0,-0.005,0);
       glVertex3f(0.0,0.005,0);
      glEnd();
    glDisable(GL_BLEND);
    glPopMatrix();
{\\\\  }

   end;
end;
   //if FRender= FR_L  then  M_RGB:=CL1 else M_RGB:=cr1;

// OBJ Loader ========================
if  rLoadObj  then begin
glPushMatrix();
// glClearColor(0.0, 0.0, 0.0, 0.0);       // Black Background
   glShadeModel(GL_SMOOTH);                 // Enables Smooth Color Shading
   glClearDepth(1.0);                       // Depth Buffer Setup
   glEnable(GL_DEPTH_TEST);                 // Enable Depth Buffer
   glDepthFunc(GL_LESS);                 // The Type Of Depth Test To Do
// glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);   //Realy Nice perspective calculations

// Turn on OpenGL lighting
   glLightfv(GL_LIGHT1, GL_POSITION, @LightPos);      // Set Light1 Position
   glLightfv(GL_LIGHT1, GL_AMBIENT, @LightAmb);      // Set Light1 Ambience
   glLightfv(GL_LIGHT1, GL_DIFFUSE, @LightDif);      // Set Light1 Diffuse
   glLightfv(GL_LIGHT1, GL_SPECULAR, @LightSpc);      // Set Light1 Specular
   glEnable(GL_LIGHT1);               // Enable Light1
   glEnable(GL_LIGHTING);            // Enable Lighting



MyQuadratic := gluNewQuadric();               // Initialize Quadratic
gluQuadricNormals(MyQuadratic, GL_SMOOTH);             // Enable Smooth Normal Generation
gluQuadricTexture(MyQuadratic, GL_FALSE);         // Disable Auto Texture Coords

   //glLoadIdentity();                                       // Reset The View
   glTranslatef(0,0,-3);
   glTranslatef(0.0,0.0,-22);
   glScalef(10/Scale, 10/Scale, 10/Scale);

   glRotatef(xAngle, 1, 0, 0);
   glRotatef(yAngle, 0, 1, 0);


   DrawModel(M);
   xAngle :=xAngle + xSpeed;
   yAngle :=yAngle + ySpeed;

  glPopMatrix();
  end ;

// Показ схемы
    if  ViewSHA then begin
    glPushMatrix();
     glTranslatef(-5,1.5,-1);
     glColor3f(1, 1, 0.4);
     modeX :=mode;
     if F_BL or (mode = GL_Select) then
      begin
       Draw_OGL_LoadSHA_Test01(0,0,0,100,TS2);
      end
      else  glCallList(MM3);
     glPopMatrix();
    end;
//----------------------

//BK_Sphere --------------------
   If R_BK_Sphere then begin
     glPushMatrix();
     glTranslatef(0,0,0);
     glRotatef(180,0.0,0.0,1.0);

     glRotatef(R_BK_SphereRX,1.0,0.0,0.0);
     glRotatef(R_BK_SphereRY,0.0,1.0,0.0);
     glRotatef(R_BK_SphereRZ,0.0,0.0,1.0);

    if  R_BK_SphereOffsetKvaziStereo then
    begin
     if FRender= FR_L  then
      glTranslatef(-R_BK_SphereOffsetKvaziStereoSet ,0,0);
     if FRender= FR_R  then
      glTranslatef(+R_BK_SphereOffsetKvaziStereoSet ,0,0);
    end;

    if R_BK_Capture then
            begin
             glRotatef(90+45,0.0,1.0,0.0);
             if not VirtScreen then
                Texture4:=CapTextureBMP(Tbmp,texID1, ow1,oh1,FST1,R_W,R_H);
             AAA0(Texture4);
            end
        else AAA0(Texture6);

     glPopMatrix();
    end;
//
    //VScreen ==========================
  if VirtScreen then begin
  glPushMatrix();
    glColor3f(1, 1, 0.4);
      glTranslatef(0.5,1.8,1);
     glRotatef(270,1.0,0.0,0.0);
     //glScalef(2.5,0.0,0.0);
   if rCapture then begin
    Texture4:=CapTextureBMP(Tbmp,texID1, ow1,oh1,FST1,R_W,R_H);
     AAA4(Texture4);
  end else  begin
     if FRender= FR_W  then AAA1(Texture1);
     if FRender= FR_L  then AAA1(Texture1);
     if FRender= FR_R  then AAA1(Texture2);
      end ;
    glPopMatrix();
  end;

  //VScreen2 ==========================

  if VirtScreen_2 then begin
  glPushMatrix();
    //glColor3f(1, 1, 0.4);
     glTranslatef(9.5,1.8,1);
     glRotatef(270,1.0,0.0,0.0);
     //glScalef(2.5,0.0,0.0);
     BitmapTest(Tbmp_2,pf24bit);
     Texture5:=CapTextureBMP(Tbmp_2,texID2 ,ow2,oh2,FST2,
                             Tbmp_2.Width,Tbmp_2.Height);
     AAA5(Texture5);
    glPopMatrix();
  end;

     end;
end.


Техно-Демка она техно-демка и есть.
Нацеленная на быстрый результат "Проба пера" принципиально без возможности "сопровождения кода". (И это я еще чуть по удалял закомментированные блоки с разными "недоделками и переделками" )
Зы
Практически все что делает моя техно-демка (кроме загрузки моделей и "схемы" ) запрятано в этом модуле (фоновая сфера 100% там )
Зы Зы
А вот бинарники достаточно стабильны хотя и не оптимальны
GL_Select05_VR_05_8_8_2_Bin.7z Размер: 3,2 МБ

Добавлено спустя 8 часов 14 минут 39 секунд:
*В бинарнике техно демки можно загрузить любую панораму "по кнопке " ...

А если хочешь сделать отдельную "смотрелку панорам",
то вся нужная для этого информация с избытком есть в этом посте
Просто кидаешь на форму OpenGLControl в создании формы создаешь сферу грузишь текстуру и "вешаешь таймер", по которому вызываешь рендер сцены где достаточно написать что-то вроде этого.

Код: Выделить всё

//BK_Sphere --------------------
  begin
    glPushMatrix();
     glTranslatef(0,0,0);
     glRotatef(180,0.0,0.0,1.0);

     glRotatef(R_BK_SphereRX,1.0,0.0,0.0);
     glRotatef(R_BK_SphereRY,0.0,1.0,0.0);
     glRotatef(R_BK_SphereRZ,0.0,0.0,1.0);

        AAA0(Texture6);
     glPopMatrix();
    end;


и это практически все...
Ну разве что вращение "стрелками" с клавиатуры добавить.

Всей работы максимум на полчаса "под кофе и музон", а разбирать что и как моем "чудовище Франкенштейна" можно неопределенно долго (я если честно и сам "чужую часть кода" извлеченную из этой демки не очень понимаю )
Зы
Если у кого-то есть желание по плагиатствовать "отверточным способом" (типа добавить свой логотип ), то сочувствую, но это просто не тот случай . Нет, мне не жалко "чахлых ростков на пустынной клумбе моего интеллекта " (и иначе я бы вообще ничего на форуме не размещал) но честное слово проще и надежнее сделать свой проект с использованием собранной мной информации.
А я чем могу помогу.

[Sharfik]

Если у кого-то есть желание по плагиатствовать "отверточным способом" (типа добавить свой логотип ), то сочувствую, но это просто не тот случай . Нет, мне не жалко "чахлых ростков на пустынной клумбе моего интеллекта " (и иначе я бы вообще ничего на форуме не размещал) но честное слово проще и надежнее сделать свой проект с ипользванием собранной мной информации.
А я чем могу помогу.

Тогда буду копать. Если получится слепить как отдельный компонент выложу.

[Alex2013]

Если у кого-то есть желание по плагиатствовать "отверточным способом" (типа добавить свой логотип ), то сочувствую, но это просто не тот случай . Нет, мне не жалко "чахлых ростков на пустынной клумбе моего интеллекта " (и иначе я бы вообще ничего на форуме не размещал) но честное слово проще и надежнее сделать свой проект с использованием собранной мной информации.
А я чем могу помогу.

Тогда буду копать. Если получится слепить как отдельный компонент выложу.

Успехов! Буду с интересом ждать результатов.
ЗЫ
Ну вообще-то если ВиАр-режим не сильно интересует то возможно на досуге сделаю урезанный вариант чисто для просмотра панорам на экране. (это довольно просто, но смысла в этом все равно мало - движок поворотов (от демки с танком ) по хорошему нужно переписать, а все прочие, что нужно для просмотра панорам я уже выложил ... )

[Alex2013]

Нашел вот такую поделку...

Код: Выделить всё

unit decShellScreenshot;

interface

uses
  Windows;

function CreateScreenshot(AWnd: THandle; AClearBackground: Boolean = True;
  ABackgroundColor: TColorRef = $FFFFFF): HBITMAP;

implementation

uses
  MultiMon;

var
  LibsInited: Boolean;
  User32Module: HMODULE;
  DwmapiModule: HMODULE;
  InitLibsLock: TRTLCriticalSection;

type
  DPI_AWARENESS_CONTEXT = type THandle;

const
  DPI_AWARENESS_CONTEXT_INVALID           = DPI_AWARENESS_CONTEXT(0);
  DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE = DPI_AWARENESS_CONTEXT(-3);

type
  TSetThreadDpiAwarenessContext = function(AContext: DPI_AWARENESS_CONTEXT): DPI_AWARENESS_CONTEXT; stdcall;

var
  _SetThreadDpiAwarenessContext: TSetThreadDpiAwarenessContext;

const
  DWMWA_EXTENDED_FRAME_BOUNDS = 9;

type
  TDwmIsCompositionEnabled = function(out AEnabled: BOOL): HRESULT; stdcall;
  TDwmGetWindowAttribute = function(AWnd: HWND; AAttribute: DWORD; AOut: Pointer; AOutSize: DWORD): HRESULT; stdcall;

var
  _DwmIsCompositionEnabled: TDwmIsCompositionEnabled;
  _DwmGetWindowAttribute: TDwmGetWindowAttribute;

procedure InitLibs;
begin
  EnterCriticalSection(InitLibsLock);
  try
    if LibsInited then Exit;
    LibsInited := True;

    User32Module := LoadLibrary('User32.dll');
    if User32Module <> 0 then
      begin
        @_SetThreadDpiAwarenessContext := GetProcAddress(User32Module, 'SetThreadDpiAwarenessContext');
      end
    else
      begin
        @_SetThreadDpiAwarenessContext := nil;
      end;

    DwmapiModule := LoadLibrary('Dwmapi.dll');
    if DwmapiModule <> 0 then
      begin
        @_DwmIsCompositionEnabled := GetProcAddress(DwmapiModule, 'DwmIsCompositionEnabled');
        @_DwmGetWindowAttribute := GetProcAddress(DwmapiModule, 'DwmGetWindowAttribute');
      end
    else
      begin
        @_DwmIsCompositionEnabled := nil;
        @_DwmGetWindowAttribute := nil;
      end;
  finally
    LeaveCriticalSection(InitLibsLock);
  end;
end;

procedure DoneLibs;
begin
  if User32Module <> 0 then
    FreeLibrary(User32Module);
  if DwmapiModule <> 0 then
    FreeLibrary(DwmapiModule);
end;

function DwmIsCompositionEnabled(out AEnabled: BOOL): HRESULT;
begin
  InitLibs;
  if Assigned(@_DwmIsCompositionEnabled) then
    Result := _DwmIsCompositionEnabled(AEnabled)
  else
    Result := E_NOTIMPL;
end;

function DwmGetWindowAttribute(AWnd: HWND; AAttribute: DWORD; AOut: Pointer; AOutSize: DWORD): HRESULT;
begin
  InitLibs;
  if Assigned(@_DwmGetWindowAttribute) then
    Result := _DwmGetWindowAttribute(AWnd, AAttribute, AOut, AOutSize)
  else
    Result := E_NOTIMPL;
end;

function SetThreadDpiAwarenessContext(AContext: DPI_AWARENESS_CONTEXT): DPI_AWARENESS_CONTEXT;
begin
  InitLibs;
  if Assigned(@_SetThreadDpiAwarenessContext) then
    Result := _SetThreadDpiAwarenessContext(AContext)
  else
    Result := DPI_AWARENESS_CONTEXT_INVALID;
end;

function GetRealWindowRect(AWnd: HWND; out ARect: TRect): Boolean;
var
  Enabled: BOOL;
begin
  Result := False;
  if Succeeded(DwmIsCompositionEnabled(Enabled)) and Enabled then
    Result := Succeeded(DwmGetWindowAttribute(AWnd, DWMWA_EXTENDED_FRAME_BOUNDS, @ARect, SizeOf(ARect)));
  if not Result then
    Result := GetWindowRect(AWnd, ARect);
end;

type
  PHRGN = ^HRGN;

function MonitorEnumProc(AMonitor: HMONITOR; ADC: HDC; ARect: PRect; ARegion: LPARAM): Boolean; stdcall;
var
  TempRegion: HRGN;
begin
  with ARect^ do
    TempRegion := CreateRectRgn(Left, Top, Right, Bottom);
  if TempRegion <> RGN_ERROR then
    begin
      if PHRGN(ARegion)^ = RGN_ERROR then
        PHRGN(ARegion)^ := TempRegion
      else
        begin
          CombineRgn(PHRGN(ARegion)^, PHRGN(ARegion)^, TempRegion, RGN_OR);
          DeleteObject(TempRegion);
        end;
    end;
  Result := True;
end;

function GetMonitorsRegion: HRGN;
begin
  Result := RGN_ERROR;
  EnumDisplayMonitors(0, nil, MonitorEnumProc, LPARAM(@Result));
end;

function GetRealWindowRectEx(AWnd: HWND; out ARect: TRect; out AClearRegion: HRGN): Boolean;
var
  MonitorsRegion: HRGN;
  TempRegion: HRGN;
  RegionBox: TRect;
begin
  Result := GetRealWindowRect(AWnd, ARect);

  if Result then
    begin
      AClearRegion := CreateRectRgn(0, 0, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);
      if AClearRegion <> RGN_ERROR then
        begin
          GetWindowRgn(AWnd, AClearRegion);

          MonitorsRegion := GetMonitorsRegion;
          if MonitorsRegion <> RGN_ERROR then
            begin
              OffsetRgn(MonitorsRegion, -ARect.Left, -ARect.Top);
              CombineRgn(AClearRegion, AClearRegion, MonitorsRegion, RGN_AND);
              DeleteObject(MonitorsRegion);
            end;

          GetRgnBox(AClearRegion, RegionBox);
          TempRegion := CreateRectRgn(0, 0, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);
          if TempRegion <> RGN_ERROR then
            begin
              CombineRgn(AClearRegion, AClearRegion, TempRegion, RGN_XOR);
              DeleteObject(TempRegion);

              Inc(ARect.Left, RegionBox.Left);
              Inc(ARect.Top, RegionBox.Top);
              ARect.Right := ARect.Left + (RegionBox.Right - RegionBox.Left);
              ARect.Bottom := ARect.Top + (RegionBox.Bottom - RegionBox.Top);
              OffsetRgn(AClearRegion, -RegionBox.Left, -RegionBox.Top);
            end
          else
            begin
              DeleteObject(AClearRegion);
              AClearRegion := RGN_ERROR;
            end;
        end;
    end;
end;

procedure ClearBackground(ADC: HDC; ARegion: HRGN; AColor: TColorRef);
var
  Brush: HBRUSH;
begin
  if ARegion = RGN_ERROR then Exit;
  Brush := CreateSolidBrush(AColor);
  if Brush <> 0 then
    begin
      FillRgn(ADC, ARegion, Brush);
      DeleteObject(Brush)
    end;
end;

function CreateScreenshot(AWnd: THandle; AClearBackground: Boolean = True;
  ABackgroundColor: TColorRef = $FFFFFF): HBITMAP;
var
  PrevContext: DPI_AWARENESS_CONTEXT;
  Rect: TRect;
  ClearRegion: HRGN;
  Width: Integer;
  Height: Integer;
  SourceDC, DestDC: HDC;
  SaveDC: HDC;
begin
  Result := 0;

  PrevContext := SetThreadDpiAwarenessContext(DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE);
  SourceDC := GetDC(0);
  if SourceDC <> 0 then
    begin
      DestDC := CreateCompatibleDC(SourceDC);
      if DestDC <> 0 then
        begin
          if GetRealWindowRectEx(AWnd, Rect, ClearRegion) then
            begin
              Width := Rect.Right - Rect.Left;
              Height := Rect.Bottom - Rect.Top;
              Result := CreateCompatibleBitmap(SourceDC, Width, Height);
              if Result <> 0 then
                begin
                  SaveDC := SelectObject(DestDC, Result);
                  BitBlt(DestDC, 0, 0, Width, Height, SourceDC, Rect.Left, Rect.Top, SRCCOPY);
                  if AClearBackground then
                    ClearBackground(DestDC, ClearRegion, ABackgroundColor);
                  SelectObject(SaveDC, Result);
                end;
              if ClearRegion <> RGN_ERROR then
                DeleteObject(ClearRegion);
            end;
          DeleteDC(DestDC);
        end;
      ReleaseDC(0, SourceDC);
    end;
  if PrevContext <> DPI_AWARENESS_CONTEXT_INVALID then
    SetThreadDpiAwarenessContext(PrevContext);
end;

initialization
  LibsInited := False;
  User32Module := 0;
  DwmapiModule := 0;
  InitializeCriticalSection(InitLibsLock);

finalization
  DoneLibs;
  DeleteCriticalSection(InitLibsLock);
end.


Заметных результатов увы, нет. (Но может где-то ошибка затесалаась )

Зато сделал захват с нескольких мониторов ( в полноэкранном режиме ) .

Код: Выделить всё


procedure CreateSnapshotPlusWH
   (var B:TBitmap;//Входящий проинициализированный  битмап.
        W,H:Integer; // Исходящие размеры битмапа
        WindowHD:HWND;// Хембел окна если 0 включается полноэкранный режим
         MNT,//Номер монитора для полноэкранного захват (От 0 до Screen.MonitorCount-1)
        Sbs:Integer); // Сепаратор стереопары 0 - без разделения 1- левый полукадр 2- правый полукадр.
       (...как оказались зря старался потому что  "SBS сепарацию"  во время снятия скрина в моей программе делать просто бессмысленно )
  var
      wnd:HWND;
      dc:HDC;
      X,WS,HS:Longint;
      r,R2:TRect;
      CR: HRGN;
  begin
    if not LibsInited then InitLibs;
    If B=Nil then exit;

      wnd :=WindowHD;
      if wnd =0 then
          begin //Захват экрана.
           dc := GetDC(0);
          if MNT > Screen.MonitorCount-1 then MNT:=0;
          Ws:=Screen.Monitors[MNT ].Width;
          Hs:=Screen.Monitors[MNT ].Height;
          R :=Screen.Monitors[MNT ].WorkareaRect;
          Ws:=r.Right-r.Left;
          Hs:=r.Bottom-r.Top;
          end
         else // Захват окна
          begin
          dc := GetWindowDC(wnd);

        // GetRealWindowRect(Wnd, R); проверил но результатов отличных от стандартного метода не обнаружил
        // if not GetRealWindowRectEx(Wnd, R, CR) then GetWindowRect(wnd,r);

         Windows.GetClientRect(WND, r); // так чуть по другому но неособо лучше
           Ws:=r.Right-r.Left;
           Hs:=r.Bottom-r.Top;
          end;

      if SBS in [1,2] then ws:=ws div 2;
      if SBS in [0,1] then X:=0;
      if SBS = 2 then x:=ws;
      b.SetSize(W,H);
  StretchBlt(B.Canvas.Handle,0,0,B.Width,B.Height,DC
  ,x+r.Left,r.Top,WS,HS,SRCCOPY);
  ReleaseDC(wnd,dc);
  end;