I am trying to export an Excel chart in SVG format using VBA.
Set objChrt = ActiveChart.Parent
objChrt.Activate
Set curChart = objChrt.Chart
curChart.Export fileName:=fileName, FilterName:="SVG"
If I replace "SVG" by "PNG", the export works exactly as intended and produces a valid PNG file. However, "SVG" results in an empty file. (Manually, there is an option to save as SVG inside Excel 365, so the export filter exists).
According to the documentation, Filtername is "The language-independent name of the graphic filter as it appears in the registry.", but I couldn't find anything like that in the registry, and either way, it's hard to imagine the SVG filtername being named anything other than "SVG".
Is there a way to export a Chart in SVG format using VBA?
Note: There is another question about Chart.export producing an empty file, and the fix was to use ChartObject.Activate before the export. This question is different because the code works correctly with "PNG" but fails with "SVG" (so it's not an issue related to activation or visibility). Also the recommended fix does not work.
Exporting in vector format:
If your main issue is exporting the charts in some vector format, I recommend just exporting as PDF, as this is very easy:
Set curChart = objChrt.Chart
objChrt.ExportAsFixedFormat xlTypePDF, "YourChart"
The PDF now contains your chart as a vector graphic and PDF is a widely supported format for further processing.
If you absolutely need to convert the chart to .svg you can do so from the command line (and therefore easily automatable) using the open-source software Inkscape or so I thought :/.
Converting to SVG:
Unfortunately, the Inkscape conversion didn't seem to work for me so I implemented it using the open-source pdf rendering toolkit Poppler. (Install instructions at the bottom of this post)
This library provides the command line utility pdftocairo, which will be used in the following solution:
Sub ExportChartToSVG()
Dim MyChart As ChartObject
Set MyChart = Tabelle1.ChartObjects("Chart 1")
Dim fileName As String
fileName = "TestExport"
Dim pathStr As String
pathStr = ThisWorkbook.Path
' Export chart as .pdf
MyChart.Chart.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=pathStr & "\" & fileName
' Convert .pdf file to .svg
Dim ret As Double
ret = Shell("cmd.exe /k cd /d """ & pathStr & """ & " & _
"pdftocairo -svg -f 1 -l 1 " & fileName & ".pdf", vbHide)
End Sub
Note that the text in the resulting .svg file isn't selectable and the file is larger than the file generated by manual export (241 KB vs. 88 KB in my test). The file is definitely infinite resolution, so not that weird bitmap embedded in a .svg file one occasionally sees but comes with another little problem:
Unfortunately, the ExportAsFixedFormat method creates a PDF 'page' where the graphic is positioned on the page depending on the position on the worksheet. The .svg conversion unfortunately keeps this 'page' format. I had to learn that getting rid of this problem is not as simple as I initially thought because excel does not support custom page sizes and therefore exporting a chart as .pdf without white borders seems pretty much impossible, see this bountied but unsolved question (Edit: I solved it in the following part and also posted my method as answer to that question). I tried several methods they didn't even think of in this linked question and still didn't manage to get it done properly using only Excel, it might be possible depending on your printer drivers but I'm not going that way...
Exporting to clean SVG without the white bars:
The easiest workaround is to just use Word to properly export the chart as .pdf:
Sub ExportChartToSVG()
Dim MyWorksheet As Worksheet
Set MyWorksheet = Tabelle1
Dim MyChart As ChartObject
Set MyChart = MyWorksheet.ChartObjects(1)
Dim fileName As String
fileName = "TestExport"
Dim pathStr As String
pathStr = ThisWorkbook.Path
'Creating a new Word Document
'this is necessary because Excel doesn't support custom pagesizes
'when exporting as pdf and therefore unavoidably creates white borders around the
'chart when exporting
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
Dim wdDoc As Object
Set wdDoc = wdApp.Documents.Add
MyChart.Copy
wdDoc.Range.Paste
Dim shp As Object
Set shp = wdDoc.Shapes(1)
With wdDoc.PageSetup
.LeftMargin = 0
.RightMargin = 0
.TopMargin = 0
.BottomMargin = 0
.PageWidth = shp.Width
.PageHeight = shp.Height
End With
shp.Top = 0
shp.Left = 0
wdDoc.saveas2 fileName:=pathStr & "\" & fileName, FileFormat:=17 '(wdExportFormatPDF)
wdApp.Quit 0 '(wdDoNotSaveChanges)
Set wdApp = Nothing
Set wdDoc = Nothing
Set shp = Nothing
' Convert .pdf file to .svg
Dim ret As Double
ret = Shell("cmd.exe /k cd /d """ & pathStr & """ & " & "pdftocairo -svg -f 1 -l 1 " & fileName & ".pdf", vbHide)
End Sub
The resulting .pdf and .svg look exactly the same as the manually exported .svg, with only the .pdf having selectable text. The .pdf file remains in the folder. If necessary, it can easily be deleted later via VBA code...
If this method is used to export a larger number of charts, I strongly recommend moving it into a class and having the class hold an instance of the Word application, so it doesn't constantly reopen and close Word. It has the added benefit of making the actual code to export very terse and clean.
Class-based method for exporting to clean SVG:
The code for exporting becomes very simple:
Sub ExportChartToSVG()
Dim MyWorksheet As Worksheet
Set MyWorksheet = Tabelle1
Dim MyChart As ChartObject
Set MyChart = MyWorksheet.ChartObjects(1)
Dim fileName As String
fileName = "TestExport"
Dim filePath As String
filePath = ThisWorkbook.Path & Application.PathSeparator
Dim oShapeExporter As cShapeExporter
Set oShapeExporter = New cShapeExporter
' Export as many shapes as you want here, before destroying oShapeExporter
' cShapeExporter can export objets of types Shape, ChartObject or ChartArea
oShapeExporter.ExportShapeAsPDF MyChart, filePath, fileName
Set oShapeExporter = Nothing
End Sub
Code for class module called cShapeExporter:
Option Explicit
Dim wdApp As Object
Dim wdDoc As Object
Private Sub Class_Initialize()
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Add
' Setting margins to 0 so we have no white borders!
' If you want, you can set custom white borders for the exported PDF here
With wdDoc.PageSetup
.LeftMargin = 0
.RightMargin = 0
.TopMargin = 0
.BottomMargin = 0
End With
End Sub
Private Sub Class_Terminate()
' Important: Close Word instance as the object is destroyed.
wdApp.Quit 0 '(0 = wdDoNotSaveChanges)
Set wdApp = Nothing
Set wdDoc = Nothing
End Sub
Public Sub ExportShapeAsPDF(xlShp As Object, _
filePath As String, _
Optional ByVal fileName As String = "")
' Defining which objects can be exported, maybe others are also supported,
' they just need to support all the methods and have all the properties used
' in this sub
If TypeName(xlShp) = "ChartObject" Or _
TypeName(xlShp) = "Shape" Or _
TypeName(xlShp) = "ChartArea" Then
'fine
Else
MsgBox "Exporting Objects of type " & TypeName(xlShp) & _
" not supported, sorry."
Exit Sub
End If
xlShp.Copy
wdDoc.Range.Paste
Dim wdShp As Object
Set wdShp = wdDoc.Shapes(1)
With wdDoc.PageSetup
.PageWidth = wdShp.Width
.PageHeight = wdShp.Height
End With
wdShp.Top = 0
wdShp.Left = 0
' Export as .pdf
wdDoc.saveas2 fileName:=filePath & fileName, _
FileFormat:=17 '(17 = wdExportFormatPDF)
wdShp.Delete
End Sub
Installing the Poppler utility:
I'm assuming you are using Windows here, on Linux getting Poppler is trivial anyway...
So on Windows, I'd suggest installing it using the chocolatey packet manager for Windows. To install chocolatey, you can follow these instructions (takes <5 min).
When you have chocolatey, you can install Poppler with the simple command
choco install poppler
and you are ready to run the code I proposed for converting .pdf to .svg.
If you prefer installing Poppler in a different way, there are various options described here, but I'd like to add some notes about some of the methods:
Downloading the binaries didn't work for me, running the utility would always result in errors.
Installing via Anaconda (conda install -c conda-forge poppler) somehow didn't work for me either. The installation just failed.
Installing via the Windows Subsystem for Linux did work, and the utility worked too, but if you don't already have wsl including a distribution installed you will have to download and install several hundred MB ob data which might be overkill.
If you have MiKTeX installed, the utility is supposed to be included (and was in my case). I tried the utility from my MiKTeX install, and somehow it didn't work.
Exporting to .svg without any external applications using only Excel and VBA
I had to create a new answer because there wasn't enough space in my other one. Personally, I would prefer to use this solution, as there are no external dependencies.
I can now confidently answer this question: Is there a way to export a Chart in SVG format using VBA?
Yes.
It's a hacky mess but it works for now... at least on my machine.
And I tried to create a simple interface for the code so you don't really have to understand it to use it. Still, first I will explain how it works, what problems exist that had to be overcome, and how I managed to solve them. Then, I give a short and simple usage example and instructions. So if you are not interested in the technicalities, you can skip to the easy part.
What's the idea?
The code basically tries to just use the manual export method. There are several problems with this, the first being yet another bug in the Chart.Export method. Chart.Export Interactive:=True is supposed to open the desired dialog box, but this just doesn't work. By leveraging rarely used and even undocumented shortcuts (Probably not, but I had to find one of them with the brute force method), the export window can be opened very reliably using SendKeys "+{F10}" followed by SendKeys "g". The first hurdle is taken, but the trouble has only just begun!
It turns out, that opening a modal Dialog stops all code execution in the entire Application. Even if we call code in another application instance before we open the dialog, how can we keep it running there and return at the same time to finish opening the dialog? It sounds impossible because VBA is strictly single-threaded...
Well, it turns out, the single threading is not quite so strict :) The solution is called Application.OnTime, which starts a procedure at a predetermined time in the future. That procedure has to run in a different instance of Excel.Application because Application.OnTime will only start a procedure if the application is in certain modes (Ready, Copy, Cut, or Find), and having VBA code running or having a modal dialog open are certainly not among those. Therefore, before the dialog is opened, we have to create a background instance of the Excel app, insert VBA code into it and call that code, which will then schedule other code to start running in the background instance once the dialog is open. Note: Because we want to insert the code automatically into the background instance, we need to enable Trust access to the VBA project object model.
The next question is: How can we work with the Windows dialog box using only VBA code? I tried very hard to avoid more SendKeys but unfortunately, some problems were just out of my league. I managed to get all the window and control handles of the dialog via EnumChildWindows and used the information to insert text into the "FileName" ComboBox. Since you can also insert the path there, the only problems left were selecting ".svg" in the FileFormat ComboBox and clicking the "Save" Button.
Changing the selection in the Combobox is relatively easy using Windows API functions but the problem is to actually get it to register the change. It appeared to have changed in the dialog but when I clicked "Save" it still saved as .png. I spent hours in Spy++ monitoring the messages that are sent during a manual change but I wasn't able to reproduce them with VBA. The language is truly horrible for low-level tasks, trying to align bits with VBA is a pain. Anyways, because of this, it had to be SendKeys again for changing the file format and pressing 'Save'.
I tried to be very careful with the SendKeys usage, implementing various safety checks, and pulling the target window to the front before every usage, but you can never be 100% safe with it.
Because the method requires a background instance of an app once again, I implemented a class for a ShapeExporter object again. Creating the object opens the background app, destroying the object closes it.
Simple usage guide
The following procedure will export all ChartObjects in the specified worksheet to the folder the workbook is saved in.
Sub ExportEmbeddedChartToSVG()
Dim MyWorksheet As Worksheet
Set MyWorksheet = Application.Worksheets("MyWorksheet")
'Creating the ShapeExporter object
Dim oShapeExporter As cShapeExporter
Set oShapeExporter = New cShapeExporter
'Export as many shapes as you want here, before destroying oShapeExporter
Dim oChart As ChartObject
For Each oChart In MyWorksheet.ChartObjects
'the .ExportShapeAsSVG method of the object takes three arguments:
'1. The Chart or Shape to be exported
'2. The target filename
'3. The target path
oShapeExporter.ExportShapeAsSVG oChart, oChart.Name, ThisWorkbook.Path
Next oChart
'When the object goes out of scope, its terminate procedure is automatically called
'and the background app is closed
Set oShapeExporter = Nothing
End Sub
For the code to work, you must first:
Trust access to the VBA project object model (for reason see detailed description of the macro)
Create a class module, rename it to "cShapeExporter", and paste the following code into it:
'Class for automatic exporting in SVG-Format
'Initial author: Guido Witt-Dörring, 09.12.2020
'https://stackoverflow.com/a/65212838/12287457
'Note:
'When objects created from this class are not properly destroyed, an invisible
'background instance of Excel will keep running on your computer. In this
'case, you can just close it via the Task Manager.
'For example, this will happen when your code hits an 'End' statement, which
'immediately stops all code execution, or when an unhandled error forces
'you to stop code execution manually while an instance of this class exists.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As LongPtr) As Boolean
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Boolean
Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hWnd As LongPtr) As Boolean
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Boolean
Private Declare Function IsWindowVisible Lib "User32" (ByVal hWnd As Long) As Boolean
Private Declare Function IsIconic Lib "User32" Alias "IsIconic" (ByVal hWnd As long) As boolean
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private NewXlAppInstance As Excel.Application
Private xlWbInOtherInstance As Workbook
Private Sub Class_Initialize()
Set NewXlAppInstance = New Excel.Application
Set xlWbInOtherInstance = NewXlAppInstance.Workbooks.Add
NewXlAppInstance.Visible = False
On Error Resume Next
xlWbInOtherInstance.VBProject.References.AddFromFile "scrrun.dll"
xlWbInOtherInstance.VBProject.References.AddFromFile "FM20.dll"
On Error GoTo 0
Dim VbaModuleForOtherInstance As VBComponent
Set VbaModuleForOtherInstance = xlWbInOtherInstance.VBProject.VBComponents.Add(vbext_ct_StdModule)
VbaModuleForOtherInstance.CodeModule.AddFromString CreateCodeForOtherXlInstance
End Sub
Private Sub Class_Terminate()
NewXlAppInstance.DisplayAlerts = False
NewXlAppInstance.Quit
Set xlWbInOtherInstance = Nothing
Set NewXlAppInstance = Nothing
End Sub
Public Sub ExportShapeAsSVG(xlShp As Object, FileName As String, FilePath As String)
'Check if path exists:
If Not ExistsPath(FilePath) Then
If vbYes = MsgBox("Warning, you are trying to export a file to a path that doesn't exist! Continue exporting to default path? " & vbNewLine & "Klick no to resume macro without exporting or cancel to debug.", vbYesNoCancel, "Warning") Then
FilePath = ""
ElseIf vbNo Then
Exit Sub
ElseIf vbCancel Then
Error 76
End If
End If
If TypeName(xlShp) = "ChartObject" Or TypeName(xlShp) = "Shape" Or TypeName(xlShp) = "Chart" Or TypeName(xlShp) = "ChartArea" Then
'fine
Else
MsgBox "Exporting Objects of type " & TypeName(xlShp) & " not supported, sorry."
Exit Sub
End If
If TypeName(xlShp) = "ChartArea" Then Set xlShp = xlShp.Parent
retry:
SetForegroundWindow FindWindow("XLMAIN", ThisWorkbook.Name & " - Excel")
If Not Application.Visible Then 'Interestingly, API function "IsWindowVisible(Application.hWnd)" doesn't work here! (maybe because of multi monitor setup?)
MsgBox "The workbook must be visible for the svg-export to proceed! It must be at least in window mode!"
Application.WindowState = xlNormal
Application.Visible = True
Sleep 100
GoTo retry
End If
If IsIconic(Application.hWnd) Then 'Interestingly "Application.WindowState = xlMinimized" doesn't work here!"
MsgBox "The workbook can't be minimized for the svg-export to proceed! It must be at least in window mode!"
Application.WindowState = xlNormal
Sleep 100
GoTo retry
End If
'check if background instance still exists and start support proc
On Error GoTo errHand
NewXlAppInstance.Run "ScheduleSvgExportHelperProcess", Application.hWnd, ThisWorkbook.Name, FileName, FilePath
On Error GoTo 0
Sleep 100
xlShp.Activate
SetForegroundWindow FindWindow("XLMAIN", ThisWorkbook.Name & " - Excel")
SendKeys "+{F10}"
DoEvents
SendKeys "g"
DoEvents
Exit Sub
errHand:
MsgBox "Error in ShapeExporter Object. No more shapes can be exported."
Err.Raise Err.Number
End Sub
Public Function ExistsPath(ByVal FilePath As String) As Boolean
Dim oFso As Object
Dim oFolder As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
'Setting the Folder of the Filepath
On Error GoTo PathNotFound
Set oFolder = oFso.GetFolder(Left(Replace(FilePath & "\", "\\", "\"), Len(Replace(FilePath & "\", "\\", "\")) - 1))
On Error GoTo 0
ExistsPath = True
Exit Function
PathNotFound:
ExistsPath = False
End Function
Private Function CreateCodeForOtherXlInstance() As String
Dim s As String
s = s & "Option Explicit" & vbCrLf
s = s & "" & vbCrLf
s = s & "#If VBA7 Then" & vbCrLf
s = s & " Public Declare PtrSafe Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)" & vbCrLf
s = s & " Private Declare PtrSafe Function GetForegroundWindow Lib ""user32"" () As LongPtr" & vbCrLf
s = s & " Private Declare PtrSafe Function GetWindowText Lib ""user32"" Alias ""GetWindowTextA"" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long" & vbCrLf
s = s & " Private Declare PtrSafe Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr" & vbCrLf
s = s & " Private Declare PtrSafe Function SetForegroundWindow Lib ""user32"" (ByVal hWnd As LongPtr) As Boolean" & vbCrLf
s = s & " Private Declare PtrSafe Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr" & vbCrLf
s = s & " Private Declare PtrSafe Function GetClassName Lib ""user32"" Alias ""GetClassNameA"" (ByVal hWnd As LongPtr, ByVal lpStr As String, ByVal nMaxCount As Long) As Long" & vbCrLf
s = s & " Private Declare PtrSafe Function EnumChildWindows Lib ""user32"" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Boolean" & vbCrLf
s = s & " Private Declare PtrSafe Function GetWindowTextLength Lib ""user32"" Alias ""GetWindowTextLengthA"" (ByVal hWnd As LongPtr) As Long" & vbCrLf
s = s & " Private Declare PtrSafe Function GetWindowLongPtr Lib ""user32"" Alias ""GetWindowLongPtrA"" (ByVal hWnd As LongPtr, ByVal nindex As Long) As LongPtr" & vbCrLf
s = s & "#Else" & vbCrLf
s = s & " Public Declare Sub Sleep Lib ""kernel32"" (ByVal lngMilliSeconds As Long)" & vbCrLf
s = s & " Private Declare Function GetForegroundWindow Lib ""user32"" () As Long" & vbCrLf
s = s & " Private Declare Function GetWindowText Lib ""user32"" Alias ""GetWindowTextA"" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long" & vbCrLf
s = s & " Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long" & vbCrLf
s = s & " Private Declare Function SetForegroundWindow Lib ""user32"" (ByVal hwnd As Long) As Boolean" & vbCrLf
s = s & " Private Declare Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long" & vbCrLf
s = s & " Private Declare Function GetClassName Lib ""user32"" Alias ""GetClassNameA"" (ByVal hwnd As Long, ByVal lpStr As String, ByVal nMaxCount As Long) As Long" & vbCrLf
s = s & " Private Declare Function EnumChildWindows Lib ""User32"" (ByVal hwndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As boolean" & vbCrLf
s = s & " Private Declare Function GetWindowTextLength Lib ""User32"" Alias ""GetWindowTextLengthA"" (ByVal hwnd As Long) As Long" & vbCrLf
s = s & " Private Declare Function GetWindowLongPtr Lib ""User32"" Alias ""GetWindowLongPtrA"" (ByVal hwnd As Long, ByVal nindex As Long) As Long" & vbCrLf
s = s & "#End If" & vbCrLf
s = s & "" & vbCrLf
s = s & "Private Const GWL_ID = -12" & vbCrLf
s = s & "" & vbCrLf
s = s & "Private Const WM_SETTEXT = &HC" & vbCrLf
s = s & "" & vbCrLf
s = s & "'Const for this Application:" & vbCrLf
s = s & "Private Const dc_Hwnd = 1" & vbCrLf
s = s & "Private Const dc_ClassName = 2" & vbCrLf
s = s & "Private Const dc_CtlID = 3" & vbCrLf
s = s & "Private Const dc_CtlText = 4" & vbCrLf
s = s & "" & vbCrLf
s = s & "Private Const Window_Search_Timeout As Single = 5#" & vbCrLf
s = s & "Public ChildWindowsPropDict As Object" & vbCrLf
s = s & "" & vbCrLf
s = s & "#If VBA7 Then" & vbCrLf
s = s & " Private Function GetCtlText(ByVal hctl As LongPtr) As String" & vbCrLf
s = s & "#Else" & vbCrLf
s = s & " Private Function GetCtlText(ByVal hctl As Long) As String" & vbCrLf
s = s & "#End If" & vbCrLf
s = s & " Dim ControlText As String" & vbCrLf
s = s & " On Error GoTo WindowTextTooLarge" & vbCrLf
s = s & " ControlText = Space(GetWindowTextLength(hctl) + 1)" & vbCrLf
s = s & " GetWindowText hctl, ControlText, Len(ControlText)" & vbCrLf
s = s & " GetCtlText = ControlText 'Controls Text" & vbCrLf
s = s & " Exit Function" & vbCrLf
s = s & " " & vbCrLf
s = s & "WindowTextTooLarge:" & vbCrLf
s = s & " ControlText = Space(256)" & vbCrLf
s = s & " On Error GoTo -1" & vbCrLf
s = s & " GetWindowText hctl, ControlText, Len(ControlText)" & vbCrLf
s = s & " GetCtlText = ControlText 'Controls Text" & vbCrLf
s = s & "End Function" & vbCrLf
s = s & "" & vbCrLf
s = s & "#If VBA7 Then" & vbCrLf
s = s & " Private Function EnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As LongPtr) As Long" & vbCrLf
s = s & "#Else" & vbCrLf
s = s & " Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long" & vbCrLf
s = s & "#End If" & vbCrLf
s = s & " Dim ClassName As String" & vbCrLf
s = s & " Dim subCtlProp(1 To 4) As Variant" & vbCrLf
s = s & " " & vbCrLf
s = s & " subCtlProp(dc_Hwnd) = hWnd 'Controls Handle" & vbCrLf
s = s & " " & vbCrLf
s = s & " ClassName = Space(256)" & vbCrLf
s = s & " GetClassName hWnd, ClassName, Len(ClassName)" & vbCrLf
s = s & " subCtlProp(dc_ClassName) = Trim(CStr(ClassName)) 'Controls ClassName" & vbCrLf
s = s & " " & vbCrLf
s = s & " subCtlProp(dc_CtlID) = GetWindowLongPtr(hWnd, GWL_ID) 'Controls ID" & vbCrLf
s = s & " " & vbCrLf
s = s & " subCtlProp(dc_CtlText) = GetCtlText(hWnd) 'Controls Text 'Doesn't always work for some reason..." & vbCrLf
s = s & " '(sometimes returns """" when Spy++ finds a string)" & vbCrLf
s = s & " ChildWindowsPropDict.Add key:=CStr(hWnd), Item:=subCtlProp" & vbCrLf
s = s & " " & vbCrLf
s = s & " 'continue to enumerate (0 would stop it)" & vbCrLf
s = s & " EnumChildProc = 1" & vbCrLf
s = s & "End Function" & vbCrLf
s = s & "" & vbCrLf
s = s & "#If VBA7 Then" & vbCrLf
s = s & " Private Sub WriteChildWindowsPropDict(hWnd As LongPtr)" & vbCrLf
s = s & "#Else" & vbCrLf
s = s & " Private Sub WriteChildWindowsPropDict(hWnd As Long)" & vbCrLf
s = s & "#End If" & vbCrLf
s = s & " On Error Resume Next" & vbCrLf
s = s & " Set ChildWindowsPropDict = Nothing" & vbCrLf
s = s & " On Error GoTo 0" & vbCrLf
s = s & " Set ChildWindowsPropDict = CreateObject(""Scripting.Dictionary"")" & vbCrLf
s = s & " EnumChildWindows hWnd, AddressOf EnumChildProc, ByVal 0&" & vbCrLf
s = s & "End Sub" & vbCrLf
s = s & "" & vbCrLf
s = s & "Private Function ExistsFileInPath(ByVal FileName As String, ByVal FilePath As String, Optional warn As Boolean = False) As Boolean" & vbCrLf
s = s & " Dim oFso As Object" & vbCrLf
s = s & " Dim oFile As Object" & vbCrLf
s = s & " Dim oFolder As Object" & vbCrLf
s = s & " " & vbCrLf
s = s & " Set oFso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
s = s & " 'Setting the Folder of the Filepath" & vbCrLf
s = s & " On Error GoTo PathNotFound" & vbCrLf
s = s & " Set oFolder = oFso.GetFolder(Left(Replace(FilePath & ""\"", ""\\"", ""\""), Len(Replace(FilePath & ""\"", ""\\"", ""\"")) - 1))" & vbCrLf
s = s & " On Error GoTo 0" & vbCrLf
s = s & " " & vbCrLf
s = s & " 'Writing all Filenames of the Files in the Folder to flStr" & vbCrLf
s = s & " For Each oFile In oFolder.Files" & vbCrLf
s = s & " If oFile.Name = FileName Then" & vbCrLf
s = s & " ExistsFileInPath = True" & vbCrLf
s = s & " Exit Function" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " Next oFile" & vbCrLf
s = s & " " & vbCrLf
s = s & " ExistsFileInPath = False" & vbCrLf
s = s & " Exit Function" & vbCrLf
s = s & " " & vbCrLf
s = s & "PathNotFound:" & vbCrLf
s = s & " If warn Then MsgBox ""The path "" & Chr(10) & FilePath & Chr(10) & "" was not found by the function ExistsFileInPath."" & Chr(10) & ""Returning FALSE""" & vbCrLf
s = s & " ExistsFileInPath = False" & vbCrLf
s = s & "End Function" & vbCrLf
s = s & "" & vbCrLf
s = s & "#If VBA7 Then" & vbCrLf
s = s & " Public Sub ScheduleSvgExportHelperProcess(ByVal Wb1hwnd As LongPtr, ByVal Wb1Name As String, ByVal SvgFileName As String, ByVal SvgFilePath As String)" & vbCrLf
s = s & "#Else" & vbCrLf
s = s & " Public Sub ScheduleSvgExportHelperProcess(ByVal Wb1hwnd As Long, ByVal Wb1Name As String, ByVal SvgFileName As String, ByVal SvgFilePath As String)" & vbCrLf
s = s & "#End If" & vbCrLf
s = s & " If Not Wb1hwnd = FindWindow(""XLMAIN"", Wb1Name & "" - Excel"") Then" & vbCrLf
s = s & " MsgBox ""Error finding Wb1hwnd - something unforseen happened!""" & vbCrLf
s = s & " GoTo badExit" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " " & vbCrLf
s = s & " Application.OnTime Now + TimeValue(""00:00:02""), ""'SvgExportHelperProcess """""" & CStr(Wb1hwnd) & """""", """""" & Wb1Name & """""", """""" & SvgFileName _" & vbCrLf
s = s & " & """""", """""" & SvgFilePath & """"""'"", Now + TimeValue(""00:00:015"")" & vbCrLf
s = s & " Exit Sub" & vbCrLf
s = s & "badExit:" & vbCrLf
s = s & " MsgBox ""Shutting down background instance of excel.""" & vbCrLf
s = s & " Application.DisplayAlerts = False" & vbCrLf
s = s & " Application.Quit" & vbCrLf
s = s & "End Sub" & vbCrLf
s = s & "" & vbCrLf
s = s & "Public Sub SvgExportHelperProcess(ByVal Wb1hwndStr As String, ByVal Wb1Name As String, ByVal SvgFileName As String, ByVal SvgFilePath As String)" & vbCrLf
s = s & " #If VBA7 And Win64 Then" & vbCrLf
s = s & " Dim Wb1hwnd As LongPtr" & vbCrLf
s = s & " Wb1hwnd = CLngPtr(Wb1hwndStr)" & vbCrLf
s = s & " Dim dlgHwnd As LongPtr" & vbCrLf
s = s & " Dim tempHctrl As LongPtr" & vbCrLf
s = s & " #Else" & vbCrLf
s = s & " Dim Wb1hwnd As LongPtr" & vbCrLf
s = s & " Wb1hwnd = CLng(Wb1hwndStr)" & vbCrLf
s = s & " Dim dlgHwnd As Long" & vbCrLf
s = s & " Dim tempHctrl As Long" & vbCrLf
s = s & " #End If" & vbCrLf
s = s & " Dim i As Long" & vbCrLf
s = s & " Dim stopTime As Single" & vbCrLf
s = s & " " & vbCrLf
s = s & " 'Find dialog window handle" & vbCrLf
s = s & " stopTime = Timer() + Window_Search_Timeout" & vbCrLf
s = s & " Do" & vbCrLf
s = s & " dlgHwnd = 0" & vbCrLf
s = s & " Sleep 15" & vbCrLf
s = s & " DoEvents" & vbCrLf
s = s & " SetForegroundWindow Wb1hwnd 'FindWindow(""XLMAIN"", Wb1Name & "" - Excel"")" & vbCrLf
s = s & " Sleep 150" & vbCrLf
s = s & " dlgHwnd = FindWindow(""#32770"", vbNullString)" & vbCrLf
s = s & " Loop Until Timer() > stopTime Or dlgHwnd <> 0" & vbCrLf
s = s & " " & vbCrLf
s = s & " If dlgHwnd = 0 Then" & vbCrLf
s = s & " MsgBox ""Couldn't find dialog window handle!""" & vbCrLf
s = s & " GoTo errHand" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " " & vbCrLf
s = s & " 'Enumerate the child windows of the dialog and write their properties to a dictionary" & vbCrLf
s = s & " WriteChildWindowsPropDict dlgHwnd" & vbCrLf
s = s & "" & vbCrLf
s = s & " 'the first window of class ""Edit"" inside ChildWindowsPropDict will be the filename box" & vbCrLf
s = s & " Dim v As Variant" & vbCrLf
s = s & " For Each v In ChildWindowsPropDict.items" & vbCrLf
s = s & " If Left(CStr(v(dc_ClassName)), Len(CStr(v(dc_ClassName))) - 1) = ""Edit"" Then" & vbCrLf
s = s & " tempHctrl = v(dc_Hwnd)" & vbCrLf
s = s & " 'send message" & vbCrLf
s = s & " SendMessage tempHctrl, WM_SETTEXT, 0&, ByVal SvgFilePath & ""\"" & SvgFileName" & vbCrLf
s = s & " 'we don't need this hwnd anymore" & vbCrLf
s = s & " ChildWindowsPropDict.Remove CStr(v(dc_Hwnd))" & vbCrLf
s = s & " Exit For" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " Next v" & vbCrLf
s = s & "" & vbCrLf
s = s & "retry:" & vbCrLf
s = s & " SetForegroundWindow dlgHwnd" & vbCrLf
s = s & " " & vbCrLf
s = s & " SendKeys ""{TAB}""" & vbCrLf
s = s & " Sleep 250" & vbCrLf
s = s & " SetForegroundWindow dlgHwnd" & vbCrLf
s = s & " For i = 1 To 10" & vbCrLf
s = s & " SendKeys ""{DOWN}""" & vbCrLf
s = s & " Sleep 100" & vbCrLf
s = s & " SetForegroundWindow dlgHwnd" & vbCrLf
s = s & " Next i" & vbCrLf
s = s & " " & vbCrLf
s = s & " SendKeys ""~""" & vbCrLf
s = s & " Sleep 100" & vbCrLf
s = s & " SetForegroundWindow dlgHwnd" & vbCrLf
s = s & " SendKeys ""~""" & vbCrLf
s = s & " Sleep 50" & vbCrLf
s = s & " " & vbCrLf
s = s & " 'give the keystrokes time to process" & vbCrLf
s = s & " Sleep 300" & vbCrLf
s = s & "" & vbCrLf
s = s & " 'Wait until the file appears in the specified path:" & vbCrLf
s = s & " Dim cleanFileName As String" & vbCrLf
s = s & " If InStr(1, Right(SvgFileName, 4), "".svg"", vbTextCompare) = 0 Then" & vbCrLf
s = s & " cleanFileName = SvgFileName & "".svg""" & vbCrLf
s = s & " Else" & vbCrLf
s = s & " cleanFileName = SvgFileName" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " " & vbCrLf
s = s & " Dim retryTime As Single" & vbCrLf
s = s & " retryTime = Timer + 5" & vbCrLf
s = s & " stopTime = Timer + 60 '1 minute timeout." & vbCrLf
s = s & " 'relatively long in case a file already exists dialog appears..." & vbCrLf
s = s & " Do Until ExistsFileInPath(SvgFileName, SvgFilePath, False)" & vbCrLf
s = s & " Sleep 700" & vbCrLf
s = s & " DoEvents" & vbCrLf
s = s & " If Timer > retryTime Then" & vbCrLf
s = s & " 'check if graphic export dialog is top window" & vbCrLf
s = s & " If dlgHwnd = GetForegroundWindow Then GoTo retry" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " If Timer > stopTime Then GoTo timeoutHand" & vbCrLf
s = s & " Loop" & vbCrLf
s = s & " " & vbCrLf
s = s & " Exit Sub" & vbCrLf
s = s & "errHand:" & vbCrLf
s = s & " MsgBox ""Error in the helper process""" & vbCrLf
s = s & " GoTo badExit" & vbCrLf
s = s & " " & vbCrLf
s = s & "timeoutHand:" & vbCrLf
s = s & " MsgBox ""Timeout. It seems like something went wrong creating the file. File "" & cleanFileName & "" didn't appear in folder "" & SvgFilePath & "".""" & vbCrLf
s = s & " GoTo badExit" & vbCrLf
s = s & " " & vbCrLf
s = s & "badExit:" & vbCrLf
s = s & " MsgBox ""Shutting down background instance of excel.""" & vbCrLf
s = s & " Application.DisplayAlerts = False" & vbCrLf
s = s & " Application.Quit" & vbCrLf
s = s & "End Sub" & vbCrLf
s = s & "" & vbCrLf
CreateCodeForOtherXlInstance = s
End Function
When you copy a chart to the clipboard, Excel adds lots of different clipboard formats. Since version 2011 (Application.Build >= 13426), this now includes "image/svg+xml".
So all we have to do is find that format on the clipboard and save it to a file. Which turns out to be fairly annoying.
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" _
Alias "GetClipboardFormatNameW" _
(ByVal wFormat As Long, _
ByVal lpString As LongPtr, _
ByVal nMaxCount As Integer) As Integer
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GlobalUnlock Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateFile Lib "Kernel32" _
Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As LongPtr, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As LongPtr) As LongPtr
Private Declare PtrSafe Function WriteFile Lib "Kernel32" _
(ByVal hFile As LongPtr, _
ByVal lpBuffer As LongPtr, _
ByVal nNumberOfBytesToWrite As Long, _
ByRef lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As LongPtr) As Long
Private Declare PtrSafe Function CloseHandle Lib "Kernel32" (ByVal hObject As LongPtr) As Long
Sub SaveClipboard(formatName As String, filename As String)
Dim fmtName As String
Dim fmt As Long
Dim length As Long
Dim wrote As Long
Dim data As LongPtr
Dim fileHandle As LongPtr
Dim content As LongPtr
Dim ret As Long
If OpenClipboard(ActiveWindow.hwnd) = 0 Then
Exit Sub
End If
fmt = 0
Do
fmt = EnumClipboardFormats(fmt)
If fmt = 0 Then Exit Do
fmtName = String$(255, vbNullChar)
length = GetClipboardFormatName(fmt, StrPtr(fmtName), 255)
If length <> 0 And Left(fmtName, length) = formatName Then
data = GetClipboardData(fmt)
length = CLng(GlobalSize(data))
content = GlobalLock(data)
' use win32 api file handling to avoid copying buffers
fileHandle = CreateFile(filename, &H120089 Or &H120116, 0, 0, 2, 0, 0)
ret = WriteFile(fileHandle, content, length, wrote, 0)
CloseHandle fileHandle
GlobalUnlock data
Exit Do
End If
Loop
CloseClipboard
If fmt = 0 Then
MsgBox "Did not find clipboard format " & formatName
Exit Sub
End If
End Sub
Then just copy the chart and save the svg;
shape.Copy
SaveClipboard "image/svg+xml", "C:\temp\output.svg"
If you don't need .svg in particular then .emf is another vector format. It does not work directly from Excel but it does work using a 'helper' PowerPoint app:
Sub ExportChartToEMF(ByVal ch As Chart, ByVal filePath As String)
Const methodName As String = "ExportChartToEMF"
Const ppShapeFormatEMF As Long = 5
'
If ch Is Nothing Then Err.Raise 91, methodName, "Chart not set"
'
Dim pp As Object
Dim slide As Object
Dim errNumber As Long
'
Set pp = CreateObject("PowerPoint.Application")
With pp.Presentations.Add(msoFalse) 'False so it's not Visible
Set slide = .Slides.AddSlide(.Slides.Count + 1, .Designs(1).SlideMaster.CustomLayouts(1))
End With
'
ch.Parent.Copy
On Error Resume Next
slide.Shapes.Paste.Export filePath, ppShapeFormatEMF
errNumber = Err.Number
On Error GoTo 0
'
pp.Quit
If Err.Number <> 0 Then Err.Raise Err.Number, methodName, "Error while exporting to file"
End Sub
You would use it like:
ExportChartToEMF ActiveChart, "[FolderPath]\[FileName].emf"
If you really need .svg then unfortunately the functionality is not exposed to VBA although it works manually in Excel and PowerPoint via the Save as Picture dialog (right-click on chart shape).
In short, you cannot fully automate the export of chart to .svg file unless you go through an intermediate format (like .emf or .pdf) or manually saving to .svg via the Save as Picture dialog.
Related
Option Explicit
Option Compare Text
Option Base 1
Private Declare PtrSafe Function lstrlen Lib "kernal32" Alias "lstrlenW" ( _
ByVal lpString As Long) As LongPtr
Private Declare PtrSafe Function StrTrim Lib "shlwapi" Alias "StrTrimW" ( _
ByVal pszSource As Long, _
ByVal pszTrimChars As Long) As LongPtr
Private Function TrimWS(ByVal Text As String) As String
'unicode safe
Dim WHITE_SPACE As String
WHITE_SPACE = " " & vbTab & vbCr & vbLf & Chr(1) & Chr(2) & Chr(3) & Chr(4) & Chr(5) & Chr(6) & Chr(7) & Chr(8) & Chr(9) & Chr(10) & Chr(11) & Chr(12) & Chr(13) & Chr(14) & Chr(15) & Chr(16) & Chr(17) & Chr(18) & Chr(19) & Chr(20) & Chr(21) & Chr(22) & Chr(23) & Chr(24) & Chr(25) & Chr(26) & Chr(27) & Chr(28) & Chr(29) & Chr(30) & Chr(31) & Chr(32) & ChrW(&HA0)
If StrTrim(StrPtr(Text), StrPtr(WHITE_SPACE)) Then
TrimWS = Left$(Text, lstrlen(StrPtr(Text)))
Else
TrimWS = Text
End If
End Function
This function above isn't working when I swapped to 64 bit. The "StrPtr" areas seem to error out because this doesn't exist in 64 bit. Also the lstrlen doesn't seem to work either. It gives a mismatch error.
Can anyone give some suggestions on how to convert this to 64 bit?
I tried swapping the original function to LongPtr, I'm not sure what this function does but it's taking all those charcodes and testing for it. If it exists its running the lstrlen function.
I kinda hit a wall on this one.
I setup the LongPtr in the wrong spot. It works fine now.
Private Declare PtrSafe Function lstrlen Lib "Kernel32" Alias "lstrlenW" ( _
ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function StrTrim Lib "shlwapi.dll" Alias "StrTrimW" ( _
ByVal pszSource As LongPtr, _
ByVal pszTrimChars As LongPtr) As Long
I want to password protect the zip folder not the files in zip folder using VBA.
for example: if there is folder test.zip and there is file test.xlsx in it. I want to have a password on folder test.zip. Can someone help? Will be highly appreciated. Thanks
This procedure accepts an argument named NewFolder, which represents the folder to which the user is trying to switch. If this folder’s name is Confidential, the procedure asks the user to enter the password. If the password doesn’t match, the Cancel argument is set to True, which means the folder isn’t displayed.
Hope this will help you:
Sub zip_activeworkbook()
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
If ActiveWorkbook Is Nothing Then Exit Sub
DefPath = ActiveWorkbook.Path
If Len(DefPath) = 0 Then
msgbox "Please Save activeworkbook before zipping" & Space(12), vbInformation, "zipping"
Exit Sub
End If
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xls and zip file name
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
newzip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNameXls
msgbox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping"
Else
msgbox "FileNameZip or/and FileNameXls exist", vbInformation, "zipping"
End If
End Sub
Private Sub newzip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
You may find my version easier to use and understand. Here is the macro code along with an example of using it. The password is optional.
Private Declare Function ShellExecute _
Lib "Shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Sub ZipFile(FileName As String, Optional ByVal Password As String)
Dim CmdLine As String
Dim Ext As Long
Dim FilePath As String
Dim RetVal As Long
Dim Path As Long
Dim ZipName As String
' If no path is specified use the current directory
Path = InStrRev(FileName, "\")
FilePath = IIf(Path = 0, CurDir & "\", "")
' Check if file exists
If Dir(FilePath & FileName) = "" Then
MsgBox "File Not Found" & vbCrLf & " " & FilePath & FileName
Exit Sub
End If
' Name for the zip archive
Ext = InStrRev(FileName, ".")
ZipName = FilePath & IIf(Ext = 0, FileName & ".zip", Left(FileName, Ext) & "zip")
' Command line string - file names must include quotes
If Password = "" Then
CmdLine = "-min -a -en " & Chr$(34) & ZipName & Chr$(34) & " " _
& Chr$(34) & FileName & Chr$(34)
Else
CmdLine = "-min -a -en -s" & Chr$(34) & Password & Chr$(34) _
& " " & Chr$(34) & ZipName & Chr$(34) & " " _
& Chr$(34) & FileName & Chr$(34)
End If
' Command line String to Unzip a file
'CmdLine = "-min -e " & Chr$(34) & ZipFileName & Chr$(34) & " " _
' & FolderPath
' Zip the file and save it in the archive
RetVal = ShellExecute(0&, "", "WinZip32.exe", CmdLine, FilePath, 1&)
' Check for Errors are from 0 to 32
If RetVal <= 32 Then
Select Case RetVal
Case 2 'SE_ERR_FNF
Msg = "File not found"
Case 3 'SE_ERR_PNF
Msg = "Path not found"
Case 5 'SE_ERR_ACCESSDENIED
Msg = "Access denied"
Case 8 'SE_ERR_OOM
Msg = "Out of memory"
Case 32 'SE_ERR_DLLNOTFOUND
Msg = "DLL not found"
Case 26 'SE_ERR_SHARE
Msg = "A sharing violation occurred"
Case 27 'SE_ERR_ASSOCINCOMPLETE
Msg = "Incomplete or invalid file association"
Case 28 'SE_ERR_DDETIMEOUT
Msg = "DDE Time out"
Case 29 'SE_ERR_DDEFAIL
Msg = "DDE transaction failed"
Case 30 'SE_ERR_DDEBUSY
Msg = "DDE busy"
Case 31 'SE_ERR_NOASSOC
Msg = "Default Email not configured"
Case 11 'ERROR_BAD_FORMAT
Msg = "Invalid EXE file or error in EXE image"
Case Else
Msg = "Unknown error"
End Select
Msg = "File Not Zipped - " & Msg & vbCrLf & "Error " & RetVal
MsgBox Msg, vbExclamation + vbOKOnly
End If
Example of using the macro:
Sub ZipTest()
ZipFile "C:\PF Credits.xls", Password:="123"
End Sub
I have the below macro that fills the data from excel to a PDF. I would like to enhance the code to save the PDF and also print it. The name for the file is located in cell A5. The current code saves the FDF to my directory. Below is the code used and is taken from the following link: http://blog.excelhero.com/2010/04/14/excel_acrobat_pdf_form_filler/:
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_NORMAL = 1
Public Const PDF_FILE = "f8655.pdf"
Public Sub MakeFDF()
Dim sFileHeader As String
Dim sFileFooter As String
Dim sFileFields As String
Dim sFileName As String
Dim sTmp As String
Dim lngFileNum As Long
Dim vClient As Variant
' Builds string for contents of FDF file and then writes file to workbook folder.
On Error GoTo ErrorHandler
sFileHeader = "%FDF-1.2" & vbCrLf & _
"%âãÏÓ" & vbCrLf & _
"1 0 obj<</FDF<</F(" & PDF_FILE & ")/Fields 2 0 R>>>>" & vbCrLf & _
"endobj" & vbCrLf & _
"2 0 obj[" & vbCrLf
sFileFooter = "]" & vbCrLf & _
"endobj" & vbCrLf & _
"trailer" & vbCrLf & _
"<</Root 1 0 R>>" & vbCrLf & _
"%%EO"
sFileFields = "<</T(f1_01(0))/V(---NAME---)>>" & vbCrLf & _
"<</T(f1_02(0))/V(---EIN_LEFT---)>>" & vbCrLf & _
"<</T(f1_03(0))/V(---EIN_RIGHT---)>>" & vbCrLf & _
"<</T(f1_06(0))/V(---OIN---)>>" & vbCrLf & _
"<</T(f1_04(0))/V(---TRADE_NAME---)>>" & vbCrLf & _
"<</T(c1_1(0))/V(---SEASONAL---)>>" & vbCrLf & _
"<</T(f1_05(0))/V(---STREET_ADDRESS---)>>" & vbCrLf & _
"<</T(f1_07(0))/V(---CITY_STATE_ZIP---)>>" & vbCrLf & _
"<</T(f1_08(0))/V(---CONTACT---)>>" & vbCrLf & _
"<</T(f1_09(0))/V(---PHONE_LEFT---)>>" & vbCrLf & _
"<</T(f1_10(0))/V(---PHONE_RIGHT---)>>" & vbCrLf & _
"<</T(f1_11(0))/V(---FAX_LEFT---)>>" & vbCrLf & _
"<</T(f1_12(0))/V(---FAX_RIGHT---)>>" & vbCrLf
vClient = Range(Selection.Row & ":" & Selection.Row)
sFileFields = Replace(sFileFields, "---NAME---", vClient(1, 2))
If Len(vClient(1, 3)) > 3 Then
sTmp = Replace(vClient(1, 3), "-", "")
sFileFields = Replace(sFileFields, "---EIN_LEFT---", Left$(sTmp, 2))
sFileFields = Replace(sFileFields, "---EIN_RIGHT---", Mid$(sTmp, 3))
Else
sFileFields = Replace(sFileFields, "---EIN_LEFT---", vbNullString)
sFileFields = Replace(sFileFields, "---EIN_RIGHT---", vbNullString)
End If
sFileFields = Replace(sFileFields, "---OIN---", vClient(1, 4))
sFileFields = Replace(sFileFields, "---TRADE_NAME---", vClient(1, 5))
sFileFields = Replace(sFileFields, "---SEASONAL---", vClient(1, 6))
sFileFields = Replace(sFileFields, "---STREET_ADDRESS---", vClient(1, 7))
sFileFields = Replace(sFileFields, "---CITY_STATE_ZIP---", vClient(1, 8))
sFileFields = Replace(sFileFields, "---CONTACT---", vClient(1, 9))
If Len(vClient(1, 10)) = 10 Then
sTmp = Replace(vClient(1, 10), "-", "")
sFileFields = Replace(sFileFields, "---PHONE_LEFT---", Left$(sTmp, 3))
sFileFields = Replace(sFileFields, "---PHONE_RIGHT---", Mid$(sTmp, 4, 3) & "-" & Mid$(sTmp, 7))
Else
sFileFields = Replace(sFileFields, "---PHONE_LEFT---", vbNullString)
sFileFields = Replace(sFileFields, "---PHONE_RIGHT---", vbNullString)
End If
If Len(vClient(1, 11)) = 10 Then
sTmp = Replace(vClient(1, 11), "-", "")
sFileFields = Replace(sFileFields, "---FAX_LEFT---", Left$(sTmp, 3))
sFileFields = Replace(sFileFields, "---FAX_RIGHT---", Mid$(sTmp, 4, 3) & "-" & Mid$(sTmp, 7))
Else
sFileFields = Replace(sFileFields, "---FAX_LEFT---", vbNullString)
sFileFields = Replace(sFileFields, "---FAX_RIGHT---", vbNullString)
End If
sTmp = sFileHeader & sFileFields & sFileFooter
' Write FDF file to disk
If Len(vClient(1, 1)) Then sFileName = vClient(1, 1) Else sFileName = "FDF_DEMO"
sFileName = ActiveWorkbook.Path & "\" & sFileName & ".fdf"
lngFileNum = FreeFile
Open sFileName For Output As lngFileNum
Print #lngFileNum, sTmp
Close #lngFileNum
DoEvents
' Open FDF file as PDF
ShellExecute vbNull, "open", sFileName, vbNull, vbNull, SW_NORMAL
Exit Sub
ErrorHandler:
MsgBox "MakeFDF Error: " + Str(Err.Number) + " " + Err.Description + " " + Err.Source
End Sub
Any help would be greatly appreciated!
Option Explicit
Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Public Sub PrintFile(ByVal strPathAndFilename As String)
Call apiShellExecute(Application.hwnd, "print", strPathAndFilename, vbNullString, vbNullString, 0)
End Sub
Sub Test()
PrintFile ("C:\Test.pdf")
End Sub
Add this code as it is and just make the call to PrintFile under your desired location and pass your file path in your case sFileName so final call would be :
PrintFile sFileName
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub SendEMail()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double
For r = 2 To 2000 'data in rows 2-4
' Get the email address
Email = Cells(r, 6)
' Message subject
Subj = "bug"
' Compose the message
Msg = ""
Msg = Msg & "Dear " & Cells(r, 6) & "," & vbCrLf & vbCrLf
Msg = Msg & "Please Validate thebug Waiting on You "
Msg = Msg & Cells(r, 1).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "S" & vbCrLf
Msg = Msg & "RTS"
' Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
' Create the URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Next r
End Sub
help me debug this, its going to infinity loop
kindly I have a two VBA codes one is to save the printed area as PDF with the same name as the workbook is and save file location is Desktop and it works fine
and I do have another code which start outlook new message and take some specific cell value as subject and another value as body.
The problem is I want the code of the new mail to attach that saved PDF file from code 1 and make the subject to be same as PDF file name.
The save pdf code is:
Sub Save_as_pdf()
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name
If FSO.FileExists(ThisWorkbook.FullName) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sNewFilePath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
End Sub
... and the second outlook new email code is :
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub SendEMail()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Email = " "
Subj = "P.O # " & "-" & Cells(9, 5) & "-" & Cells(15, 2) & "-" & Cells(15, 8) & Cells(15, 7)
Msg = " "
Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched P.O to be delivered to " & Cells(10, 12)
'Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
'Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
'Create the URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg
'Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
'Wait two seconds before sending keystrokes
'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"
End Sub
I hope I could clarify my problem fine.
Thanks in advance.
You can try this :
It changes the PDF export to a function to get the file path and use it as an argument in the other one.
URL method doesn't works with attachments, so below is some code for Outlook(edited to contain the whole code)
Preparing mail with Outlook (sorry for french comments):
Sub Send_To_Pdf()
Dim PdfPath As String
Dim BoDy As String
BoDy = Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched P.O to be delivered to " & Cells(10, 12)
PdfPath = Save_as_pdf
EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), "recepient1#domain.com;recepient2#domain.com", , , BoDy, 1, PdfPath
End Sub
Public Function Save_as_pdf() As String
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name
If FSO.FileExists(ThisWorkbook.FullName) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sNewFilePath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
Save_as_pdf = sNewFilePath
End Function
Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)
Dim MonOutlook As Object
Dim MonMessage As Object
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.createitem(0)
Dim PJ() As String
PJ() = Split(PjPaths, ";")
With MonMessage
.Subject = Subject '"Je suis content"
.To = Destina '"marcel#machin.com;julien#chose.com"
.cc = CCdest '"chef#machin.com;directeur#chose.com"
.bcc = CCIdest '"un.copain#supermail.com;une-amie#hotmail.com"
.BoDy = BoDyTxt
If PjPaths <> "" And NbPJ <> 0 Then
For i = 0 To NbPJ - 1
'MsgBox PJ(I)
.Attachments.Add PJ(i) '"C:\Mes Documents\Zoulie Image.gif"
Next i
End If
.display
'.send '.Attachments.Add ActiveWorkbook.FullName
End With '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb"
Set MonOutlook = Nothing
End Sub