Screenshot aus Zwischenablage per VBA-Marko in Bild-Steuerelement einfügen

  • PowerPoint

Es gibt 1 Antwort in diesem Thema. Der letzte Beitrag () ist von MichaHo.

    Screenshot aus Zwischenablage per VBA-Marko in Bild-Steuerelement einfügen

    Hallo Zusammen,

    für eine PowerPoint-Vorlage benötige ich ein VBA-Makro, mit dem ich ein Screenshot aus der Zwischenablage in ein Bild-Steuerelement einfügen kann. Die Präsentation sollte dabei aus dem Bearbeitungsmodus herausspringen. Für das automatische Erstellen eines Screenshots habe ich bereits die folgenden Makros erstellt. Diese liegen in einem Standardmodul. Die Prozedur "Screen Copy" wird über einen CommandButton aufgerufen. Was

    Visual Basic-Quellcode

    1. ' API-Deklarationen:
    2. Private Declare Sub keybd_event _
    3. Lib "User32" ( _
    4. ByVal byteVirtualKeycode As Byte, _
    5. ByVal byteScan As Byte, _
    6. ByVal lFlags As Long, _
    7. ByVal lExtraInfo As Long)
    8. Private Const KEYEVENTF_KEYUP As Long = &H2 ' Taste lösen
    9. Private Const VK_MENU As Byte = &H12 ' Alt-Taste
    10. Private Const VK_SNAPSHOT As Byte = &H2C ' Druck/PrtScrn-Taste
    11. Public Sub ScreenCopy(Optional ByVal ActiveWindow As Boolean = False)
    12. ' Überträgt eine Bildschirmkopie des Desktops (ActiveWindow = False)
    13. ' oder des aktiven Fensters (ActiveWindow = True) in die Zwischenablage.
    14. If ActiveWindow Then
    15. ' Nur das aktive Fenster abfotografieren
    16. ' => Alt-Taste einbeziehen
    17. keybd_event VK_MENU, 0, 0, 0 ' Alt 'runter
    18. keybd_event VK_SNAPSHOT, 0, 0, 0 ' Druck ' runter
    19. keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0 ' Druck hoch
    20. keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0 ' Alt hoch
    21. Else
    22. ' Den gesamten Desktop abfotografieren
    23. keybd_event VK_SNAPSHOT, 0, 0, 0 ' Druck ' runter
    24. keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0 ' Druck hoch
    25. End If
    26. End Sub


    Über ein Rückmeldung würde ich mich sehr freuen !

    Vielen Dank schon mal !

    Gruß Mauda
    Hallo,

    ich sehe keine Frage...
    Du kannst aber auch direkt auf die Zwischenablage zugreifen:
    in ein Modul:
    Spoiler anzeigen

    Visual Basic-Quellcode

    1. Option Explicit
    2. Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    3. ByVal lpClassName As String, _
    4. ByVal lpWindowName As String) As Long
    5. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    6. ByRef PicDesc As PIC_DESC, _
    7. ByRef RefIID As GUID, _
    8. ByVal fPictureOwnsHandle As Long, _
    9. ByRef IPic As IPictureDisp) As Long
    10. Private Declare Function CopyImage Lib "user32.dll" ( _
    11. ByVal handle As Long, _
    12. ByVal un1 As Long, _
    13. ByVal n1 As Long, _
    14. ByVal n2 As Long, _
    15. ByVal un2 As Long) As Long
    16. Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    17. ByVal wFormat As Integer) As Long
    18. Private Declare Function OpenClipboard Lib "user32.dll" ( _
    19. ByVal hWnd As Long) As Long
    20. Private Declare Function GetClipboardData Lib "user32.dll" ( _
    21. ByVal wFormat As Integer) As Long
    22. Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
    23. Private Declare Function CloseClipboard Lib "user32.dll" () As Long
    24. Private Type GUID
    25. Data1 As Long
    26. Data2 As Integer
    27. Data3 As Integer
    28. Data4(0 To 7) As Byte
    29. End Type
    30. Private Type PIC_DESC
    31. lngSize As Long
    32. lngType As Long
    33. lnghPic As Long
    34. lnghPal As Long
    35. End Type
    36. Private Const PICTYPE_BITMAP = 1
    37. Private Const CF_BITMAP = 2
    38. Private Const IMAGE_BITMAP = 0
    39. Private Const LR_COPYRETURNORG = &H4
    40. Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"
    41. Private Function Paste_Picture() As IPictureDisp
    42. Dim lngReturn As Long, lngCopy As Long, lngPointer As Long
    43. If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
    44. lngReturn = OpenClipboard(FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption))
    45. If lngReturn > 0 Then
    46. lngPointer = GetClipboardData(CF_BITMAP)
    47. lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    48. Call CloseClipboard
    49. If lngPointer <> 0 Then Set Paste_Picture = Create_Picture(lngCopy, 0&, CF_BITMAP)
    50. End If
    51. End If
    52. End Function
    53. Private Function Create_Picture( _
    54. ByVal lnghPic As Long, _
    55. ByVal lnghPal As Long, _
    56. ByVal lngPicType As Long) As IPictureDisp
    57. Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
    58. Dim objPicture As IPictureDisp
    59. With udtID_IDispatch
    60. .Data1 = &H7BF80980
    61. .Data2 = &HBF32
    62. .Data3 = &H101A
    63. .Data4(0) = &H8B
    64. .Data4(1) = &HBB
    65. .Data4(2) = &H0
    66. .Data4(3) = &HAA
    67. .Data4(4) = &H0
    68. .Data4(5) = &H30
    69. .Data4(6) = &HC
    70. .Data4(7) = &HAB
    71. End With
    72. With udtPicInfo
    73. .lngSize = Len(udtPicInfo)
    74. .lngType = PICTYPE_BITMAP
    75. .lnghPic = lnghPic
    76. .lnghPal = lnghPal
    77. End With
    78. Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)
    79. Set Create_Picture = objPicture
    80. End Function
    81. Public Sub GetImageFromClipBoard()
    82. Dim objPicture As IPictureDisp
    83. Set objPicture = Paste_Picture
    84. If Not objPicture Is Nothing Then
    85. UserForm1.Image1.Picture = objPicture 'UserForm Namen anpassen
    86. Else
    87. MsgBox "Error - Zwischenablage scheint leer zu sein", vbCritical, "Error"
    88. End If
    89. End Sub


    in Deiner Userform in einem Button:

    Visual Basic-Quellcode

    1. Private Sub CommandButton1_Click()
    2. Call GetImageFromClipBoard
    3. End Sub


    Das Bild muss sich in der Zwischenablage befinden...

    Den Snippet hab ich noch aus meiner Excel VBA Zeit.... keine Ahnung wo ich den her hatte...
    "Hier könnte Ihre Werbung stehen..."