My set-up is that I have a bunch of blank templates in a folder. Inside each blank template is a fund code (it is the only thing in the template)
The below macro I created (in an external workbook) goes through the folder with the templates, opens each template, and "fills it out" via a loop.
Basically my macro opens each template, assigns the fund code to a variable and then uses that variable in combination with some text strings to pull in other worksheets/PDF objects related to that specific fund code.
My issue is that in a more meaty version of the below code, I added maybe four or five more PDF objects to insert. It'll go through some of the templates and then randomly stop on a random fund code at a random pdf object insert line saying either "object cannot be found" or "object cannot be inserted"
If I press debug and then press F8 to run that line again, it is able to insert the object no problem. So perhaps my code is running too fast for adobe to handle? I am unsure. Perhaps my code isn't doing things as efficiently as possible. This would save sooo much time for my team, I just can't be having it work half the time.
(also the file names have definitely been correct, so that is not an issue)
Public Sub test()
Set currentbook = ActiveWorkbook
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wbk As Workbook
Dim filename1 As String
Dim Path As String
Dim a As Long
Path = "C:\Users\Bob\Desktop\Workbooks\"
filename1 = Dir(Path & "*.xlsm")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(filename1) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & filename1)
wbk.Activate
'Gets Fund Code
Sheets("Initialize").Select
Dim FdCode As String
FdCode = Worksheets("Initialize").Range("D8")
'--------------------------- PDF ADDS
'Add PDF TB----------------------------------------------------
Worksheets("F.a - Working TB").OLEObjects.Add filename:="C:\Users\Bob\Desktop\Raw Reports\R122 04.30.16 - 04.30.17\" & FdCode & " 04.30.16 TB.PDF", Link:=False, DisplayAsIcon:=False, Left:=40, Top:=40, Width:=150, Height:=10
On Error GoTo 0
'Add PDF Closed Options----------------------------------------------------'
Worksheets("T300.1 - Options (Closed)").OLEObjects.Add filename:="C:\Users\Bob\Raw Reports\Other Reports 04.30.16-04.30.17\Breakout\" & FdCode & " other 04.30.17_ CLOSED OPTIONS POSITION REPORT.PDF", Link:=False, DisplayAsIcon:=False, Left:=40, Top:=40, Width:=150, Height:=10
On Error GoTo 0
ActiveWorkbook.Save
wbk.Close False
filename1 = Dir
Loop
Application.ScreenUpdating = True
End Sub
Related
I need to loop over some word documents, and extract images from a word document and save them in a separate folder.
I've tried the method of saving them as an HTML document, but it is not a good fit for my requirement.
Now, I'm looping through the images using inlineshapes object and then copy-pasting them on a publisher document and then saving them as an image. However, I'm facing a Runtime Automation error when I'm running the script.
For using the Publisher runtime library I've tried both early and late binding but I'm facing the error on both of them.
Can anyone please let me know what is the problem? Also, if anyone can explain why I'm facing this error, that'd be great. As per my understanding, it is due to memory allocation, but I'm not sure.
Here is the code block that I've been working on (fp, dp are folder paths, while filename is the word document name. I'm calling this sub in another sub that is looping over all the files in a folder):
Sub test(ByVal fp As String, ByVal dp As String, ByVal filename As String)
Dim doc As Document
Dim pubdoc As New Publisher.Document
Dim shp As InlineShape
'Application.Screenupdating = False
'Dim pubdoc As Object
'Set pubdoc = CreateObject("Publisher.Document")
Set doc = Documents.Open(fp)
With doc
i = .InlineShapes.Count
Debug.Print i
End With
For j = 1 To i
Set shp = doc.InlineShapes(j)
shp.Select
Selection.CopyAsPicture
pubdoc.Pages(1).Shapes.Paste
pubdoc.Pages(1).Shapes(1).SaveAsPicture (dp & Application.PathSeparator & j & ".jpg")
pubdoc.Pages(1).Shapes(1).Delete
Next
doc.Close (wdDoNotSaveChanges)
pubdoc.Close
'Application.Screenupdating = True
End Sub
Apart from this, if anyone has any suggestions to make this faster, I'm all ears. Thanks in advance!
Just add .zip to the end of the file name, expand the file and look in the word/media folder. All the files will be there, no programming necessary.
Extracting the pictures from a Filtered HTML document that was created from your original source document would be faster. However, you said that was not a good fit for you needs so ... here is example code that will locate pictures in your source document and paste them into a second document.
The speed problem of this type of code is caused by the CopyPicture working from a Selection command, so I recommend using a range instead. Of course the For/Next loop that is required is slower no matter what.
Sub CopyPasteAsPicture()
Dim doc As Word.Document, iShp As Word.InlineShape, shp As Word.Shape
Dim i As Integer, nDoc As Word.Document, rng As Word.Range
Set doc = ActiveDocument
If doc.Shapes.Count > 0 Then
For i = 1 To doc.Shapes.Count
Set shp = doc.Shapes(i)
If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then
'if you want only pictures extracted then you have
'to specify the type
shp.ConvertToInlineShape
'if you want all extracted pictures to be in the sequence
'they appear in the document then you have to convert
'floating shapes to inline shapes
End If
Next
End If
If doc.Content.InlineShapes.Count > 0 Then
Set nDoc = Word.Documents.Add
Set rng = nDoc.Content
For i = 1 To doc.Content.InlineShapes.Count
doc.Content.InlineShapes(i).Range.CopyAsPicture
rng.Paste
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
rng.Paragraphs.Add
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
Next
End If
End Sub
If you want to place all shapes (floating or inline) into a folder as image files, then the best way is to save the source document as a filtered HTML document. Here is the command:
htmDoc.SaveAs2 FileName:=LGPWorking & strFileName, AddToRecentFiles:=False, FileFormat:=Word.WdSaveFormat.wdFormatFilteredHTML
In the above the active document is assigned to the variable htmDoc. I am giving this new document a specific name and location. The output from this is not only the HTML file but also a directory by the same name with an appended "_Files" label. In the "x_Files" directory are all the image files.
If you only want selective images pulled from your original source document, or if you want images pulled from multiple source documents ... then you need to use the above code that I shared for placing only the images you want from one or more source document into a new Word document and then save that new document as an Filtered HTML.
When your routine is done, you can Kill the HTML document and only leave the Files directory.
I had to change a few things around, but this will allow to save a single image on a word document and go through a couple of cycles before it turns into a jpg on the other side, without any white space
filename = ActiveDocument.FullName
saveLocaton = "z:\temp\"
FolderName = "test"
On Error Resume Next
Kill "z:\temp\test_files\*" 'Delete all files
RmDir "z:\temp\test_files" 'Delete folder
ActiveDocument.SaveAs2 filename:="z:\temp\test.html", FileFormat:=wdFormatHTML
ActiveDocument.Close
Kill saveLocaton & FolderName & ".html"
Kill saveLocaton & FolderName & "_files\*.xml"
Kill saveLocaton & FolderName & "_files\*.html"
Kill saveLocaton & FolderName & "_files\*.thmx"
Name saveLocaton & FolderName & "_files\image00" & 1 & ".png" As saveLocaton & FolderName & "_files\" & test2 & "_00" & x & ".jpg"
Word.Application.Visible = True
Word.Application.Activate
Hope someone help me with this problem.
I have a subroutine that will copy my data from this workbook to another existing workbook(Report Workbook).
When I try to run the code, during run-time once it opens the Report Workbook it suddenly stops and I've notice that it goes to design mode. Thus, hindering the execution of the routine.
But when I try to put a break point on the subroutine and continue it again. It executes without problem. This seems a bit odd.
I'm a bit out of the corner trying to figure this out.
So far this are the troubleshooting steps that I've tried.
Tried to run the Workbook in another machine.
I have tried deleting all the Workbook_Open on the Report Workbook.
Tried to delete all the Macro Codes on the Report Workbook.
Insert an error handler. Unfortunately, no error is presented.
Tried to delete the DoEvents code on the subroutine.
But still no luck. It stops the code from executing.
Private Sub TransferRawData()
Dim wsPTRawData As Worksheet, wbPTWorkBook As Workbook, wsOutputRaw As Worksheet
Dim filePath As String, FileName As String, ptTargetRow As Long
Application.EnableEvents = False
Application.StatusBar = "Exporting All Raw Data... Please wait a moment..."
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
filePath = ThisWorkbook.Path & "\"
FileName = filePath & pt_FileName
Set wbPTWorkBook = Workbooks.Open(FileName:=FileName, UpdateLinks:=0, IgnoreReadOnlyRecommended:=True)
DoEvents
Set wsPTRawData = wbPTWorkBook.Worksheets(pt_ProdRawSheet)
Set wsOutputRaw = ThisWorkbook.Sheets(merger_prodOutputSheet)
ptTargetRow = wsPTRawData.Range("A" & Rows.Count).End(xlUp).Row + 1
If lastRow(wsOutputRaw, "A") > 1 Then wsOutputRaw.Range("A2:F" & lastRow(wsOutputRaw, "A")).Copy wsPTRawData.Range("A" & ptTargetRow)
wbPTWorkBook.Close True
Set wsOutputRaw = Nothing
Set wsPTRawData = Nothing
Set wbPTWorkBook = Nothing
End Sub
BTW, I have 3 set of workbook that uses the above code. All of them will copy the data on the Report Workbook. But all of them are having trouble in executing the transfer routine.
For additional Information. Once I run the routine and it executes the Workbooks.Open Event. Here is the screenshot of the VBA Project Window and Excel Window.
Add an error handler in here and see if there are any errors that aren't being caught properly
Private Sub TransferRawData()
Dim wsPTRawData As Worksheet, wbPTWorkBook As Workbook, wsOutputRaw As Worksheet
Dim filePath As String, FileName As String, ptTargetRow As Long
Application.EnableEvents = False
Application.StatusBar = "Exporting All Raw Data... Please wait a moment..."
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
filePath = ThisWorkbook.Path & "\"
FileName = filePath & pt_FileName
On Error GoTo ErrHandler
Set wbPTWorkBook = Workbooks.Open(FileName:=FileName, UpdateLinks:=0, IgnoreReadOnlyRecommended:=True)
DoEvents
Set wsPTRawData = wbPTWorkBook.Worksheets(pt_ProdRawSheet)
Set wsOutputRaw = ThisWorkbook.Sheets(merger_prodOutputSheet)
ptTargetRow = wsPTRawData.Range("A" & Rows.Count).End(xlUp).Row + 1
If lastRow(wsOutputRaw, "A") > 1 Then wsOutputRaw.Range("A2:F" & lastRow(wsOutputRaw, "A")).Copy wsPTRawData.Range("A" & ptTargetRow)
wbPTWorkBook.Close True
Set wsOutputRaw = Nothing
Set wsPTRawData = Nothing
Set wbPTWorkBook = Nothing
ErrHandlerSave:
Debug.Print Chr(13) & "Error # " & Str(Err.Number) & " was generated on Saving" _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
End Sub
You'll see an error message come up in the Immediate window at the bottom of the VBA code. If you don't have it up or unsure how to show it LOOK HERE
Hi For Reference of others that will encounter this issue on the future.
The code itself doesn't have anything to do with the error.
After a lot of time investigating this error. I have found out that the culprit is the shortcut key that I have assigned on the Macro itself.
I have assigned a CTRL+SHIFT Key on the macro thus hindering the other macro of the other workbook that its opening.
Going forward, I made configuration on my Macro shortcut key and avoided the Shift key. As a result, the subroutine do what it needs to supposed to do.
I recently received help here for an Excel spreadsheet we have that allows users to create quotations for customers. The spreadsheet uses VBA to allow the user to press a button which generates a PDF out from certain sheets, and attaches them to a new Outlook email.
Unfortunately this isn't working on one of the user's computers. The problem seems to be with the generating of the PDF. Initially when pressing the button, nothing happened. I suspected it was to do with the Microsoft Add-in to Save as PDF, so I made sure it was installed, which it was. After 'commenting out' the error message coming from the code to get to the real error message from Visual Basic, I found it to be this:
run-time error '-2147467261 (80004003)': Document not saved.
When clicking 'Debug' it highlights:
FileName = Create_PDF_Sheet_Level_Names(NamedRange:="addtopdf1", _
FixedFilePathName:=ThisWorkbook.Path & "\" & "Quotation - " & Range("G18") & ".pdf", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
Which relates to:
Function Create_PDF_Sheet_Level_Names(NamedRange As String, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
'This function will create a PDF with every sheet with
'a sheet level name variable <NamedRange> in it
Dim FileFormatstr As String
Dim Fname As Variant
Dim Ash As Worksheet
Dim sh As Worksheet
Dim ShArr() As String
Dim s As Long
Dim SheetLevelName As Name
'Test If the Microsoft Add-in is installed
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
'We fill the Array with sheets with the sheet level name variable
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = -1 Then
Set SheetLevelName = Nothing
On Error Resume Next
Set SheetLevelName = sh.Names(NamedRange)
On Error GoTo 0
If Not SheetLevelName Is Nothing Then
s = s + 1
ReDim Preserve ShArr(1 To s)
ShArr(s) = sh.Name
End If
End If
Next sh
'We exit the function If there are no sheets with
'a sheet level name variable named <NamedRange>
If s = 0 Then Exit Function
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
'Remember the ActiveSheet
Set Ash = ActiveSheet
'Select the sheets with the sheet level name in it
Sheets(ShArr).Select
'Now the file name is correct we Publish to PDF
On Error Resume Next
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then
Create_PDF_Sheet_Level_Names = Fname
End If
Ash.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Function
I'm really scratching my head here! Checked all settings side-by-side with my machine on Excel and Outlook, including Trust Centre settings. Also checked add-ins.
Please check if there is enough disk space where the user wants to save the PDF file to!
I would recommend to check the length of the PDF fullname (path, filename and file extension; in your example it is the variable "Fname") as well before calling "ActiveSheet.ExportAsFixedFormat(...)", because filenames (or rather fullnames) under Microsoft Windows regularly cannot exceed more than 255 characters (see: Naming Files, Paths, and Namespaces).
First time posting so please be kind.
From a template file, I am running a macro to create a new folder with a copy of the template file in it. I then rename it and update it. At one point, I need to manually download a file from a website and open it and then start another macro to finish the update.
I initially tried to do that from one unique macro but I got issues as the macro would keep running before the excel file had time to open.
I have now split my macro in 2. At the end of the 1st macro, I call a userform with instructions and a continue button. The idea is that I would download the file while the userform is opened and click on "continue" when the file is opened.
For some reason, the file does not open at all. It seems like either the userform or the macro stops the file from opening. However, If I run it using the debug function, It works fine...
Public strSN As String, strPart As String, strPath As String
Sub create_new()
' Create Folder if it doesn't exist
'Dim strSN As String, strPart As String, strPath As String
'strSN = SerialNumber.Value
'strPart = PartNumber.Value
'strPath = "M:\Quality\QUALITY ASSURANCE\DOC\Rental Folder\Scanned MRB's\"
' close userform
welcomeform.Hide
'set Microsoft scription runtime reference to allow creation of folder macro
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D- 00A0C9054228}", 1, 0
On Error GoTo 0
If Not FolderExists(strSN) Then
'Serial Number folder doesn't exist, so create full path
FolderCreate strPath & strSN
End If
' Create new file in new folder
On Error Resume Next
ActiveWorkbook.SaveCopyAs Filename:=strPath & strSN & "\" & strPart & " " & strSN & " " & "SNR.xlsm"
If Err.Number <> 0 Then
MsgBox "Copy error: " & strPath & "TEMPLATE SNR.xlsm"
End If
On Error GoTo 0
' open new file without showing it or opening macros
Application.EnableEvents = False 'disable Events
Workbooks.Open Filename:=strPath & strSN & "\" & strPart & " " & strSN & " " & "SNR.xlsm"
Application.EnableEvents = True 'enable Events
' Modify serial number and part number in traceability summary form
Sheets("Traceability Summary Form").Activate
Sheets("Traceability Summary Form").Unprotect
Range("A7").Value = strSN
Range("C7").Value = strPart
' update file with ITP
Call Download_itp
End Sub
Sub Download_itp()
downloaditp.Show
End Sub
In the download_itp userform:
Sub continue_Click()
Call update_traceable_items
End Sub
Then the 2nd macro starts with code:
Sub update_traceable_items()
'
' Macro to update the SNR tab with the traceable items from the ITP
'
downloaditp.Hide
' copy ITP in file
Application.ActiveProtectedViewWindow.Edit
ActiveSheet.Name = "ITP"
ActiveSheet.Copy after:=Workbooks(strPart & " " & strSN & " " & "SNR.xlsm").Sheets("SNR template")
Any help would be appreciated!
Thanks
The UserForm is being displayed modally, which probably prevents you from "opening" the recently downloaded file. When UserForm is displayed modally, the user is prevented from "interacting" with any part of Excel Application that is not the UserForm itself -- so you can't select cells or worksheets, you can't open files or close files, etc.
This is the default behavior for UserForms, but fortunately there is an optional parameter for the .Show method which allows you to display the form "modelessly":
downloaditp.Show vbModeless
This allows you to interact with the Excel Application while the form is open.
Note: If the file is on a shared network location, you can probably handle this better by using a FileDialog object to allow you to "browse" to the location of the file, and open it, all within the scope of your main procedure, like:
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 1 Then
MsgBox "No file selected!", vbCritical
Exit Sub
Else
Dim NewWorkbook as Workbook
Set NewWorkbook = Workbooks.Open(.SelectedItems(0))
End If
End With
I am a total dummy as for vb and excel, have tried to combine 2 macros that I have found around here, into 1, but obviously did something terribly wrong and now i'm stuck.. First I just used this macro (saved it in as personal.xlsb so as to be able to use it in any workbook)
Sub CSVFile()
Dim SrcRg As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant
FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
ListSep = ";"
If Selection.Cells.Count > 1 Then
Set SrcRg = Selection
Else
Set SrcRg = ActiveSheet.UsedRange
End If
Open FName For Output As #1
For Each CurrRow In SrcRg.Rows
CurrTextStr = ìî
For Each CurrCell In CurrRow.Cells
CurrTextStr = CurrTextStr & """" & GetUTF8String(CurrCell.Value) & """" & ListSep
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
Print #1, CurrTextStr
Next
Close #1
End Sub
That plus the GetUTF8String function code. Now that was working fine. Then I have thought well why not just experiment with my limited (that is a serious understatement) vb understanding, added the following code and changed the CSVFile sub into a function, which I then called from the sub below, with the output file name as a parameter (to be used instead FName = Application.GetSaveAsFilename). I thought yeah, this code saves all sheets automatically, now let's just make sure that the encoding and delimiter/enclosure setting function runs before each sheet is saved. It doesn't seem right but I thought hey why not try..
Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' Save the file in current director
OutputPath = ThisWorkbook.Path
If OutputPath <> "" Then
Application.Calculation = xlCalculationManual
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
CSVFile(OutputFile)
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
Application.Calculation = xlCalculationAutomatic
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
Saved that and with that I have managed to achieve something very different. On opening any workbooks, that macro runs and opens up my sheets from that particular workbook as csv files (without saving them). Now I am like Alice in Wonderland. How come it is running on file open? That is not desirable, so I went back to the macro code and changed it back to just the csvfile sub. Well that didn't help, no idea what I did there, was definitely editing the same macro... So I deleted the macro, the modul, I cannot imagine where the thing now is but it's still running + I get this warning that macros were deactivated. Can't get rid of it! Now lads, I'm sorry for the total lack of professionality from my side, this was just supposed to be a small favor for a client, without wasting loads of time learning vb, coz my boss doesn't like that... I am of course interested in how to achieve the goal of saving the sheets automatically after setting the deimiter and enclosure in them. And at this moment I am very interested in how to get rid of that macro and where it is hiding.. What have I done?! Thank you for your patience!
I think the problem lies with the line
OutputPath = ThisWorkbook.Path
Because you are running this from your personal.xlsb which is stored in your XLSTART folder it has created the CSV files in the same location. When Excel starts it will try and load any files that it finds in that location.
Just locate your XLSTART folder and delete any CSV files you find there.
Try using
OutputPath = ActiveWorkbook.Path
XLSTART folder location, dependent on your system, is probably something like:
C:\Users\YOURNAME\AppData\Roaming\Microsoft\Excel\XLSTART