nur weiße screenshotes

[Harry M.]

ich habe mir nen tool gebaut, das screenshots macht... aber nur weiße. am code kann es eigendlich nicht liegen da ich diesen schon mehrfach verwendet habe... und das problem tritt auch nicht auf meinem rechner auf sondern auf den eines freundes welcher das tool haben wollte. ich habe den code auch schon durch anderen ersetzt. aber das problem bleibt. auf meinem rechner läuft alles wunderbar. woran könnte das liegen das verwendete betriebssystem ist das gleiche.

[Airblader]

Meine Glaskugel ist mir vorhin leider rutnergefallen, könntest du also auch mal ein bisschen Code zeigen?

air

[Harry M.]

nimm meine glaskugel...
*g

Delphi-Quellcode:

// procedure zum anlegen des screenshotes
procedure ScreenCapture(Bmp: TBitmap);
var
  DeskWnd: HWnd;
  DeskDC: HDC;
  DeskCv: TCanvas;
  R: TRect;
  W, H: Integer;
begin
  if Bmp = nil then Exit;
  DeskWnd := GetDesktopWindow;
  DeskDC := GetWindowDC(DeskWnd);
  DeskCv := TCanvas.Create;
  DeskCv.Handle := DeskDC;
  W := Screen.Width;
  H := Screen.Height;
  R := Bounds(0, 0, W, H);
  try
    Bmp.HandleType := bmDIB;
    Bmp.PixelFormat := pf24Bit;
    Bmp.Width := W;
    Bmp.Height := H;
    Bmp.Canvas.CopyMode := cmSrcCopy;
    Bmp.Canvas.CopyRect(R, DeskCv, R);
  finally
    DeskCv.Free;
    ReleaseDC(DeskWnd, DeskDC);
  end;
end;

// zum kovertieren in jpg
function setJPGFileName(fbmp: string):string;
var
  I : integer;
begin
  s := ExtractFileName(fbmp);
  for i := 1 to 3 do Delete(s,Length(s),1);
  result := s + 'JPG'
end;

// screenshot machen
self.Image1.Picture.Bitmap:=TBitmap.Create;
ScreenCapture(self.Image1.Picture.Bitmap);

// und kovertieren
    Try
    pic := TImage.Create(nil);
    //pic.Picture.LoadFromFile('Temp.bmp');
    pic.Picture := Image1.Picture;
    with TJPEGImage.Create do begin
      Performance := jpBestQuality;
      CompressionQuality := 20;
      Assign(pic.Picture.Graphic);
      //fNameJPG := setJPGFileName('Temp.bmp');
      SaveToFile('Temp.jpg');
      Free
    end;
    except; end;
    pic.Free;

wie gesagt auf meinem rechner läuft alles wunderbar.

[Airblader]

Sicher dasses läuft?
Da ist doch ein Fehler nachm andern drin...das sollte nichmal kompiliert werden können.

zum Beispiel: wo deklarierst du "s"?

und für den dateinamen gibts es imho noch ChangeFileExt ;)

air

[Harry M.]

na klar bin ich sicher das es läuft. nur um den ganzen code hier vorzustellen ist er zu umfangreich. das ist das wichtigste und wie gesagt ich habe den code auch schon durch anderen erstezt...

[Assun]

nimm den Code :

Delphi-Quellcode:

  
public
Bmp : TBitmap;
Jpg : TJpegImage;
end;

[..]

Delphi-Quellcode:

function GetCursorInfo2: TCursorInfo;
var
hWindow: HWND;
pt: TPoint;
pIconInfo: TIconInfo;
dwThreadID, dwCurrentThreadID: DWORD;
begin
Result.hCursor := 0;
ZeroMemory(@Result, SizeOf(Result));
// Find out which window owns the cursor
if GetCursorPos(pt) then
begin
   Result.ptScreenPos := pt;
   hWindow := WindowFromPoint(pt);
   if IsWindow(hWindow) then
   begin
     // Get the thread ID for the cursor owner.
     dwThreadID := GetWindowThreadProcessId(hWindow, nil);

     // Get the thread ID for the current thread
     dwCurrentThreadID := GetCurrentThreadId;

     // If the cursor owner is not us then we must attach to
     // the other thread in so that we can use GetCursor() to
     // return the correct hCursor
     if (dwCurrentThreadID <> dwThreadID) then
     begin
       if AttachThreadInput(dwCurrentThreadID, dwThreadID, True) then
       begin
         // Get the handle to the cursor
         Result.hCursor := GetCursor;
         AttachThreadInput(dwCurrentThreadID, dwThreadID, False);
       end;
     end
     else
     begin
       Result.hCursor := GetCursor;
     end;
   end;
end;
end;

