[nixon232]

Началось все с того, что на ноутбуке, с заявленным разрешением, FHD
некорректно работает такой код:

Код:

1 2 3 4 5 6 7

h := WindowFromPoint(Mouse.CursorPos);     SetForegroundWindow(h);     GetWindowRect(h, r);           bit := CaptureScreenRect(r); OrigBMP.Assign(bit);     bit.SaveToFile(ExtractFilePath(ParamStr(0)) + 'xxx.BMP');

Код:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21

function CaptureScreenRect( ARect: TRect ) : TBitmap; var   ScreenDC: HDC; begin   Result := TBitmap.Create;       Result.Width := ARect.Right - ARect.Left;     Result.Height := ARect.Bottom - ARect.Top;       ScreenDC := GetDC( 0 );     try        BitBlt ( Result.Canvas.Handle, 0, 0,  Result.Width,       Result.Height, ScreenDC,         ARect.Left, ARect.Top, SRCCOPY );     finally  //    Result.SaveToFile('d:\1.bmp');       ReleaseDC( 0, ScreenDC );     end;   end;

Имеем в итоге картинку
такую
1.BMP

Меняем разрешение с 1920х1080 на 1600х900 и картинка в норме

2.BMP

В итоге решил проверить разрешениие

Код:

1 2 3 4

for m := 0 to Screen.MonitorCount - 1 do     with Screen.Monitors[m] do         Format('%d : Monitor %d x %d, Scale: %d', [m+ 1, width, height, PixelsPerInch]);

в корректном случае

1 : Monitor 1600 x 900, Scale: 96

