My code below scans the provided doc file (sp parameter) and copy over the tables to a sheet named "xxxx" (given in global variable 'shtTableName'.
This code is working perfectly fine when computer is NOT locked. But this code fails to run when screen/computer is locked.
I traced that the issue.. it is with line
sht.Paste Range("A1")
i tried
Acitvesheet.Paste
but it throws same error.
I tried every possible thing in Excel vba but none worked,....
on top of this, when it throws error, it is not captured in ErrWord section, it immediately throws the error to the parent error handler of calling procedure....
I cant understand why screen/computer locking can create such an issue.
Any help would be greatly appreciated.
I am using Windows 10 Version 1808 Build 10730.20348
Thanks
Gaurav
Sub read_word_document(filename As String)
Dim DOC_PATH As String
DOC_PATH = filename
Dim sht As Worksheet
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
Dim i As Long, r As Long, c As Long
Dim rng As Range, t As Word.Table
Dim oData As New DataObject 'object to use the clipboard
Dim bWordDocObjectCreated As Boolean
On Error GoTo ErrWord
bWordDocObjectCreated = False
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Open(DOC_PATH, ReadOnly:=True)
bWordDocObjectCreated = True 'indicates that object WordDoc has been created and file has been opened
Set sht = Sheets(shtTableName)
Set rng = sht.Range("A1")
For Each t In WordDoc.Tables
sht.Cells.Delete Shift:=-4162
sht.Activate
sht.Range("A1").Select
t.Range.Copy
sht.Paste Range("A1")
'ActiveSheet.Paste
Exit For 'get only first table
Next t
Application.CutCopyMode = False
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard 'take it to the clipboard to empty it
Application.DisplayAlerts = False
WordDoc.Close False
WordApp.Quit
Exit Sub
ErrWord:
If Not UCase(Err.Description) Like "*CORRUPTED*" And bWordDocObjectCreated = True Then
Data.SetText Text:=Empty 'Clear
oData.PutInClipboard 'take in the clipboard to empty it
Application.CutCopyMode = False
Application.DisplayAlerts = False
WordDoc.Close False
End If
WordApp.Quit
End Sub
I had a similar problem but in excel. The solution that worked for me was adding
Application.ScreenUpdating = False at the beginning of the macro. This may or may not work in your case.
Generally speaking, macros that simulate a user's actions e.g copy/pasting, sending keystrokes, cannot be run when the screen is locked - in my experience.
You may need another application to ensure the screen is unlocked before running the macro, or keep the screen unlocked. I have used Caffeine for this purpose successfully.
Related
I need to automate moving stuff from excel into PowerPoint. I build put together a macro, which works fine and it is basically running in PowerPoint, accessing Excel, taking some range of nicely formatted tables, and pasting as enhanced metafile:
Function CopyFromExcelToPPT(excelFilePath As String, sheetName As String, rngCopy As String, dstSlide As Long, Optional shapeTop As Long, Optional shapeLeft As Long, Optional shapeHeight As Long, Optional shapeWidth As Long)
On Error GoTo ErrorHandl 'Handle Errors
'Set Variables and Open Excel
Dim eApp As Excel.Application, wb As Excel.Workbook, ppt As PowerPoint.Presentation
Set eApp = New Excel.Application
eApp.Visible = False
Set wb = eApp.Workbooks.Open(excelFilePath)
Set ppt = ActivePresentation
'Copy cells in Excel
wb.Sheets(sheetName).Range(rngCopy).Copy
'Paste into first slide in active PowerPoint presentation
ppt.Slides(dstSlide).Shapes.PasteSpecial ppPasteEnhancedMetafile
'Close and clean-up Excel
eApp.CutCopyMode = False
wb.Close SaveChanges:=False
eApp.Quit
Set wb = Nothing: Set eApp = Nothing
'Move the new shape if left/top provided
If Not (IsMissing(shapeTop)) Then
With ppt.Slides(dstSlide).Shapes(ppt.Slides(dstSlide).Shapes.Count)
.Left = shapeLeft
.Top = shapeTop
End With
End If
'Resize the shape if height/width provided
If Not (IsMissing(shapeHeight)) Then
With ppt.Slides(dstSlide).Shapes(ppt.Slides(dstSlide).Shapes.Count)
.Height = shapeHeight
.Width = shapeWidth
End With
End If
'Put them to the back
With ppt.Slides(dstSlide).Shapes(ppt.Slides(dstSlide).Shapes.Count)
While .ZOrderPosition > 2
.ZOrder msoSendBackward
Wend
End With
CopyFromExcelToPPT = True
Exit Function
ErrorHandl:
'Make sure to close the workbook and Excel and return False
On Error Resume Next
If Not (eApp Is Nothing) Then
wb.Close SaveChanges:=False
eApp.CutCopyMode = False
eApp.Quit
End If
CopyFromExcelToPPT = False
End Function
The problem is, that I need to run this like 80x, and after each 5 loads I need to run a macro in that source excel, which will update data. Therefor I tried to either keep excel open during this macro, and manually lunch that macro, or ideally incorporate all of this into this PowerPoint macro.
I tried different approaches, however, I am not able to make it work, I am getting always errors.
Firstly I tried to to create another function handling running macro, and eventually chain it together with main function in main sub:
Function CallTopsheetMacro(excelFilePath As String, sheetName As String)
On Error GoTo ErrorHandl 'Handle Errors
'Set Variables and Open Excel
Dim eApp As Excel.Application, wb As Excel.Workbook
Set eApp = New Excel.Application
eApp.Visible = True
Set wb = eApp.Workbooks.Open(excelFilePath)
wb.Run "'...\excel.xlsb'!macro_01"
wb.Wait (Now + TimeValue("0:00:10"))
'Close and saves Excel
wb.Close SaveChanges:=True
wb.Wait (Now + TimeValue("0:00:10"))
eApp.Quit
Set wb = Nothing: Set eApp = Nothing
MsgBox ("Done!")
CallTopsheetMacro = True
Exit Function
ErrorHandl:
'Make sure to close the workbook and Excel and return False
On Error Resume Next
If Not (eApp Is Nothing) Then
wb.Close SaveChanges:=False
eApp.CutCopyMode = False
eApp.Quit
End If
CallTopsheetMacro = False
End Function
But this functions did basically nothing, only opens and closes excel, waiting is not even reflecting. Then I tried with both sessions (main PowerPoint taking the pictures, and excel which is providing pictures and running macros) running, as I would avoid manually triggering macros and wasting time with open/close excels which is pretty bulky:
Function CallTopsheetMacroActive()
On Error GoTo ErrorHandl 'Handle Errors
'Set Variables and Open Excel
Dim eApp As Excel.Application
Set eApp = GetObject("..\excel.xlsb", "Excel.Application")
eApp.Visible = True
'Run macro
eApp.Run "'...\excel.xlsb'!macro_01"
MsgBox ("Done!")
Exit Function
ErrorHandl:
'Make sure to close the workbook and Excel and return False
On Error Resume Next
If Not (eApp Is Nothing) Then
wb.Close SaveChanges:=False
eApp.CutCopyMode = False
eApp.Quit
End If
End Function
This one is doing nothing. Then I tried to examine the syntax for GetObject, even with small testing scripts, but it is not working. I have even added references for scrrun.dll, as I have 64bit and it was suggested in couple of similar topics, but of no help. For a simple code like this:
Sub GetObject_Testing()
Dim MyExcel As Excel.Workbook
Dim MySheet As Worksheet
Dim MyFilePath As String
'Set MyExcel = GetObject("Excel.Application")
MyFilePath = "...\excel.xlsb"
Set MyExcel = GetObject(MyFilePath, "Excel.Application")
For Each MySheet In MyExcel.Sheets
Debug.Print MySheet.Name
Next MySheet
End Sub
I am getting run.time error 432 (file name or class name not found during automation operation).
I have no idea what I may be doing wrong, and just to make sure I am providing whole code, just in case I have some error somewhere.
Would appreciate any suggestions which will help to solve this.
PS: Doing this from PowerPoint, because when I tried to the same from Excel, I was getting error that there is not enough memory to start PowerPoint.
Thanks!
OS: Windows 10 Pro Version 20H2 (OS Build 19042.1052)
Application: Microsoft 365 Excel Version 2106 (Build 14131.20278)
VBA: Microsoft Visual Basic for Applications 7.1 Version 1110
The module that contains the code resides in a Macro-enabled workbook, which opens other workbooks in a folder and modify each if it passes certain criteria. The workbook itself that contains the code is not being altered, it just holds the code.
I'm wondering if I need to turn Application.ScreenUpdating off and on for every subsequent workbook that will be opened within a subroutine, such as in this one:
Option Explicit
Sub Test_Code()
'Variable declaration
Dim fsoLib As Scripting.FileSystemObject
Dim strSrcPath As String
Dim fsoFolder As Scripting.Folder
Dim fsoFile As Scripting.File
Dim fsoFiles As Scripting.Files
Dim wb As Excel.Workbook
Dim wbs As Excel.Workbooks
'Assign values to variables
Set fsoLib = New Scripting.FileSystemObject
strSrcPath = "/SourcePath"
Set fsoFolder = fsoLib.GetFolder(strSrcPath)
Set fsoFiles = fsoFolder.Files
Set wbs = Excel.Workbooks
'Modify workbooks
For Each fsoFile In fsoFiles
Set wb = wbs.Open(fsoFile)
Application.ScreenUpdating = False 'TURNS OFF SCREEN UPDATING
'Code to modify workbooks here..
Application.ScreenUpdating = True 'TURNS SCREEN UPDATING BACK ON
wb.Close(True)
Next
'Housekeeping
Set fsoLib = Nothing
strSrcPath = vbEmpty
Set fsoFolder = Nothing
Set fsoFile = Nothing
Set fsoFiles = Nothing
Set wb = Nothing
Set wbs = Nothing
'Success indicator
Debug.Print "You have reached the end of the line.."
End Sub
..or do I just place it on top and bottom, respectively? Like in this one:
Option Explicit
Sub Test_Code()
Application.ScreenUpdating = False
'Rest of the code here..
Application.ScreenUpdating = True
End Sub
I couldn't find any resources about it on the internet that's current. I found one old discussion here but the OP had mixed results depending on whether it is run from the VBA IDE or otherwise.
I'd appreciate any help from you guys. Thank you all very much.
I am trying to export each worksheet content (textboxes and shapes, no cellcontent) into a word document. The result is not what I expected. If there are 2 worksheets each one with a text box, 1 text box will be copied twice and the other one won't be copied at all!
Private Sub Export()
Dim WordApp As Word.Application
Set WordApp = CreateObject("Word.Application")
On Error Resume Next
WordApp.Documents.Add
WordApp.Visible = True
For Each ws In ActiveWorkbook.Worksheets
ws.Shapes.SelectAll
Selection.Copy
WordApp.Selection.PasteSpecial DataType:=wdPasteShape
Application.CutCopyMode = False
Next ws
End Sub
What I am missing:
Insert a page break after each ws is exported
Understanding why a textbox from a worksheet is copied twice and another textbox from a different worksheet is not copied at all
1. Adding page breaks
If you want to insert a page break at the end of your Word file, you can (1) select the end of the Word content section and (2) insert the page break like this:
WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.InsertBreak
Your code would then look like this:
Private Sub Export_v1()
Dim WordApp As Word.Application
Set WordApp = CreateObject("Word.Application")
On Error Resume Next
WordApp.Documents.Add
WordApp.Visible = True
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Shapes.SelectAll
Selection.Copy
WordApp.Selection.PasteSpecial DataType:=wdPasteShape
Application.CutCopyMode = False
WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.InsertBreak
Next ws
End Sub
2. Avoiding the same text box to be pasted
If you run the above macro, you'll still get the textbox(s) from the first sheet twice. Why? Because you are using Selection.Copy which is dependent on which sheet is active.
To make sure that the correct sheet is active, simply add ws.Activate before selecting the shapes like this:
Private Sub Export_v2()
Dim WordApp As Word.Application
Set WordApp = CreateObject("Word.Application")
On Error Resume Next
WordApp.Documents.Add
WordApp.Visible = True
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
ws.Shapes.SelectAll
Selection.Copy
WordApp.Selection.PasteSpecial DataType:=wdPasteShape
Application.CutCopyMode = False
WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.InsertBreak
Next ws
End Sub
3. Potential improvements
3.1 Avoid using Select inside Excel
Avoiding using Select in Excel VBA can lead to major speed improvements. However, in this case you can't just replace
ws.Shapes.SelectAll
Selection.Copy
with
ws.Shapes.Copy
as it won't copy the shapes. Instead, you would need to loop through each shape in the worksheet to paste them one by one. This might introduce more complications to your code, so if speed is not an issue, you could keep it as this.
3.2 Reset objects to nothing
To avoid Excel running out of memory, it is a good practice to always reset objects to nothing after you are done using them (at the end of your procedure in this case):
Set WordApp = Nothing
I'm looking to create a spell check macro for protected word documents. I'm more familiar with Excel VBA and I just created a similar project for protected spreadsheets so I attempted to follow the same logic. So far my code copies misspelled words from the office document, into a new excel workbook and then runs spellcheck, but I am having trouble pasting the new value back into the original word document. I can't have this require "adding a reference library" as this will need to be portable and run without end user intervention.
Here is what I have so far:
Sub SpellCheckDoc()
Dim lockedFields As Long
Dim unlockedFields As New Collection
For Each theFields In ActiveDocument.Fields
If theFields.Locked = True Then
lockedFields = lockedFields + 1
Else
unlockedFields.Add theFields
End If
Next theFields
If lockedFields = ActiveDocument.Fields.Count Then Exit Sub
'Word
Dim objWord As Object 'Word.Application
Set objWord = GetObject(, "Word.Application")
'Excel
Dim objExcel As Object, objWB As Object
Set objExcel = CreateObject("Excel.Application")
Set objWB = objExcel.Workbooks.Add
objExcel.Visible = True
Set wb = objExcel.ActiveWorkbook
Set ws = wb.Worksheets("Sheet1")
For Each theFields In unlockedFields
If CheckSpelling(theFields.Result.Text) = False Then
theFields.Copy ' Select text from Word Doc
'Paste into new workbook and spellcheck
With ws
.Range("A1").Select
.Paste
.Range("A1").CheckSpelling
.Range("A1").Copy
End With
objWord.theFields.Paste ''' This line doesn't work
End If
Next theFields
End Sub
Change theFields.Result.Text. So you can do .CheckSpelling in Excel, then make theFields.Result.Text = .Range("A1").Text
Dim correctSpelling as String
With ws
.Range("A1").Select
.Paste
.Range("A1").CheckSpelling
correctSpelling = .Range("A1").Text
End With
theFields.Result.Text = correctSpelling
End If
Next theFields
End Sub
I'm creating an Excel document that, among other things, copies a few arrays of data into a Word file.
Everything is working absolutely fine except that, when it pastes the selection I'm interested in, it pastes it infinitely until I intervene by taking down Word via Task Manager.
There is no reason, as far as I can see, for it to loop. So I'm pretty clueless of what to do next, and I was hoping you guys would shed a light into what I'm doing wrong. The concept is as follows:
Sub TestA()
'Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdbmRange As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnReport As Range
'Opening app and document
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open("C:\Users\RCO1\Desktop\Teste VBA\2. Conceptual Testing\Export\XLWDTST.docx")
Set wdbmRange = wdDoc.Bookmarks("TableInsertion").Range
'Selecting array
Sheets("ExportMe").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Pasting data
With wdbmRange
.PasteSpecial '<------- it simply goes back up to the beginning of the code at this point
CutCopyMode = False
End With
'Closing and saving
wdDoc.Save
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
End Sub
Just note that I can't simply transform this array into a table so to speak for formatting reasons.
After placing a few inquiries, I have been given the following simple, yet very effective, piece of code:
Set wdApp = CreateObject("Word.Application")
Filepath = Sheets("Proposal Generator").Range("I9")
Set wdDoc = Word.Documents.Open(Filepath)
with wdDoc
Sheets("Shhet1").Cells(1).CurrentRegion.Copy
.Bookmarks("TableInsertion").Range.PasteExcelTable 0, 0, 0
.SaveAs (TxtSaveFolder.Text & "\" & TxtFileName.Text)
End With
I hope this works for anyone who's trying to export tables.