VB 5/6-Tipp 0078: Screenshot, Fotografie des Bildschirms erstellen

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei PROJECT1.VBP -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Vertikale Scrollbar "VScroll1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Bildfeld-Steuerelement "Picture2" auf Picture1
' Steuerelement: Schaltfläche "Command1"

Option Explicit

Private Declare Function GetDesktopWindow Lib "user32" () _
        As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As _
        Long) As Long

Private Declare Function GetWindowRect Lib "user32" (ByVal _
        hwnd As Long, lpRect As RECT) As Long
        
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc _
        As Long, ByVal x As Long, ByVal y As Long, ByVal _
        nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC _
        As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
        ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _
        ByVal dwRop As Long) As Long
        
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd _
        As Long, ByVal hdc As Long) As Long

Private Type RECT
  Left As Long
  Top As Long
  Width As Long
  Height As Long
End Type

Const SRCCOPY = &HCC0020

Private Sub Form_Load()
  Picture2.Top = 0
  Picture2.Left = 0
  VScroll1.LargeChange = Picture1.Height / 4
  
  VScroll1.SmallChange = 120
  HScroll1.LargeChange = Picture1.Width / 4
  HScroll1.SmallChange = 120
End Sub

Private Sub Command1_Click()
  Call ScreenShot
End Sub

Private Sub Command2_Click()
  SavePicture Picture2.Image, App.Path & "\Test.bmp"
End Sub

Private Sub Command3_Click()
  Printer.Print
  Printer.PaintPicture Picture2.Image, 0, 0, _
                       Picture2.Width, Picture2.Height, _
                       0, 0, Picture2.Width * 2, _
                       Picture2.Height * 2
  Printer.EndDoc
End Sub

Private Sub HScroll1_Change()
  Picture2.Left = -HScroll1.Value
End Sub

Private Sub VScroll1_Change()
  Picture2.Top = -VScroll1.Value
End Sub


Private Sub ScreenShot()
  Dim Result&, DesktopHwnd&, DesktopHdc&
  Dim Desktop As RECT
    
    Picture2.AutoRedraw = True
    
    '### Desktopgröße in Pixeln ermitteln
    DesktopHwnd = GetDesktopWindow()
    DesktopHdc = GetDC(DesktopHwnd)
    Result = GetWindowRect(DesktopHwnd, Desktop)
    
    '### Zielbild und Scrollbalken der Desktopgröße anpassen
    Picture2.Width = Desktop.Width * 15
    Picture2.Height = Desktop.Height * 15
    VScroll1.Max = Picture2.Height - Picture1.Height + 15
    HScroll1.Max = Picture2.Width - Picture1.Width + 15
    
    '### Der eigentliche Screenshot
    Result = StretchBlt(Picture2.hdc, Desktop.Left, Desktop.Top, _
                        Desktop.Width, Desktop.Height, DesktopHdc _
                        , 0, 0, Desktop.Width, Desktop.Height, _
                        SRCCOPY)
    
    
    '### Gerätekontext löschen
    Result = ReleaseDC(DesktopHwnd, DesktopHdc)
     
    Picture2.Refresh
    Picture2.AutoRedraw = False
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei PROJECT1.VBP --------------

Kommentar von Darktemp am 14.09.2008 um 03:05

Ich bräuchte eine Editfunktion:
Es geht um den Code um den Mauszeiger abzurufen.
Ich habe eben auf http://msdn.microsoft.com/en-us/library/ms648070(VS.85).aspx nochwas gelesen:

"Remarks
GetIconInfo creates bitmaps for the hbmMask and hbmColor members of ICONINFO. The calling application must manage these bitmaps and delete them when they are no longer necessary."

Also braucht man noch folgende DLL-Funktion:

Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long

und muss am Ende des Codes (nach 'DrawIcon' aber außerhalb des 'if'-blockes) noch einfügen:

DeleteObject theicon.hbmColor
DeleteObject theicon.hbmMask

, sonst erstellt das Programm immer mehr Objekte und stürzt irgendwann ab.

Gruß Darktemp

Kommentar von Darktemp am 14.09.2008 um 02:11

und noch ein viertes mal ich:

ich habe gefunden, wie die transparenten teile mitkopiert werden: man braucht eine 2. konstante, die an stretchblt übergeben wird:

Const SRCCOPY = &HCC0020
Const CAPTUREBLT = &H40000000

'### Der eigentliche Screenshot
Result = StretchBlt(Picture2.hdc, Desktop.Left, Desktop.Top, _
Desktop.Width, Desktop.Height, DesktopHdc _
, 0, 0, Desktop.Width, Desktop.Height, _
SRCCOPY Or CAPTUREBLT)

Kommentar von Darktemp am 14.09.2008 um 01:49

nochmal ich: ich hab im kommentar vorhin eine dll-funktion übersehen:

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, _
ByVal x As Long, ByVal y As Long, ByVal hicon As Long) As Long

Kommentar von Darktemp am 14.09.2008 um 01:28

Außer der Ergänzung mit dem Cursor wollte ich eigentlich fragen, ob/wie man einen screenshot macht wo auch alpha-transparente Elemente drauf sind(z.b. Programme mit sogenanntem "click-through"-Feature), diese werden mit StretchBlt nicht mitkopiert.

