kathrin.boettger@me.com
25.02.2021 14:11:46
Käthe
ich arbeite grade an einem Makro, dass einen bestimmten Bereich meiner Excel Datei in ein PNG umwandelt und im gleichen Ordner abspeichert. Soweit so gut. Jetzt möchte ich aber, dass die Größe des Bildes immer 950 x 650 Pixel sind. Auf meinem Rechner bekomme ich das auch zum Laufen, wenn aber Kollegen das gleiche bei sich probieren, hat das Bild plötzlich 634 x 434 Pixel. Da ich das auf unterschiedliche Auflösungen geschoben habe, habe ich ein API aus dem Internet eingefügt, dass das umrechnen sollte, funktioniert aber nicht. Weiß da zufällig jemand weiter? Hier der Code, die Datei habe ich auch nochmal angehängt. Ich wäre sehr dankbar über jeden Tipp!!
Viele Grüße
Käthe
In einem allgemeinen Modul:
'** API-Funktion zum Auslesen der Bildschirmauflösung
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Declare
Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Const X_RESOLUTION = 1920
Public Const Y_RESOLUTION = 1080
Code des Tabellenblatts:
Sub ExportImage()
Dim sFilePath As String
Dim sView As String
Dim XFactor As Single ' Horizontal resize ratio
Dim YFactor As Single ' Vertical resize ratio
XFactor = GetSystemMetrics(SM_CXSCREEN) / X_RESOLUTION
YFactor = GetSystemMetrics(SM_CYSCREEN) / Y_RESOLUTION
'Captures current window view
sView = Windows("Layout.xlsm").View
'Sets the current view to normal
ActiveWindow.View = xlNormalView
'Temporarily disable screen updating
Application.ScreenUpdating = False
Set Sheet = ThisWorkbook.Worksheets("Sheet1")
Sheet.PageSetup.PrintArea = Sheet.Range("A1:P31").Address
'Set the file path to export the image to the user's desktop
sFilePath = ActiveWorkbook.Path & "\Layout.png"
'Export print area as correctly scaled PNG image
Windows("Layout.xlsm").Zoom = 100
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
'Set size of PNG impage depending on screen resolution
Set chartobj = Sheet.ChartObjects.Add(0, 0, 475 * XFactor, 325 * YFactor)
chartobj.Activate
chartobj.Chart.Paste
chartobj.Activate
chartobj.Chart.Export sFilePath
chartobj.Delete
'Returns to the previous view
ActiveWindow.View = sView
'Re-enables screen updating
Application.ScreenUpdating = True
End Sub
https://www.herber.de/bbs/user/144242.xlsm