Foto verkleinert einfügen / Chart.Paste Problem
26.09.2019 17:44:29
Roland
Mit unten stehendem Code kann der User ein Foto auf seinem Rechner auswählen. Anschließend wird das Foto in einem Diagramm auf die richtige Grösse verkleinert, nach C:\Temp exportiert und auf das Tabellenblatt eingefügt.
Das hat bis Office 2013 einwandfrei funktioniert. Mit Office 365 bleibt das exportierte Bild entweder weiß oder es wird das Wasserzeichen des Charts angezeigt.
Gemäß diversen Forums-Einträgen muss unter Office 365 die ChartArea ja selektiert werden. Das habe ich gemacht. Das Bild wird aber trotzdem nicht angezeigt.
Komischerweise funktioniert das Programm im Debug-Modus (F8).
Kann mir jemand weiterhelfen?
Herzlichen Dank
Gruß, Roland
Option Explicit
Public Const strFilePathBildKlein As String = "C:\temp\TestFoto.jpg"
Public Const strMyPwd As String = "Test"
Sub FotoVerkleinern()
Dim sngWidth, sngHeight As Single
Dim objChart As Chart, objChartObject As ChartObject
Dim strOrgFaktor, strZellenBreite, strFilePath As String
Dim objBild As Object
strZellenBreite = Range("A5:B5").Width
strFilePath = Application.GetOpenFilename("Only Picture (*.jpg), *.jpg", Title:="Select _
Picture", MultiSelect:=False)
Set objBild = ActiveSheet.Pictures.Insert(strFilePath)
strOrgFaktor = objBild.Width / objBild.Height
objBild.Cut
sngWidth = strZellenBreite
sngHeight = strZellenBreite / strOrgFaktor
Application.ScreenUpdating = False
Set objChart = Charts.Add
objChart.Activate
ActiveWindow.Zoom = 100
Set objChartObject = objChart.ChartObjects.Add(0, 0, sngWidth, sngHeight)
With objChartObject.Chart
.ChartArea.Select
.Paste
.Export Filename:=strFilePathBildKlein, _
FilterName:="jpg", Interactive:=False
End With
Application.DisplayAlerts = False
objChart.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set objBild = Nothing
End Sub
Sub FotoEinfuegen()
Dim str_FotoNummer As String
Dim lng_ScrollPosition As Long
Application.ScreenUpdating = False
ActiveSheet.Unprotect strMyPwd
mdl_Steuerung.FotoVerkleinern
With Tabelle1
lng_ScrollPosition = ActiveWindow.ScrollRow
Select Case Application.Caller
Case "pic_Foto1"
str_FotoNummer = "pic_Foto1"
Case "pic_Foto2"
str_FotoNummer = "pic_Foto2"
Case "pic_Foto3"
str_FotoNummer = "pic_Foto3"
Case Else
ActiveSheet.Protect strMyPwd
Exit Sub
End Select
.Shapes(str_FotoNummer).Fill.UserPicture (strFilePathBildKlein)
End With
Kill (strFilePathBildKlein)
ActiveSheet.Protect strMyPwd
ActiveWindow.ScrollRow = lng_ScrollPosition
Application.ScreenUpdating = True
End Sub
Sub FotoEntfernen()
Dim str_FotoNummer As String
Dim lng_ScrollPosition As Long
ActiveSheet.Unprotect strMyPwd
With Tabelle1
lng_ScrollPosition = ActiveWindow.ScrollRow
Select Case Application.Caller
Case "pic_FotoDelete1"
str_FotoNummer = "pic_Foto1"
Case "pic_FotoDelete2"
str_FotoNummer = "pic_Foto2"
Case "pic_FotoDelete3"
str_FotoNummer = "pic_Foto3"
Case Else
ActiveSheet.Protect strMyPwd
Exit Sub
End Select
.Shapes(str_FotoNummer).Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.Shapes(str_FotoNummer).Fill.Transparency = 1
End With
ActiveSheet.Protect strMyPwd
ActiveWindow.ScrollRow = lng_ScrollPosition
End Sub