в проблемном (при 1920 х1080

1 : Monitor 1536 x 864, Scale: 96

Потом думаю дай гляну масштабирование, оно оказалось нифига не 100, а 125, хотя по логу Scale 96 в обоих случаях. Откатил до 100 - проблема как таковая ушла, но как тогда сделать корректный скрин окна при масштабировании?

[Alegun]

Да как-то слишком уж изьяшно окошко фоткается - сначало область определяется, и затем только из целой снимки рабочего стола кусман с её размерами выкусывается, а при масштабировании окно немного по-другому место на экране занимает и кусок видимо поэтому от целой картинки отличается, вот может вдруг такой вариант для скриншотки больше подойдёт

Код:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31

procedure ScreenShot(hWnd: HWND; bm: TBitmap); var  RLeft, RTop, RWidth, RHeight: Word;  R: TRect;  dc: HDC;  lpPal: PLogPalette; begin  dc:= GetDC(0);  try   if (not IsWindow(hWnd)) or (dc = 0) then Exit;   GetWindowRect(hWnd, R);   RLeft:= R.Left;   RTop:= R.Top;   RWidth:= R.Right-RLeft;   RHeight:= R.Bottom-RTop;   bm.Width:= RWidth;   bm.Height:= RHeight;   if (GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE) then    begin     GetMem(lpPal, SizeOf(TLogPalette) + (255 * SizeOf(TPaletteEntry)));     FillChar(lpPal^, SizeOf(TLogPalette) + (255 * SizeOf(TPaletteEntry)), #0);     lpPal^.palVersion:= $300;     lpPal^.palNumEntries:= GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEntry);     if (lpPal^.PalNumEntries <> 0) then bm.Palette:= CreatePalette(lpPal^);     FreeMem(lpPal, SizeOf(TLogPalette) + (255 * SizeOf(TPaletteEntry)));    end;   BitBlt(bm.Canvas.Handle, 0, 0, RWidth, RHeight, dc, RLeft, RTop, SRCCOPY);  finally   ReleaseDc(0, dc);  end; end;

[nixon232]

Как ни странно, но ваш вариант дает такой же результат

3.BMP
То ли тут WindowRect Косячит? То ли В манифесте дело?
Если в свойствах - совместитмость убрать масштабирование, то скрин корректный, а разрешение пишет так

1 : Monitor 1920 x 1080, Scale: 120

[Vayrus]

Попробуйте эти варианты, не тестировал, в проблему вопроса вникать некогда)

Код:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121

//v1 function GetScreenShot(const AHandle: THandle; FileName: String; QuickSave: Boolean): Boolean; var   fBitmap: PBitmap;   DC: HDC;   Rect: TRect;   OSD: POpenSaveDialog;   Image: PPngObject;   begin   Image := NewPngObject;   fBitmap := nil;   Result := False;   DC := GetDC(AHandle);   if DC <> 0 then     try       if not GetClientRect(AHandle, Rect) then Exit;       fBitmap := NewDIBBitmap(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, pf32bit);       Result := BitBlt(fBitmap.Canvas.Handle, 0, 0, fBitmap.Width, fBitmap.Height, DC, 0, 0, SRCCOPY);       if not Result then Exit;       Image.AssignHandle(fBitmap.Handle, false, 0);       if not QuickSave then         begin         OSD := NewOpenSaveDialog('', '', DefOpenSaveDlgOptions );         OSD.Filter := 'PNG - Portable Network Graphics|*.png';         OSD.Filename := FileName;         OSD.WndOwner := OpWnd;         OSD.OpenDialog := false;         if OSD.Execute then           begin           Image.SaveToFile(OSD.Filename);           end;         OSD.Free;         end       else Image.SaveToFile(FileName);     finally       fBitmap.Free;       Image.Free;       ReleaseDC(AHandle, DC);     end; end;   //v2 //WindowSnap(Self.Handle, Image1.Picture.Bitmap) ; //Image1.Refresh; function WindowSnap(windowHandle: HWND; bmp: TBitmap): boolean; var   r: TRect;   user32DLLHandle: THandle;   printWindowAPI: function(sourceHandle: HWND; destinationHandle: HDC;     nFlags: UINT): BOOL; stdcall; begin   result := False;   user32DLLHandle := GetModuleHandle(user32) ;   if user32DLLHandle <> 0 then   begin     @printWindowAPI := GetProcAddress(huser32, 'PrintWindow') ;     if @printWindowAPI <> nil then     begin       GetWindowRect(windowHandle, r) ;       bmp.Width := r.Right - r.Left;       bmp.Height := r.Bottom - r.Top;       bmp.Canvas.Lock;       try         result := printWindowAPI(windowHandle, bmp.Canvas.Handle, 0) ;       finally         bmp.Canvas.Unlock;       end;     end;   end; end; (*WindowSnap*)   //v3 procedure TForm1.Button1Click(Sender: TObject); const   FullWindow = True; // Set to false if you only want the client area. var   Win: HWND;   DC: HDC;   Bmp: TBitmap;   FileName: string;   WinRect: TRect;   Width: Integer;   Height: Integer; begin   Form1.Hide;   try     Application.ProcessMessages; // Was Sleep(500);     Win := GetForegroundWindow;       if FullWindow then     begin       GetWindowRect(Win, WinRect);       DC := GetWindowDC(Win);     end else     begin       Windows.GetClientRect(Win, WinRect);       DC := GetDC(Win);     end;     try       Width := WinRect.Right - WinRect.Left;       Height := WinRect.Bottom - WinRect.Top;         Bmp := TBitmap.Create;       try         Bmp.Height := Height;         Bmp.Width := Width;         BitBlt(Bmp.Canvas.Handle, 0, 0, Width, Height, DC, 0, 0, SRCCOPY);         FileName := 'Screenshot_' +           FormatDateTime('mm-dd-yyyy-hhnnss', Now());         Bmp.SaveToFile(Format('C:\Screenshots\%s.bmp', [FileName]));       finally         Bmp.Free;       end;     finally       ReleaseDC(Win, DC);     end;   finally     Form1.Show;   end; end;

[nixon232]

Первый вариант - так и не смог скомпилировать, не знаю, что за объекты\ методы там используются (хотя куда сохранять не критично думаю. схожий вариант делал - не помогло)
Вариант второй - был с ошибками, но работает. Итог : Слева/верху лишнего нет, но высота и ширина не те. Плюс на скрине (только) стиль окна вин 7 ,а по факту вин 10.

4.BMP

Третий - пробовал ранее.

[Alegun]

Интересная геометрия у экрана, почти 2:1, обычно это у ноутов 1.5:1, наверное что-то типа нестандарта, а виндовская "окнопечатка" нормально в буфер снимок копирует?, тогда здесь может эмуляция жима комбинации Alt+PrintScrn подойдёт, при обнаружении растяжки

[nixon232]

А как вы геометрию определяете? Я окно вручную растягивал. Или вы про 15хх на 8хх? вроде стандартный 15" Моник. Как доберусь до рабочего 27" проверю как там с масштабированием, но мне кажется, что баг останется

[nixon232]

Как и предпологал, ноут как таковой не причем. на стационаром та же ситуация. Любой Scale и беда с WindowRect'om