Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Image
BildScreenshot zu Image Image-Seite mit Beispielarbeitsmappe aufrufen

Bild in Zwischenablage importieren & exportieren

Betrifft: Bild in Zwischenablage importieren & exportieren von: Josef
Geschrieben am: 06.11.2020 10:21:26

Hallo!


Ich habe folgendes Problem, ich möchte aus einem bestimmten Ordner ein Bild (jpg) auswählen und anschließend in der Zwischenablage speichern.


Anschließend möchte ich mit einem zweiten Makro das Bild (jpg) in eine Excel Arbeitsmappe einfügen und um 90° drehen.

Danach die Zwischenablage wieder löschen.


Vielen Dank schon mal.

Josef

Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Nepumuk
Geschrieben am: 06.11.2020 10:57:25

Hallo Josef,

teste mal:

Option Explicit

Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long, _
    ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Long) As Long
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
    ByVal handle As LongPtr, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As LongPtr

Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

Public Sub ImageToClipBoard()
    Dim objPicture As IPictureDisp
    Dim lngptrReturn As LongPtr
    Set objPicture = LoadPicture("G:\Eigene Dateien\Eigene Bilder\2004-12-16\Scan2.BMP")
    Call OpenClipboard(Application.hwnd)
    Call EmptyClipboard
    lngptrReturn = CopyImage(objPicture.handle, IMAGE_BITMAP, _
        0&, 0&, LR_COPYRETURNORG)
    Call SetClipboardData(CF_BITMAP, lngptrReturn)
    Call CloseClipboard
End Sub

Public Sub ImageToTable()
    If IsClipboardFormatAvailable(CF_BITMAP) Then
        ActiveSheet.Paste
        Selection.ShapeRange.Rotation = 90
    Else
        Call MsgBox("Kein Bild im ClipBoard.", vbExclamation, "Hinweis")
    End If
End Sub

Gruß
Nepumuk

Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Josef
Geschrieben am: 06.11.2020 17:02:46

Danke für den Tipp, werde es gleich mal testen.

LG Josef

Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Josef
Geschrieben am: 06.11.2020 17:16:36

Hallo Nepumuk!

Funktioniert sehr gut, habe noch eine Zeile hinzugefügt am das Bild auswählen zu können.

Vielen Dank!!
Public Sub ImageToClipBoard()
    Dim objPicture As IPictureDisp
    Dim lngptrReturn As LongPtr
    Dim strBild As String
    Dim strSearch As String
    
    
    strSearch = "xc"
    strBild = Application _
    .GetSaveAsFilename(InitialFileName:=strSearch, FileFilter:="Bild Dateien (*.jpg), *.jpg",  _
Title:="Bilddatei öffnen")
    
    Set objPicture = LoadPicture(strBild)
    Call OpenClipboard(Application.hwnd)
    Call EmptyClipboard
    lngptrReturn = CopyImage(objPicture.handle, IMAGE_BITMAP, _
        0&, 0&, LR_COPYRETURNORG)
    Call SetClipboardData(CF_BITMAP, lngptrReturn)
    Call CloseClipboard
End Sub


Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Josef
Geschrieben am: 07.11.2020 13:50:24

Hallo Nepumuk!

Hätte noch eine weiter Frage bezüglich Positionierung. Ich verwende jetzt

Selection.ShapeRange.Rotation = ...
Selection.ShapeRange.Height = ...
Selection.ShapeRange.Top = ...
Selection.ShapeRange.Left =....

Leider ist die Grafik nicht immer an der selben Stellen.
Hättest du noch einen Tipp für das Problem?

LG Josef

Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Nepumuk
Geschrieben am: 07.11.2020 13:52:54

Hallo Josef,

ich versteh nicht. Willst du die Grafik ab eine bestimmte Zelle andocken?

Gruß
Nepumuk

Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Josef
Geschrieben am: 07.11.2020 14:45:39

Hallo Nepumuk!

Ja, ich habe eine Excel Vorlage wo die Zellen "E2:L31" für eine Grafik bestimmt sind.
Und für jedes neue Objekt erstelle ich eine neue Excel Datei mit dem Objektfoto.

Und mit dem ersten Marko definiere ich das Bild und mit dem zweiten Marko möchte ich das Bild
im vorgesehen Bereich einfügen. Jedoch soll das Foto das Seitenverhältnis beibehalten.

Gruß Josef

Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Nepumuk
Geschrieben am: 07.11.2020 15:43:53

Hallo Josef,

ich muss das Bild schon vor dem Einfügen drehen. Ansonsten rechnet Excel immer mit den Proportionen wie wenn es nicht gedreht wurde.

Teste mal:

Option Explicit

Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long, _
    ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Long) As Long
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
    ByVal handle As LongPtr, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As LongPtr

Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

Public Sub ImageToClipBoard()
    
    Dim strFilepath As String
    Dim lngptrReturn As LongPtr
    Dim objImageFile As Object, objImageProcess As Object
    Dim objFileDialog As FileDialog
    
    Set objFileDialog = Application.FileDialog(fileDialogType:=msoFileDialogFilePicker)
    
    With objFileDialog
        
        .AllowMultiSelect = False
        With .Filters
            If .Count > 0 Then Call .Delete
            Call .Add(Description:="Bilddateien", Extensions:="*.jpg")
        End With
        .InitialFileName = "G:\Eigene Dateien\Eigene Bilder\" 'Anpassen !!!
        .InitialView = msoFileDialogViewThumbnail
        .Title = "Bild auswählen"
        If .Show Then strFilepath = .SelectedItems(1)
        
    End With
    
    Set objFileDialog = Nothing
    
    If strFilepath <> vbNullString Then
        
        Set objImageFile = CreateObject(Class:="WIA.ImageFile")
        Set objImageProcess = CreateObject(Class:="WIA.ImageProcess")
        
        Call objImageFile.LoadFile(Filename:=strFilepath)
        
        Call objImageProcess.Filters.Add(FilterID:=objImageProcess.FilterInfos("RotateFlip").FilterID)
        
        objImageProcess.Filters(1).Properties("RotationAngle") = 90
        
        Set objImageFile = objImageProcess.Apply(Source:=objImageFile)
        
        Call OpenClipboard(Application.hwnd)
        Call EmptyClipboard
        
        lngptrReturn = CopyImage(objImageFile.FileData.Picture.handle, IMAGE_BITMAP, _
            0&, 0&, LR_COPYRETURNORG)
        
        Call SetClipboardData(CF_BITMAP, lngptrReturn)
        Call CloseClipboard
        
        Set objImageFile = Nothing
        Set objImageProcess = Nothing
        
    End If
End Sub

Public Sub ImageToTable()
    
    If IsClipboardFormatAvailable(CF_BITMAP) Then
        
        ActiveSheet.Paste
        
        With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
            
            .LockAspectRatio = True
            .Top = Rows(2).Top
            .Left = Columns(5).Left
            .Height = Range("E2:L31").Height
            If .Width > Range("E2:L31").Width Then .Width = Range("E2:L31").Width
            
        End With
    Else
        Call MsgBox("Kein Bild im ClipBoard.", vbExclamation, "Hinweis")
    End If
End Sub

Gruß
Nepumuk

Betrifft: AW: Bild in Zwischenablage importieren & exportieren
von: Josef
Geschrieben am: 07.11.2020 16:33:22

Hallo Nepumuk!

Funktioniert hervorragend!!! Vielen Dank.

LG Josef

Beiträge aus dem Excel-Forum zum Thema "Bild in Zwischenablage importieren & exportieren"