ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE
Diese Seite wurde zuletzt aktualisiert am 03.12.1999

Diese Seite wurde zuletzt aktualisiert am 03.12.1999
Aktuell im ABOUT Visual Basic-MagazinGrundlagenwissen und TechnologienKnow How, Tipps und Tricks rund um Visual BasicAddIns für die Visual Basic-IDE und die VBA-IDEVBA-Programmierung in MS-Office und anderen AnwendungenScripting-Praxis für IE, Windows Scripting Host und das Scripting-ControlTools, Komponenten und Dienstleistungen des MarktesRessourcen für Programmierer (Bücher, Job-Börse)Dies&Das...

Themen und Stichwörter im ABOUT Visual Basic-Magazin
Code, Beispiele, Komponenten, Tools im Überblick, Shareware, Freeware
Ihre Service-Seite, Termine, Job-Börse
Melden Sie sich an, um in den vollen Genuss des ABOUT Visual Basic-Magazins zu kommen!
Informationen zur AVB-Web-Site, Kontakt und Impressum

Zurück...

Zurück...


Anzeige

Code des Controls ScreenShot

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function GetClientRect Lib "user32" _
 (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" _
 (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowDC 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 IsWindow Lib "user32" _ 
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
 (ByVal hwnd As Long, ByVal hDC As Long) As Long

Public Event Done(Picture As StdPicture)

Public Enum ScreenShotModeConstants
  ssScreen
  ssWindow
  ssClientRect
End Enum

Public Enum ssErrConstants
  ssErrInvalidWindow = vbObjectError + 10000
End Enum

Private pScreenShotMode As ScreenShotModeConstants
Private pWindow As Long

Public Property Get Picture() As StdPicture
  Set Picture = UserControl.Picture
End Property

Public Property Get ScreenShotMode() As ScreenShotModeConstants
  ScreenShotMode = pScreenShotMode
End Property

Public Property Let ScreenShotMode(ByVal New_ScreenShotMode _
 As ScreenShotModeConstants)
  Select Case New_ScreenShotMode
    Case pScreenShotMode
    Case ssScreen To ssClientRect
      pScreenShotMode = New_ScreenShotMode
    Case Else
      Err.Raise 380, Ambient.DisplayName & ".ScreenShotMode"
  End Select
  PropertyChanged "ScreenShotMode"
End Property

Public Property Get Window() As Long
  Window = pWindow
End Property

Public Property Let Window(ByVal New_Window As Long)
  pWindow = New_Window
  If Not CBool(IsWindow(nWindow)) Then
    Err.Raise ssErrInvalidWindow, Ambient.DisplayName & ".Window", _
     "Ungültiges Fenster-Handle: " & nWindow
  End If
End Property

Public Function Clear() As StdPicture
  Set UserControl.Picture = Nothing
End Function

Public Function Shot(Optional ByVal ScreenShotMode As Variant, _
 Optional ByVal Window As Variant) As StdPicture
  Dim nScreenShotMode As ScreenShotModeConstants
  Dim nWindow As Long
  Dim nDCSrc As Long
  Dim nRect As RECT
  
  If IsMissing(ScreenShotMode) Then
    nScreenShotMode = pScreenShotMode
  Else
    nScreenShotMode = ScreenShotMode
  End If
  Select Case nScreenShotMode
    Case ssScreen
      nWindow = GetDesktopWindow()
    Case Else
      If IsMissing(Window) Then
        nWindow = pWindow
      Else
        nWindow = Window
      End If
      If Not CBool(IsWindow(nWindow)) Then
        Err.Raise ssErrInvalidWindow, Ambient.DisplayName & ".Shot", _
         "Ungültiges Fenster-Handle: " & nWindow
        Exit Function
      End If
  End Select
  With UserControl
    Select Case nScreenShotMode
      Case ssScreen
        nDCSrc = GetDC(nWindow)
        With nRect
          .Right = Screen.Width \ Screen.TwipsPerPixelX
          .Bottom = Screen.Height \ Screen.TwipsPerPixelY
        End With
        .Size Screen.Width, Screen.Height
      Case ssWindow
        nDCSrc = GetWindowDC(nWindow)
        GetWindowRect nWindow, nRect
        With nRect
          .Right = .Right - .Left
          .Left = 0
          .Bottom = .Bottom - .Top
          .Top = 0
        End With
        .Size nRect.Right * Screen.TwipsPerPixelX, _
         nRect.Bottom * Screen.TwipsPerPixelY
      Case ssClientRect
        nDCSrc = GetDC(nWindow)
        GetClientRect nWindow, nRect
        .Size nRect.Right * Screen.TwipsPerPixelX, _
         nRect.Bottom * Screen.TwipsPerPixelY
    End Select
    .AutoRedraw = True
    .Cls
    BitBlt .hDC, 0, 0, .ScaleWidth, .ScaleHeight, nDCSrc, 0, 0, vbSrcCopy
    ReleaseDC nWindow, nDCSrc
    Set .Picture = .Image
    .Cls
    .AutoRedraw = False
    .Size Screen.TwipsPerPixelX, Screen.TwipsPerPixelY
    Set Shot = .Picture
    RaiseEvent Done(.Picture)
  End With
End Function

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  pScreenShotMode = PropBag.ReadProperty("ScreenShotMode", ssScreen)
  cmdBack.Visible = Not Ambient.UserMode
End Sub

Private Sub UserControl_Resize()
  Static sInProc As Boolean
  
  If sInProc Then
    Exit Sub
  Else
    sInProc = True
  End If
  If Not Ambient.UserMode Then
    UserControl.Size 32 * Screen.TwipsPerPixelX, _
     32 * Screen.TwipsPerPixelY
  End If
  sInProc = False
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "ScreenShotMode", pScreenShotMode, ssScreen
End Sub

Zurück zu "Schnappschütze" Zurück zum Text   


Komponenten-Übersicht

Zum Seitenanfang

Copyright © 1999 - 2017 Harald M. Genauck, ip-pro gmbh  /  Impressum

Zum Seitenanfang

Zurück...

Zurück...

Download Internet Explorer