17. juli 2015 - 22:47Der 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?
Teknologi, AI og forretning er i centrum på Computerworlds Cloud og AI Festival i København d. 18. og 19. september. Se hele programmet for den store konference om strategisk brug af Cloud og AI på: www.cloud-festival.dk
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.
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;
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.