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