Kommentar von Darktemp am 14.09.2008 um 01:22

Es ist zwar schon 5 bzw 7 Jahre O.o her seit den Kommentaren mit dem Cursor, da ich das aber im Moment brauchte/gefunden habe poste ich das hier mal:
Man kann nämlich das gerade aktive Icon des Cursors abrufen:

Dim posx As Long
Dim posy As Long
posx = floor(Picture1.ScaleWidth / 2)
posy = floor(Picture1.ScaleHeight / 2)

Dim Result As Long

Dim CurInf As CURSORINFO
CurInf.cbSize = Len(CurInf)
Result = GetCursorInfo(CurInf)

If Result = 0 Then Exit Sub
If CurInf.hCursor = 0 Then Exit Sub

Dim theicon As ICONINFO
Result = GetIconInfo(CurInf.hCursor, theicon)

If Result = 0 Then Exit Sub

If (CurInf.flags Or CURSOR_SHOWING) = CurInf.flags Then
DrawIcon Picture1.hdc, posx - theicon.xHotspot, posy - theicon.yHotspot, CurInf.hCursor
End If

damit wird der Hotspot (der Punkt, wo geklickt wird) in die mitte der Picturebox gezeichnet (achtung: Scalemode von der Picturebox habe ich auf "3 - Pixels" gestellt.

die benötigten dll-funktionen:
Private Declare Function GetCursorInfo Lib "User32.dll" (ByRef pCI As _
CURSORINFO) As Integer

Private Declare Function GetIconInfo Lib "User32.dll" _
(ByVal hicon As Long, ByRef piconinfo As ICONINFO) As Long

und die Types:
Private Type POINTAPI
x As Long
y As Long
End Type

Private Type CURSORINFO
cbSize As Long
flags As Long
hCursor As Long
ptScreenPos As POINTAPI
End Type

Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type

Kommentar von Timo am 30.11.2004 um 20:49

Hallo jxc

Probier mal "Overlay" Modus in Google zu suchen. Evtl kannst Du durch eine leicht graue Fläche den Video anzeigen. Aber aufnehmen leider nicht. Videodaten gehen nicht ans Betriebssystem sondern direkt an die Grafikkarte.

Timo

Kommentar von jxc am 29.07.2004 um 17:09

Hi
weis jemand wie mann den code verändern kann so dass er auch ´Videos anzeigt bei mir ist das nähmlich so dass z.B. bei AVi Previev dort wo normalerweise das Video wäre ein schwarzer Fleck ist

Kommentar von Dominik am 22.05.2004 um 11:53

Kann man auch einen Screenshot von einem einzigen Form machen?
Könnte ich gut für ein Programm von mir gebrauchen.

mfg
Dominik

Kommentar von geigercounter am 05.02.2003 um 12:11

@Revenant

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
X As Long
Y As Long
End Type
Dim CursorPos As POINTAPI

Sub Main
Call GetCursorPos(CursorPos)
End Sub

Dann mit BitBlt (glaub heisst so) das Bild des Mauszeigers in den Screenshot laden...
Zugegeben... nicht gerade super da der Typ des Mauszeigers nicht bestimmt werden kann, also ob Sanduhr, Link-Händchen, norm. Mauspfeil etc.

Kommentar von Oliver am 28.01.2003 um 15:23

Hallo,
besteht die Möglichkeit diese Funktion vielleicht in abgewandelter form auch in einem VBScript zu verwenden?
ich brauche einfach nur den Inhalt des aktiven Fensters in der Zwischenablage.
da .sendkeys den {prtsc} nicht ausführt.
wäre für jede Hilfe dankbar...

Kommentar von Rudi am 18.03.2002 um 21:07

sicher geht das. du musst nur statt der hWnd des Desktop die des MDIChild nehmen

Kommentar von andreas am 07.02.2002 um 16:15

wie schafft man es, einen screenshot eines MDI-childs zu machen u. zu speichern?thx,andreas

Kommentar von kennR am 23.12.2001 um 13:12

hi,
ja, man kann die images auch als JPG speichern. dazu ist allerdings eine DLL von intel sowie eine umfangreiche klassenbibliothek von vbaccelerator.
alles gibt´s unter folgendem link:
http://vbaccelerator.com/codelib/gfx/vbjpeg.htm
interessanterweise muss man die grafik trotzdem vorher als BMP speichern, sonst gibt es einen DLL-fehler:
SavePicture Picture2.image, App.Path & "\buffer.bmp"
Picture2.Picture = LoadPicture(App.Path & "\buffer.bmp")
erst dann kann man mit der in vbaccelerator beschriebenen methode als JPG speichern.
schöne grüße
kennR

Kommentar von Revenant am 27.07.2001 um 11:40

Hi, aknn ich auch Screenshots erstellen auf denen die Maus zu sehen ist?
mfg
Rev

Kommentar von Christian Loos am 06.06.2001 um 08:47

Ja, wenn du den Komprimierungsalgorythmus des Jpeg-Formats in den Code einbaust. Viel Spaß dabei :-)

Kommentar von Rene am 21.05.2001 um 09:27

Kann man denn mit dieser Prozedur erstellten Screenshot auch als jpg abspeichern?
mfg Rene