AW: Bild in Zwischenablage importieren & exportieren
07.11.2020 15:43:53
Nepumuk
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