Avatar billede jisch Mester
17. juli 2015 - 22:47 Der er 4 kommentarer og
1 løsning

Nyt spørgsmål til PrtSc tast

Jeg fik som svar på mit spørgsmål "PrtSc tast" følgede glimrende fra stone.

procedure ScreenShot(Billede: TBitMap);
var
  c: TCanvas;
  r: TRect;
begin
  c := TCanvas.Create;
  c.Handle := GetWindowDC(GetDesktopWindow);
  try
    r := Rect(0, 0, Screen.Width, Screen.Height);
    Billede.Width := Screen.Width;
    Billede.Height := Screen.Height;
    Billede.Canvas.CopyRect(r, c, r);
  finally
    ReleaseDC(0, c.Handle);
    c.Free;
  end;
end;

procedure ScreenShotActiveWindow(Billede: TBitMap);
var
  c: TCanvas;
  r, t: TRect;
  h: THandle;
begin
  c := TCanvas.Create;
  c.Handle := GetWindowDC(GetDesktopWindow);
  h := GetForeGroundWindow;
  if h <> 0 then
    GetWindowRect(h, t);
  try
    r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
    Billede.Width  := t.Right - t.Left;
    Billede.Height := t.Bottom - t.Top;
    Billede.Canvas.CopyRect(r, c, t);
  finally
    ReleaseDC(0, c.Handle);
    c.Free;
  end;
end;

Det fungerer perfekt under "normale" forhold. Der opstår dog problemer under W8 HVIS man har sat tekst og andre elementer fra Mindre til Større under skærmopløsning. Eksempel:
Mindre 1920 x 1080 (1:1)
Mellem 1536 x 864 (1,25:1)
Større 1280 x 720 (1,5:1)
PPI er under alle 96

Det betyder, at IKKE hele billedet bliver kopieret hvis computeren er sat til Mellem eller Større (det skal den f.eks på Microsofts Surface pro 3 for at få et ordenligt billede) samtidig med at tekst og elementer bliver større i kopien. Det er underligt, for opløsningen står til 1920 x 1080 men Billede.Width og Billede.Height står med de faktorer som beskrevet ovenover. Jeg har prøvet med at forcere den Mindre (1920 x 1080) altså r:=Rect(0, 0, 1920, 1080), Billede.Width:=1920 og Billede.Height:=1080. Det virker, men er ikke særlig elegant eller generelt - og det virker ikke med ScreenShotActiveWindow.

Og så til spørgsmålet: Findes der en Function/Procedure hvor jeg kan aflæse den Mindre opløsning? Det må virke ved ScreenShot - men hvad med ActiveWindow?
Avatar billede stone Forsker
18. juli 2015 - 04:09 #1
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;
Avatar billede jisch Mester
18. juli 2015 - 09:38 #2
>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.
Avatar billede stone Forsker
18. juli 2015 - 14:35 #3
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;
Avatar billede jisch Mester
18. juli 2015 - 18:40 #4
>Stone: Tak - Det ser spændende ud. Jeg har fået implementeret den sidste. Smid lige et svar.
Avatar billede stone Forsker
18. juli 2015 - 19:05 #5
svar
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Kurser inden for grundlæggende programmering

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester