экспортировать графики Excel как * .emf - PullRequest
Новая
       51

экспортировать графики Excel как * .emf

0 голосов
/ 16 марта 2020

Я обнаружил это сообщение, но, к сожалению, не ответил на вопрос, который пришел мне в голову на КАК ЭКСПОРТИРОВАТЬ ГРАФЫ ИЗ EXCEL AS * .EMF

Диаграмма экспорта в Excel в wmf или emf?

Представленный код не работает для меня. Что я сделал, так это расширил каждую " Закрытую функцию объявления " следующим образом " Закрытое объявление функции PtrSafe ", чтобы сделать ее применимой для 64-бит.

КОД : 

Option Explicit

Private Declare PtrSafe Function OpenClipboard _
Lib "user32" ( _
    ByVal hwnd As Long) _
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

'// CreateMetaFileA DeleteEnhMetaFile
Private Declare PtrSafe Function CopyEnhMetaFileA _
Lib "gdi32" ( _
    ByVal hENHSrc As Long, _
    ByVal lpszFile As String) _
As Long

Private Declare PtrSafe Function DeleteEnhMetaFile _
Lib "gdi32" ( _
    ByVal hemf As Long) _
As Long

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 Function

Sub SaveIt()
Charts.Add
ActiveChart.ChartArea.Select
Selection.Copy
If fnSaveAsEMF("C:\Excel001.emf") Then
    MsgBox "Saved", vbInformation
Else
    MsgBox "NOT Saved!", vbCritical
End If

Я хочу использовать этот код для автоматического экспорта графиков из рабочих таблиц с именами рабочих таблиц в указанную c папку в пределах oop, если это возможно. Выделите, если это возможно выполнить с помощью кнопки.

Пока я запускаю код, все, что я получаю, это сообщение "НЕ СОХРАНЕНО". Я использую Excel 365 ProPlus, в случае, если это имеет какое-либо отношение.

Я был бы очень признателен, если бы кто-то объяснил мне, как работает этот код и что мне нужно реализовать там

1 Ответ

0 голосов
/ 16 марта 2020

это некоторый код, который я использовал, функция user32, которая напрямую имитирует взаимодействие с человеком, - это единственный способ, с помощью которого я могу сохранить чаты в различных форматах с помощью vba, также его текущие операторы предназначены для активного листа / рабочей книги, которая, очевидно, может будут изменены, если вы создаете панель управления, где диаграммы остаются на других листах, если у вас есть какие-либо вопросы, вы можете написать мне на howtovba@gmail.com;

Option Explicit

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

'// CreateMetaFileA DeleteEnhMetaFile
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


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 Function

Sub SaveIt()
Charts.Add
    ActiveChart.ChartArea.Select
    Selection.Copy
    If fnSaveAsEMF("C:\Excel001.emf") Then 'the name excluding the .emf can be changed
        MsgBox "Saved", vbInformation
    Else
        MsgBox "NOT Saved!", vbCritical
    End If

End Sub
...