// 2. Capture the screen
function CaptureScreen: TBitmap;
var
DC: HDC;
ABitmap: TBitmap;
MyCursor: TIcon;
CursorInfo: TCursorInfo;
IconInfo: TIconInfo;
begin
// Capture the Desktop screen
DC := GetDC(GetDesktopWindow);
ABitmap := TBitmap.Create;
try
   ABitmap.Width  := GetDeviceCaps(DC, HORZRES);
   ABitmap.Height := GetDeviceCaps(DC, VERTRES);
   // BitBlt on our bitmap
   BitBlt(ABitmap.Canvas.Handle,
     0,
     0,
     ABitmap.Width,
     ABitmap.Height,
     DC,
     0,
     0,
     SRCCOPY);
   // Create temp. Icon
   MyCursor := TIcon.Create;
   try
     // Retrieve Cursor info
     CursorInfo := GetCursorInfo2;
     if CursorInfo.hCursor <> 0 then
     begin
       MyCursor.Handle := CursorInfo.hCursor;
       // Get Hotspot information
       GetIconInfo(CursorInfo.hCursor, IconInfo);
       // Draw the Cursor on our bitmap
       ABitmap.Canvas.Draw(CursorInfo.ptScreenPos.X - IconInfo.xHotspot,
                           CursorInfo.ptScreenPos.Y - IconInfo.yHotspot, MyCursor);
     end;
   finally
     // Clean up
     MyCursor.ReleaseHandle;
     MyCursor.Free;
   end;
finally
   ReleaseDC(GetDesktopWindow, DC);
end;
Result := ABitmap;
end;

procedure SaveAsJpeg(const Filename: String; Quality: TJPEGQualityRange=100);
var
 Bmp: TBitmap;
 Jpg: TJpegImage;
begin
Bmp := TBitmap.Create;
Jpg := TJpegImage.Create;
try
  Bmp.Assign(CaptureScreen);
  Jpg.CompressionQuality:=Quality;
  Jpg.Assign(Bmp);
  Jpg.SaveToFile(ChangeFileExt(Filename, '.jpg' ));
finally
  Jpg.Free;
  Bmp.Free;
end;
end;

PS : Sehe gerade, dass herbei auch noch der Mauszeiger drauf ist. hoffe das macht nix ;-)

mfg,

Assun

[Sharky]

Zitat:

Zitat von Assun

nimm den Code :...

Und wo kommt der her? ;-)

[Harry M.]

den code check ich etwas später... wenn da der maus zeiger drauf ist... ist das super! und wer so feine functionen schreibt würde mich auch interessieren

[Assun]

ich leider nicht :oops: ;-)

[BenjaminH]

Ich glaube, das ist von den Schweizern: http://www.swissdelphicenter.ch/de/showcode.php?id=1396

[Harry M.]

also der code ist sehr gut einfach wie genial, besonders das mit dem mauszeiger das der mit drauf ist. auf meiner kist läuft es wieder super... nur auf dem anderen rechner wiedermal nicht. nen anderer kollege hat aber das gleiche problem.

[Harry M.]

guten morgen

also ich habe mir gestern abend mal die funktionen zugemüte geführt. so begeister wie ich anfangs war bin ich es nun leider nicht mehr. schon nach wenigen durchläufen (nämlich 43) sind die resourcen erschöpft. und zwar gänzlich... ich hatte testweise den ram auf nur 64mb bei win2k schrumpfen lassen. ich bleibe da lieber bei "meinen" oben schon dargestellten funktionen. die sind für meine zwecke wesendlich besser weil resourcen-sparender (bei über 200 durchläufen ging immer noch alles normal). da ist zwar nicht der mauszeiger drauf aber ich kucke mal ob ich das irgendwie zusammen kriege.

vielleicht kann mir ja jemand von den DP'lern unter die arme greifen

[Sharky]

Hai Harry M.

es könnte daran liegen das in dem Code bei jedem Capturen ein TBitmap erzeugt wird das nicht mehr freigegeben wird?

Delphi-Quellcode:

// 2. Capture the screen 
function CaptureScreen: TBitmap; 
var 
  DC: HDC; 
  ABitmap: TBitmap; 
  MyCursor: TIcon; 
  CursorInfo: TCursorInfo; 
  IconInfo: TIconInfo; 
begin 
  // Capture the Desktop screen 
  DC := GetDC(GetDesktopWindow); 
  ABitmap := TBitmap.Create;  // Hier zu sehe ich kein ABitmap.Free;
  .
  .
end;

[Harry M.]

ich konnte mir schon denken das da das bitmap objekt nicht wiederfreigegeben wird. meine modifizierungan am code brachten aber nie das gewünschte ergebnis. da ich es aber vor 10min geschaft habe, in den code den ich verwendet also nicht das von den schweitzern, die sache mit den corsur einzubinden, ist das eigendlich auch schon hinfällig. ich kucke aber trozdem mal wo bei mir der fehler lag kann ja nicht schaden.

