I need a macro which will allow me to save the current Visio drawing as an SVG file.
The quickest way I can do at the moment is to use the F12 keyboard shortcut which gives me the Save As dialog, but still each time I have to select the proper output file, i.e. PNG, and then write the name of the file.
Is it possible to automate this? I was looking for something like Macro recording in Visio, but couldn't find that.
For file formats of .bmp, .dib, .dwg, .dxf, .emf, .emz, .gif, .htm, .jpg, .png, .svg, .svgz, .tif, or .wmf
The extension will define the format.
Dim vsoPage As Visio.Page
Set vsoPage = ActivePage
vsoPage.Export ("C:\\myExportedPage.svg")
Here is an example of looping all pages exporting each one.
Dim PgObj As Visio.Page
Dim Pgs As Visio.Pages
Dim filename As String
Dim PgName As String
Dim iPgs As Integer
'Set a handle to the pages collection
Set Pgs = Application.ActiveDocument.Pages
'Loop Pages collections
For iPgs = 1 To Pgs.Count
'Set a handle to a page
Set PgObj = Pgs(iPgs)
'Get Page name
PgName = PgObj.Name
'Create path to save svg file
filename = Application.ActiveDocument.Path & PgName & ".svg"
'Export the page as svg file
PgObj.Export filename
Next iPgs
'Clean Up
Set PgObj = Nothing
Set Pgs = Nothing
Related
I am trying to read one pdf and a VBA userform and then fill out another pdf.
I wrote code to read all text in a pdf and then find certain sub strings based on tokens that I can find in the string. It is intended to populate the fields in the destination pdf based on the substrings and check the appropriate text boxes based on the user form. I can get the code to fill the substrings and then save the document, but it won't check the boxes.
Before the code used a AVDoc, but I switched to a JSO because I don't want the pdf to pop up, and the jso avoids that problem.
I tried pdfBool.value = cBool(vbaBool), pdfBool.value = 1, pdfBool.value = "1", jso.setValue("checked"), jso.setValue("yes"), etc.
This code will run without crashing. I reduced the number of variables to one string and one bool for the sake of the example.
Sub main()
‘findString grabs all text from a pdf file. This code works.
Dim mystr As String
If findString(mystr) = False Then
Application.StatusBar = "Cannot find Source PDF"
Exit Sub
End If
Dim mypath As String
mypath = ActiveWorkbook.Path & "\destination.pdf"
Dim aApp As acrobat.AcroApp
Dim pdfDoc As acrobat.CAcroPDDoc
Dim jso As Object
Set aApp = CreateObject("AcroExch.App")
Set pdfDoc = CreateObject("AcroExch.PDDoc")
If pdfDoc.Open(mypath) = True Then
Set jso = pdfDoc.GetJSObject
Dim vbaText As String
Dim vbaBool As String
vbaText = returnString("Token1")
vbaBool = userForm.checkBox1.value
Dim pdfText As Object
Dim pdfBool As Object
Set pdfText = jso.getField("TextField1")
Set pdfBool = jso.getField("CheckBox1")
pdfText.Value = vbaText
pdfBool.Value = vbaBool
'save pdffile
Dim fileSavePath As String
fileSavePath = ActiveWorkbook.Path & "\My Save File.pdf"
pdfDoc.Save PDSaveFull, fileSavePath
'clean up memory
Set pdfDoc = Nothing
Set pdfText = Nothing
Set pdfBool = Nothing
Set jso = Nothing
End If
aApp.Exit
Set aApp = Nothing
Unload userForm1
End Sub
Ok, so after some searching, I have found a solution. Basically, forms created using Living Cycle don't work well with checkboxes. I asked somebody in my organization and they confirmed that Living Cycle was used on forms for a while until we got rid of it. Honestly, I don't know what Living Cycle is, but the solution seemed to work and so I think whatever the issue was related to something called "Living Cycle".
The solution? Redo the pdf form: I exported the pdf to an Encapsulated PostScript file. This stripped away all the fields. After that, I used the prepare form tool which automatically found all the relevant fields. Fortunately, with my pdf, it found all of the fields perfectly, though there was one or two extra ones that I had to delete. The field names and the code need to match so adjustments need to either be made to the PDF or to the code, but once I made that adjustment, everything was perfect.
Try jso.getfield(pdfFieldName).Value = "Yes" or "No". The value is case sensitive so you have to use Yes or No.
I am trying to insert text and pictures from a specific folder to a hidden Excel file, in specific cells, but for some reason I do not succeed in adding the pictures to the file.
What I can is open a hidden Excel file and add a bunch of data to the Excel. I can also add pictures tot the Excel from which the VBA script is running.
However combining both is something where I fail.
I use the following code to open an Excel file and put data in there:
Dim ExcelFileName As String
ExcelFileName = "C:\PictureTest.xlsx"
Dim Workbook As New Excel.Application
Dim DataWorkbook As New Excel.Workbook
Set DataWorkbook = Workbook.Workbooks.Open(ExcelFileName)
Workbook.Sheets("Sheet1").Cells(1, 1) = "Data to CELL"
DataWorkbook.Save
DataWorkbook.Close
Set Workbook = Nothing
Set DataWorkbook = Nothing
This one works perfectly, I can put data in any sheet anywhere I want.
However I also need to put pictures on certain sheets/cells.
I use the following code to add a picture to the active Excel file from which I am running the VBA script:
Dim PicturePath As String
PicturePath = "C:\Picture.tif"
Dim strPath As String
Dim Picture As Object
Set Picture = ActiveSheet.Pictures.Insert(PicturePath)
Picture.ShapeRange.LockAspectRatio = msoCTrue
Picture.Placement = xlMoveAndSize
Picture.ShapeRange.Width = 0.3 * Picture.Width
Is there anyone who can help me in getting both combined?
I have a .CATdrawing template that I use to create drawings for all my parts.
My current macro opens the template as desired.
What I would like to do is to change the working name of the document so that when the user clicks "save" the correct name is already in the dialog box and he only needs to browse to the correct location.
To clarify I'll add an image: https://i.imgur.com/eckBwRQ.png
In this image the text "Drawing2" needs to change to whatever I want it to be.
I do not want to save the .CATdrawing at this moment, the user must be allowed to continue work and save the document when it suits him.
I've been doing some searches on google and in the V5Automation.chm but I can't seem to find the code that does this.
My best guess was to try the following code:
'remember currently opened part.
Dim partDoc As PartDocument
Set partDoc = CATIA.ActiveDocument
Dim documents1 As Documents
Set documents1 = CATIA.Documents
'Open drawing
Dim mydrawingdoc As DrawingDocument
Set mydrawingdoc = documents1.Open("X:\Path\Template.CATDrawing")
'rename drawing
Set CATIA.ActiveDocument.Name = partDoc.Part.Parameters.Item("CUSTOM_NAME").ValueAsString
However I get an error saying
Invalid use of property
Any help would be greatly appreciated.
EDIT:
I've tried a few more things to do this but as of yet I've seen no success:
Left(mydrawingdoc.FullName, 10) = partDoc.Part.UserRefProperties.Item("CUSTOM_NAME").ValueAsString
this won't work either
EDIT2:
Ok so I found something that will give a completely different error:
mydrawingdoc.FullName = partDoc.Part.UserRefProperties.Item("CUSTOM_NAME").ValueAsString
Can't assign to read-only property
Does this mean it's impossible to do what I want?
Could a possible solution be to use NewFrom instead of Open like this:
Set mydrawingdoc = documents1.NewFrom("path\Template.CATDrawing")
And then immediately use the desired name while creating this drawingdocument?
It is not possible to change the name of a top-level document that has not been saved yet.
The best and only workaround, as far as I could find, is saving the document with the correct name in a temporary folder.
Example:
'remember currently opened part.
Dim partDoc As PartDocument
Set partDoc = CATIA.ActiveDocument
Dim documents1 As Documents
Set documents1 = CATIA.Documents
'Open drawing
Dim mydrawingdoc As DrawingDocument
Set mydrawingdoc = documents1.NewFrom("path\Template.CATDrawing")
'Save drawing with custom name extracted from 3D part
CATIA.ActiveDocument.SaveAs ("C:\CATIA_temp\" & partDoc.Product.UserRefProperties.Item("CUSTOM_NAME").ValueAsString & ".CATDrawing")
I'm getting this error, "Microsoft Excel is waiting for another application to complete an OLE action" when trying to automate a PDF string search and record findings in excel. For certain PDFs this error is not popping. I assume this is due to the less optimized PDFs taking a longer time to search string while indexing page by page.
To be more precise, I have a workbook containing two sheets. One contains a list of PDF file names and the other has a list of words that I want to search. From the file list the macro would open each PDF file and take each word from the list of words and perform a string search. If found it would record each finding in a new sheet in the same workbook with the file name and the found string.
Below is the code I'm struggling with. Any help is welcome.
Public Sub SearchWords()
'variables
Dim ps As Range
Dim fs As Range
Dim PList As Range
Dim FList As Range
Dim PLRow As Long
Dim FLRow As Long
Dim Tracker As Worksheet
Dim gapp As Object
Dim gAvDoc As Object
Dim gPDFPath As String
Dim sText As String 'String to search for
FLRow = ActiveWorkbook.Sheets("List Files").Range("B1").End(xlDown).Row
PLRow = ActiveWorkbook.Sheets("Prohibited Words").Range("A1").End(xlDown).Row
Set PList = ActiveWorkbook.Sheets("Prohibited Words").Range("A2:A" & PLRow)
Set FList = ActiveWorkbook.Sheets("List Files").Range("B2:B" & FLRow)
Set Tracker = ActiveWorkbook.Sheets("Tracker")
'For each PDF file list in Excel Range
For Each fs In FList
'Initialize Acrobat by creating App object
Set gapp = CreateObject("AcroExch.App")
'Set AVDoc object
Set gAvDoc = CreateObject("AcroExch.AVDoc")
'Set PDF file path to open in PDF
gPDFPath = fs.Cells.Value
' open the PDF
If gAvDoc.Open(gPDFPath, "") = True Then
'Bring the PDF to front
gAvDoc.BringToFront
'For each word list in the range
For Each ps In PList
'Assign String to search
sText = ps.Cells.Value
'This is where the error is appearing
If gAvDoc.FindText(sText, False, True, False) = True Then
'Record findings
Tracker.Range("A1").End(xlDown).Offset(1, 0) = fs.Cells.Offset(0, -1).Value
Tracker.Range("B1").End(xlDown).Offset(1, 0) = ps.Cells.Value
End If
Next
End If
'Message to display once the search is over for a particular PDF
MsgBox (fs.Cells.Offset(0, -1).Value & " assignment complete")
Next
gAvDoc.Close True
gapp.Exit
set gAVDoc = Nothing
set gapp = Nothing
End Sub
I have now found the answer to this problem.
I'm using Acrobat Pro and whenever I open a PDF file, it opens with limited features due to Protected View settings. If I disable this function or if I click Enable All Features and save changes to the PDF files, VBA macro runs smooth.
It's funny, I'm posting an answer to my own problem.
I have a folder contain texts files . The text is presented as below :
NAME Number Mail Date
xx 1 zz //
and I want to write a vba code that read all the text files and search for an information "NAME" to replace it with "name"and then save the modifications .
I did the code below , but I have an error 70 permission denied in Set f = FSO.OpenTextFile(Fichier, forWriting, True) ,
could you help me ?
Sub Sample()
dim fso=createobject("scripting.filesystemObject")
dim f
dim path as string
dim file_txt as string
path= "C:\Users\Folder\Fileshere\"
file_txt= Dir(path & "*.*")
Do While Len(file_txt) > 0
'Set objfile = FSO.CreateTextFile(path & file_txt)
Set f = FSO.OpenTextFile(file_txt, ForReading)
While Not f.AtEndOfStream
Namechange = f.ReadAll
Wend
Namechange = Replace(Namechange , "NAME", "name")
Set f = FSO.OpenTextFile(file_txt, forWriting, True)
f.Write Namechange
file_txt=dir()
loop
end sub
I'd rewrite using a bit more of the FileSystemObject functionality rather than using Dir() personally, but that's open to your own choice. The key issue I think you are having is that you have opened the file for reading and then immediately tried to open it for writing while the TextStream object is still in memory, and locking the file. This is why you are getting "Permission denied". To quote from a TechNet Article:
Opening Text Files
Working with text files is a three-step process.
Before you can do anything else, you must open the text file. This can
be done either by opening an existing file or by creating a new text
file. (When you create a new file, that file is automatically opened
and ready for use.) Either approach returns a reference to the
TextStream object. After you have a reference to the TextStream
object, you can either read from or write to the file. However, you
cannot simultaneously read from and write to the same file. In other
words, you cannot open a file, read the contents, and then write
additional data to the file, all in the same operation. Instead, you
must read the contents, close the file, and then reopen and write the
additional data. When you open an existing text file, the file can be
opened either for reading or for writing. When you create a new text
file, the file is open only for writing, if for no other reason than
that there is no content to read. Finally, you should always close a
text file. Although this is not required (the file will generally be
closed as soon as the script terminates), it is good programming
practice.
My code should work for your requirements. I've removed the While loop from the middle as if you are using ReadAll then you don't need to loop over the text.
Sub MySub()
Dim fso
Set fso = CreateObject("scripting.filesystemObject")
Dim file, folder
Dim path As String
Dim file_txt As String
path = "C:\users\folders\fileshere\"
Set folder = fso.GetFolder(path)
For Each file In folder.Files
Set file = fso.OpenTextFile(file.Path, 1)
Namechange = file.ReadAll
file.Close
Namechange = Replace(Namechange, "NAME", "name")
Set file = fso.OpenTextFile(file.Path, 2, True)
file.Write Namechange
file.Close
Next
End Sub
If you have any difficulties or would like further explanation of the above, let me know.
Some minor changes and it worked for me. Please change the path as per your own requirement in following code:
Sub change_txt()
Dim fso As Object
Set fso = CreateObject("scripting.filesystemObject")
Dim f
Dim path As String
Dim file_txt As String
path = "D:\Folder\Fileshare\"
file_txt = Dir(path & "*.*")
Do While Len(file_txt) > 0
'Set objfile = FSO.CreateTextFile(path & file_txt)
Set f = fso.opentextfile(path & file_txt, 1)
While Not f.AtEndOfStream
Namechange = f.ReadAll
Wend
Namechange = Replace(Namechange, "NAME", "name")
Set f = fso.opentextfile(path & file_txt, 2)
f.Write Namechange
file_txt = Dir()
Loop
End Sub