Hi,
recently, Office 2016 in 64bit was rolled in my office and (of course) some things refuse to work out of the box. In this special case, the emf export macro of mine changed its usual behaviour. After upgrading the header the image quality of the exported image is significantly worse than it used to be. On the right hand side there is the "new" version and on the left the older one (click to enlarge).
The macro is:
Has someone solved this already or can help to finde the error? Due to the quality requirements, a change to bmp, png, gif is not and option and I need the pictures for my papers.
Thanks in advance
recently, Office 2016 in 64bit was rolled in my office and (of course) some things refuse to work out of the box. In this special case, the emf export macro of mine changed its usual behaviour. After upgrading the header the image quality of the exported image is significantly worse than it used to be. On the right hand side there is the "new" version and on the left the older one (click to enlarge).
The macro is:
Code:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As LongPtr, ByVal lpszFile As String) As Long
Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As LongPtr) As Long
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
#End If
Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const CF_ENHMETAFILE As Long = 14
Dim ReturnValue As Long
OpenClipboard 0
ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)
EmptyClipboard
CloseClipboard
'// Release resources to it eg You can now delete it if required
'// or write over it. This is a MUST
DeleteEnhMetaFile ReturnValue
fnSaveAsEMF = (ReturnValue <> 0)
End Functio
Sub SaveItToEMF()
Dim sFileName As String
Dim sCellCharacter As String
Dim x As Integer
Selection.Copy
sFileName = InputBox("Enter filename for export:", "Export object", sFileName)
For x = 1 To Len(sFileName)
sCellCharacter = Mid(sFileName, x, 1)
If sCellCharacter Like "[</*\?%öäüß]" Then
sFileName = Replace(sFileName, sCellCharacter, "_", 1) ', Replaces all illegal filename characters with "_"
End If
If Asc(sCellCharacter) <= 32 Then
sFileName = Replace(sFileName, sCellCharacter, "_", 1) ' Replaces all non printable characters with "_"
End If
Next
sFileName = ActiveWorkbook.Path & "\..\Bilder\" & sFileName & ".emf"
If fnSaveAsEMF(sFileName) Then
MsgBox "Saved", vbInformation
Else
MsgBox "NOT Saved!", vbCritical
End If
End Sub
Thanks in advance