[Khabarakh]

Falls du noch suchen willst: Benutze MemCheck

[Assun]

Zitat:

Zitat von Harry M.

ich konnte mir schon denken das da das bitmap objekt nicht wiederfreigegeben wird. meine modifizierungan am code brachten aber nie das gewünschte ergebnis. da ich es aber vor 10min geschaft habe, in den code den ich verwendet also nicht das von den schweitzern, die sache mit den corsur einzubinden, ist das eigendlich auch schon hinfällig. ich kucke aber trozdem mal wo bei mir der fehler lag kann ja nicht schaden.

könntest du mir mal deinen Code posten ? wär echt interessant !

[Harry M.]

bitte schön:

Delphi-Quellcode:

uses Jpeg;
var 
  PIC : TImage;
  fNameJPG, S : string;

////////////////////////////////////////////////////////////////////////////////
function GetCursorInfo2: TCursorInfo; 
var 
hWindow: HWND; 
pt: TPoint; 
pIconInfo: TIconInfo; 
dwThreadID, dwCurrentThreadID: DWORD; 
begin 
Result.hCursor := 0; 
ZeroMemory(@Result, SizeOf(Result)); 
// Find out which window owns the cursor 
if GetCursorPos(pt) then 
begin 
   Result.ptScreenPos := pt; 
   hWindow := WindowFromPoint(pt); 
   if IsWindow(hWindow) then 
   begin 
     // Get the thread ID for the cursor owner. 
     dwThreadID := GetWindowThreadProcessId(hWindow, nil); 

     // Get the thread ID for the current thread 
     dwCurrentThreadID := GetCurrentThreadId; 

     // If the cursor owner is not us then we must attach to 
     // the other thread in so that we can use GetCursor() to 
     // return the correct hCursor 
     if (dwCurrentThreadID <> dwThreadID) then 
     begin 
       if AttachThreadInput(dwCurrentThreadID, dwThreadID, True) then 
       begin 
         // Get the handle to the cursor 
         Result.hCursor := GetCursor; 
         AttachThreadInput(dwCurrentThreadID, dwThreadID, False); 
       end; 
     end 
     else 
     begin 
       Result.hCursor := GetCursor; 
     end; 
   end; 
end; 
end;  
////////////////////////////////////////////////////////////////////////////////
function setJPGFileName(fbmp: string):string;
var
  I : integer;
begin
  s := ExtractFileName(fbmp);
  for i := 1 to 3 do Delete(s,Length(s),1);
  result := s + 'JPG'
end;
////////////////////////////////////////////////////////////////////////////////
procedure ScreenShot(Bild: TBitMap);  
var  
  c: TCanvas;
  r: TRect;
  MyCursor: TIcon; 
  CursorInfo: TCursorInfo;
  IconInfo: TIconInfo;
begin  
  c := TCanvas.Create;  
  c.Handle := GetWindowDC(GetDesktopWindow);
  try
    r := Rect(0, 0, Screen.Width, Screen.Height);
    Bild.Width := Screen.Width;
    Bild.Height := Screen.Height;
    Bild.Canvas.CopyRect(r, c, r);


      // Create temp. Icon 
   MyCursor := TIcon.Create; 
   try 
     // Retrieve Cursor info 
     CursorInfo := GetCursorInfo2; 
     if CursorInfo.hCursor <> 0 then begin
       MyCursor.Handle := CursorInfo.hCursor; 
       // Get Hotspot information 
       GetIconInfo(CursorInfo.hCursor, IconInfo); 
       // Draw the Cursor on our bitmap
       Bild.Canvas.Draw(CursorInfo.ptScreenPos.X - IconInfo.xHotspot, CursorInfo.ptScreenPos.Y - IconInfo.yHotspot, MyCursor);
     end;
   finally
     // Clean up
     MyCursor.ReleaseHandle;
     MyCursor.Free;
   end;


  finally
    ReleaseDC(0, c.Handle);  
    c.Free;
  end;
end;
////////////////////////////////////////////////////////////////////////////////

// screenshot machen
ScreenShot(Image1.Picture.BitMap);

// konvertieren
Try
pic := TImage.Create(nil);
pic.Picture := Image1.Picture;
with TJPEGImage.Create do begin
  Performance := jpBestQuality;
  CompressionQuality := 20;
  Assign(pic.Picture.Graphic);
  //fNameJPG := setJPGFileName('Temp.bmp');
  SaveToFile('Temp.jpg');
  Free
  end;
except; end;
pic.Free;

das der cursor nun mit angezeigt wird, lässt aber die resourcen wieder etwas mehr in anspruch nehmen. kommentiere das dann einfach aus um den unterschied festzustellen