Nyt spørgsmål til PrtSc tast

procedure ScreenShot(x: Integer;
  y: Integer; //(x, y) = Left-top coordinate
  Width: Integer;
  Height: Integer; //(Width-Height) = Bottom-Right coordinate
  bm: TBitMap); //Destination
var
  dc: HDC;
  lpPal: PLOGPALETTE;
begin
  {test width and height}
  if ((Width = 0) or
    (Height = 0)) then
    Exit;
  bm.Width  := Width;
  bm.Height := Height;
  {get the screen dc}
  dc := GetDc(0);
  if (dc = 0) then
    Exit;
  {do we have a palette device?}
  if (GetDeviceCaps(dc, RASTERCAPS) and
    RC_PALETTE = RC_PALETTE) then
  begin
    {allocate memory for a logical palette}
    GetMem(lpPal,
      SizeOf(TLOGPALETTE) +
    (255 * SizeOf(TPALETTEENTRY)));
    {zero it out to be neat}
    FillChar(lpPal^,
      SizeOf(TLOGPALETTE) +
    (255 * SizeOf(TPALETTEENTRY)),
      #0);
    {fill in the palette version}
    lpPal^.palVersion := $300;
    {grab the system palette entries}
    lpPal^.palNumEntries :=
      GetSystemPaletteEntries(dc,
      0,
      256,
      lpPal^.palPalEntry);
    if (lpPal^.PalNumEntries <> 0) then
      {create the palette}
      bm.Palette := CreatePalette(lpPal^);
    FreeMem(lpPal, SizeOf(TLOGPALETTE) +
    (255 * SizeOf(TPALETTEENTRY)));
  end;
  {copy from the screen to the bitmap}
  BitBlt(bm.Canvas.Handle,
    0,
    0,
    Width,
    Height,
    Dc,
    x,
    y,
    SRCCOPY);
  {release the screen dc}
  ReleaseDc(0, dc);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);
end;

>Stone: Tak for tilsendte. Desværre er resultatet det samme. Det er kun øverste dele af skærmen der medtages. Jeg vil beskrive det konkrete problem her:

Jeg har 2 computere med W8.1:

1) Opløsning 1920 x 1080. Denne computer står i normal mode (mindre), d.v.s. Screen.Width:=1920, Screen.Height:=1080. Ingen problemer. Begge procedurer virker både med ScreenShot (både ny og gammel) og ScreenShotActiveWindow.

2) Microsoft Surface pro 3 - 12" 2160 x 1440 opløsning. Det er meget småt at se på, derfor er denne computer default sat op med Større text og elementer på skærmen. Det giver en opløsning på 1440 x 960 - Screen.Width:=1440, Screen.Height:=960, men procedurerne skal bruge opløsningen på 2160 x 1440 for at vise hele skærmbilledet (det virker, når jeg forcerer det i Button1Click(Sender)).

Jeg kan selvfølgelig sætte computeren til mindre før jeg bruger procedurerne og så tilbage bagefter - meeen, det er lidt bøvlet. Derfor spørger jeg om der findes et kald, hvor jeg kan detektere den fulde opløsning. Hvis jeg kan det, kan jeg med lidt simpel matematik endda udregne placeringen af det aktive vindue.

Alternativt kan jeg parameter-opsætte den fulde opløsning, så bruger angiver denne en gang for alle.

Ved godt det her er lidt bøvlet
Men hvis man kan få vist den aktuelle opløsning og dermed ændre den til det optimale så må det vel kunne bruges

Finde ud af den aktuelle opløsning...

procedure TForm1.Button1Click(Sender: TObject);
begin
MessageDlg(Format('Screen Width = %d' + #13#10 + 'Screen Height = %d',
            [Screen.Width, Screen.Height]), mtInformation, [mbOK], 0);

Ændre på opløsning:

function NewRes(XRes, YRes: DWORD; Frequency: Cardinal): Integer;
var
  DevMode: TDeviceMode;
begin
  EnumDisplaySettings(nil, 0, DevMode);
  DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_DISPLAYFREQUENCY;
  DevMode.dmPelsWidth := XRes;
  DevMode.dmPelsHeight := YRes;
  DevMode.dmDisplayFrequency := Frequency;
  Result := ChangeDisplaySettings(DevMode, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if NewRes(1280, 1024, 85) = DISP_CHANGE_SUCCESSFUL then
    ShowMessage('Resolution changed!');
end


//Another function:


function ChangeResolution(XResolution, YResolution, Depth: DWORD): BOOL;
var
  DevMode: TDeviceMode;
  i: Integer;
begin
  Result := False;
  i      := 0;
  while EnumDisplaySettings(nil, i, DevMode) do
    with DevMode do
    begin
      if (dmPelsWidth = XResolution) and
        (dmPelsHeight = YResolution) and
        (dmBitsPerPel = Depth) then
        if ChangeDisplaySettings(DevMode, CDS_UPDATEREGISTRY) =
          DISP_CHANGE_SUCCESSFUL then
        begin
          Result := True;
          SendMessage(HWND_BROADCAST, WM_DISPLAYCHANGE, SPI_SETNONCLIENTMETRICS, 0);
          Break;
        end;
      Inc(i);
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ChangeResolution(800, 600, 32) then ShowMessage('Resolution changed!');
end;

>Og så lige den sidste med at vise de mulige opløsninger.

procedure TForm1.Button1Click(Sender: TObject);
var
  DC: THandle;    // display context
  Bits: Integer;    // bits per pixel
  HRes: Integer;    // horizontal resolution
  VRes: Integer;    // vertical resolution
  DM: TDevMode;  // to Save EnumDisplaySettings
  ModeNum: Longint;    // video mode number
  Ok: Bool;
  fre: Integer;    // refresh rate
begin
  DC := GetDC(Handle);
  Bits := GetDeviceCaps(DC, BITSPIXEL);
  HRes := GetDeviceCaps(DC, HORZRES);
  VRes := GetDeviceCaps(DC, VERTRES);
  fre := GetDeviceCaps(DC, VREFRESH);
  // Show Current Resolution
  Edit1.Text := Format('%d bit, %d x %d', [Bits, HRes, VRes]);
  ReleaseDC(Handle, DC); // Show all modes available ModeNum := 0;  // The 1st one
  ModeNum := 0;
  EnumDisplaySettings(nil, ModeNum, DM);
  ListBox1.Items.Add(Format('%d bit, %d x %d bei %d Hz', [DM.dmBitsPerPel,
    DM.dmPelsWidth, DM.dmPelsHeight, Dm.dmDisplayFrequency]));
  Ok := True;
  while Ok do
  begin
    Inc(ModeNum); // Get next one
    Ok := EnumDisplaySettings(nil, ModeNum, DM);
    ListBox1.Items.Add(Format('%d bit, %d x %d bei %d Hz', [DM.dmBitsPerPel,
      DM.dmPelsWidth, DM.dmPelsHeight, Dm.dmDisplayFrequency]));
  end;
end;

>Stone: Tak - Det ser spændende ud. Jeg har fået implementeret den sidste. Smid lige et svar.

svar