When I try to generate a word document, it gets stopped at the 80% progress bar and it shows the following error.
When I try to debug it, I see this
I'm getting error in now For i = 1 To .InlineShapes.Count
My code
Sub FillABookmark(strBM As String, strText As String)
Dim j As Long
With ActiveDocument
.Bookmarks(strBM).Range _
.InlineShapes _
.AddPicture FileName:=strText
j = ActiveDocument.InlineShapes.Count
.InlineShapes(j).Select
.Bookmarks.Add strBM, Range:=Selection.Range
End With
End Sub
Sub AddImage(strFile As String, addOrAfter As Boolean)
Dim oImage As Object
'Dim oDialog As Dialog
' Dim oRng As Object
' Set oDialog = Dialogs(wdDialogInsertPicture)
' With oDialog
' .Display
' If .Name <> "" Then
' strFile = .Name
' End If
'End With
'Selection.Move 6, -1 'moverse al principio del documento
'Selection.Find.Execute FindText:="[aud_sig_1]"
'If Selection.Find.Found = True Then
If (addOrAfter) Then
Set oImage = Selection.InlineShapes.AddPicture(strFile, False, True)
'With oRng
' .RelativeHorizontalPosition = _
' wdRelativeHorizontalPositionPage
' .RelativeVerticalPosition = _
' wdRelativeVerticalPositionPage
'.Left = CentimetersToPoints(0)
'.Top = CentimetersToPoints(4.5)
'End With
Else
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Set oImage = Selection.InlineShapes.AddPicture(strFile, False, True)
End If
With oImage
.LockAspectRatio = msoFalse
.Height = CentimetersToPoints(1.5)
.Width = CentimetersToPoints(2.1)
Set oRng = .ConvertToShape
End With
Set oDialog = Nothing
Set oImage = Nothing
Set oRng = Nothing
End Sub
Sub PicWithCaption(xPath, Optional ByVal imgType As String = "All")
Dim xFileDialog As FileDialog
Dim xFile As Variant
Dim doc As Document
'******Test
'Set doc = Application.ActiveDocument
'xPath = "C:\phototest\"
'doc.Bookmarks.Exists ("photos")
'doc.Bookmarks("photos").Select 'select the bookmark
'*****End test
Dim x, w, c
Dim oTbl As Word.Table, i As Long, j As Long, k As Long, StrTxt As String
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 3)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(9)
'Format the rows
Call FormatRows(oTbl, 1)
End With
If xPath <> "" Then
xFile = Dir(xPath & "\*.*")
i = 1
CaptionLabels.Add Name:="Picture"
Do While xFile <> ""
If (UCase(Right(xFile, 3)) = "PNG" Or _
UCase(Right(xFile, 3)) = "TIF" Or _
UCase(Right(xFile, 3)) = "JPG" Or _
UCase(Right(xFile, 3)) = "GIF" Or _
UCase(Right(xFile, 3)) = "BMP") And (imgType = "All" Or UCase(Left(xFile, 1) <> imgType)) Then
j = Int((i + 2) / 3) * 2 - 1
k = (i - 1) Mod 3 + 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
'Dim shape As InlineShape
' ActiveDocument.InlineShapes.AddPicture _
' FileName:=xPath & "\" & xFile, LinkToFile:=False, _
' SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range
Set shape = ActiveDocument.InlineShapes.AddPicture(xPath & "\" & xFile, False, True, oTbl.Rows(j).Cells(k).Range)
oTbl.Rows(j).Cells(k).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
' With shape
' .LockAspectRatio = msoTrue
' If .Width > .Height Then
' .Height = InchesToPoints(1.75)
' Else
' .Width = InchesToPoints(1.75)
' End If
' End With
'shape.ScaleWidth = 50
'Get the Image name for the Caption
'StrTxt = Split(xPath & "\" & xFile, "\")(UBound(Split(.SelectedItems(i), "\")))
StrTxt = xFile
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(k).Range
.InsertBefore vbCr
.Characters.First.InsertParagraph
.InsertBefore StrTxt
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Font.Bold = True
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
End If
i = i + 1
xFile = Dir()
Loop
End If
'End If
End Sub
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(6)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
.Alignment = wdAlignRowCenter
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(1.2)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
.Alignment = wdAlignRowCenter
End With
End With
End Sub
Sub rezie()
Dim i As Long
With ThisDocument
For i = 1 To .InlineShapes.Count
Next i
End With
End Sub
Use the style enums to be on the safe side when on a non-english system:
.Range.Style = Word.wdStyleCaption (in case you are using early binding - what you are using)
In case of late binding: .Range.style = -35
Related
Im not good in Visual Basic but I have task to make macros from 32 bit windows excel available on 64 bit window :)
The task is to make EMF from Excel page - I`ve already changed "function" to "PtrSafe function" and "olepro32.dll" to "oleaut32.dll" but code is running with error - RunTime error "380" Invalid property value
Sub UpdateRtLogsandEMF()
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
Application.ScreenUpdating = False
This.Worksheets("TempSQL").Visible = xlSheetVisible
This.Worksheets("TempLog").Visible = xlSheetVisible
This.Worksheets("TempLog").Select
Set cn = New ADODB.Connection
sCon = This.Worksheets("TempSQL").Cells(1, 1)
cn.Open sCon
DrillDepthIndex = This.Worksheets("TempLog").Cells(1, 157)
DrillDepthIndex = "'" & DrillDepthIndex & "'"
WellPathIndex = This.Worksheets("TempLog").Cells(1, 154)
WellPathIndex = "'" & WellPathIndex & "'"
Set rs = New ADODB.Recordset
sql_query = "SELECT Depth FROM GENDATAINDEX WHERE GenDataSetId = " & DrillDepthIndex & "ORDER BY Time DESC"
rs.Open sql_query, cn
On Error Resume Next
sss = rs.Fields(0)
If sss = "" Then
This.Worksheets("Logs RT").Cells(14, 19) = ""
Else
This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
End If
'This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
Date1 = Format(Now, "yyyy.mm.dd")
Day1 = Right(Date1, 2)
Year1 = Left(Date1, 4)
Month1 = Mid(Date1, 6, 2)
If This.Worksheets("TempLog").Cells(1, 210) = "RUS" Then
dfd = 43
Else
dfd = 42
End If
This.Worksheets("Logs RT").Cells(11, 15) = Day1 & " " & This.Worksheets("Logs RT").Cells(Month1, dfd) & " " & Year1
This.Worksheets("Logs RT").Cells(12, 15) = Format(Now, "HH:mm")
This.Worksheets("Logs RT").Select
Set rs = New ADODB.Recordset
sql_query = "SELECT SRSP_S_VDEPTH FROM SURVEY_STATION WHERE PATH_IDENTIFIER = " & WellPathIndex & " ORDER BY SRSP_TIME DESC"
rs.Open sql_query, cn
On Error Resume Next
sss = rs.Fields(0)
If sss = "" Then
This.Worksheets("Logs RT").Cells(14, 62) = ""
Else
This.Worksheets("Logs RT").Cells(14, 62) = Round(rs.Fields(0), 2)
End If
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_MD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 2), Cells(67, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_TVD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 45), Cells(67, 75)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
This.Worksheets("Logs RT").Select
This.Worksheets("TempSQL").Visible = xlSheetHidden
This.Worksheets("TempLog").Visible = xlSheetHidden
Application.ScreenUpdating = True
End Sub
Sub MakeRtLogsEMF()
Application.ScreenUpdating = False
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
Set This = ThisWorkbook
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_MD.emf"
'Get the type of bitmap
lPicType = xlPicture
'Copy a picture to the clipboard
This.Worksheets("Logs RT").Range(Cells(2, 2), Cells(67, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
'Retrieve the picture from the clipboard...
Set oPic = PastePicture(lPicType)
'... and save it to the file
SavePicture oPic, vFile
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_TVD.emf"
'Get the type of bitmap
lPicType = xlPicture
'Copy a picture to the clipboard
This.Worksheets("Logs RT").Range(Cells(2, 45), Cells(67, 75)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
'Retrieve the picture from the clipboard...
Set oPic = PastePicture(lPicType)
'... and save it to the file
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
'
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
Application.ScreenUpdating = True
End Sub
Sub MakeTailEMF()
Application.ScreenUpdating = False
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
Set This = ThisWorkbook
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_tail.emf"
'Get the type of bitmap
lPicType = xlPicture
'Copy a picture to the clipboard
This.Worksheets("Logs RT").Range(Cells(70, 2), Cells(78, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
'Retrieve the picture from the clipboard...
Set oPic = PastePicture(lPicType)
'... and save it to the file
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
'
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
Application.ScreenUpdating = True
End Sub
Sub UpdateRtLogsandEMF_woDepth()
Set This = ThisWorkbook
Dim aaa1 As Single
Dim aaa2 As Single
Application.ScreenUpdating = False
This.Worksheets("TempSQL").Visible = xlSheetVisible
This.Worksheets("TempLog").Visible = xlSheetVisible
This.Worksheets("TempLog").Select
Set cn = New ADODB.Connection
sCon = This.Worksheets("TempSQL").Cells(1, 1)
cn.Open sCon
'DrillDepthIndex = This.Worksheets("TempLog").Cells(1, 157)
'DrillDepthIndex = "'" & DrillDepthIndex & "'"
'WellPathIndex = This.Worksheets("TempLog").Cells(1, 154)
'WellPathIndex = "'" & WellPathIndex & "'"
'Set rs = New ADODB.Recordset
'sql_query = "SELECT Depth FROM GENDATAINDEX WHERE GenDataSetId = " & DrillDepthIndex & "ORDER BY Time DESC"
'rs.Open sql_query, cn
'On Error Resume Next
'sss = rs.Fields(0)
'If sss = "" Then
'This.Worksheets("Logs RT").Cells(14, 19) = ""
'Else
'This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
'End If
'This.Worksheets("Logs RT").Cells(14, 19) = Round(rs.Fields(0), 2)
Date1 = Format(Now, "yyyy.mm.dd")
Day1 = Right(Date1, 2)
Year1 = Left(Date1, 4)
Month1 = Mid(Date1, 6, 2)
This.Worksheets("Logs RT").Cells(11, 15) = Day1 & " " & This.Worksheets("Logs RT").Cells(Month1, 43) & " " & Year1
This.Worksheets("Logs RT").Cells(12, 15) = Format(Now, "HH:mm")
This.Worksheets("Logs RT").Select
'Set rs = New ADODB.Recordset
'sql_query = "SELECT SRSP_S_VDEPTH FROM SURVEY_STATION WHERE PATH_IDENTIFIER = " & WellPathIndex & " ORDER BY SRSP_TIME DESC"
'rs.Open sql_query, cn
'On Error Resume Next
'sss = rs.Fields(0)
'If sss = "" Then
'This.Worksheets("Logs RT").Cells(14, 62) = ""
'Else
'This.Worksheets("Logs RT").Cells(14, 62) = Round(rs.Fields(0), 2)
'End If
If This.Worksheets("TempLog").Cells(9, 151) = True Then
aaa1 = apiGetSystemMetrics(0&)
aaa2 = apiGetSystemMetrics(1&)
ChangeResolution 1280, 960
End If
' With Application.ErrorCheckingOptions
' .TextDate = False
' .NumberAsText = False
' .InconsistentFormula = False
' .UnlockedFormulaCells = False
' .EmptyCellReferences = False
' End With
' If ActiveWindow.DisplayGridlines Then
' bGridOn = True
' ActiveWindow.DisplayGridlines = False
' End If
Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_MD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 2), Cells(67, 32)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
sFilter = "Windows Metafile (*.emf),*.emf"
vFile = This.Worksheets("TempLog").Cells(1, 152) & "RT_header_TVD.emf"
lPicType = xlPicture
This.Worksheets("Logs RT").Range(Cells(2, 45), Cells(67, 75)).Select
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
Set oPic = PastePicture(lPicType)
SavePicture oPic, vFile
' If bGridOn Then ActiveWindow.DisplayGridlines = True
' With Application.ErrorCheckingOptions
' .TextDate = True
' .NumberAsText = True
' .InconsistentFormula = True
' .UnlockedFormulaCells = True
' .EmptyCellReferences = True
' End With
If This.Worksheets("TempLog").Cells(9, 151) = True Then
ChangeResolution aaa1, aaa2
End If
This.Worksheets("Logs RT").Select
This.Worksheets("TempSQL").Visible = xlSheetHidden
This.Worksheets("TempLog").Visible = xlSheetHidden
Application.ScreenUpdating = True
End Sub
Debugger stops at "SavePicture oPic, vFile"
I already have a script that gets list of file in a folder but I need to include subfolders as well, can you please help me modify this, I have tried to compile something from the answers found here but failed.
Sub getfiles()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel reports")
For Each oFile In oFolder.Files
If oFile.DateLastModified > Now - 7 Then
Cells(i + 1, 1) = oFolder.Path
Cells(i + 1, 2) = oFile.Name
Cells(i + 1, 3) = "RO"
Cells(i + 1, 4) = oFile.DateLastModified
i = i + 1
End If
Next oFile
Here's a non-recursive method:
Sub getfiles()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object, sf
Dim i As Integer, colFolders As New Collection, ws As Worksheet
Set ws = ActiveSheet
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel")
colFolders.Add oFolder 'start with this folder
Do While colFolders.Count > 0 'process all folders
Set oFolder = colFolders(1) 'get a folder to process
colFolders.Remove 1 'remove item at index 1
For Each oFile In oFolder.Files
If oFile.DateLastModified > Now - 7 Then
ws.Cells(i + 1, 1) = oFolder.Path
ws.Cells(i + 1, 2) = oFile.Name
ws.Cells(i + 1, 3) = "RO"
ws.Cells(i + 1, 4) = oFile.DateLastModified
i = i + 1
End If
Next oFile
'add any subfolders to the collection for processing
For Each sf In oFolder.subfolders
colFolders.Add sf
Next sf
Loop
End Sub
Here's a much simpler and faster method. This should write all the results in a text file and all you have to do is to open that file and read its contents.
Sub List_All_Files_And_SubFolders()
PID = Shell("cmd /k dir c:\test /s /b > c:\test\all_files.txt", vbHide)
While IsFileInUse() = True: DoEvents: Wend
End Sub
Function IsFileInUse()
On Error GoTo Error_Handeling
IsFileInUse = True
Name "c:\test\all_files.txt" As "c:\test\all_files1.txt"
Name "c:\test\all_files1.txt" As "c:\test\all_files.txt"
IsFileInUse = False
Error_Handeling:
If Err.Description = "Path/File access error" Then IsFileInUse = True: Exit Function
End Function
You can do it this way.
Sub FileListingAllFolder()
' Open folder selection
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
If Right(pPath, 1) <> "\" Then
pPath = pPath & "\"
End If
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the file list
' add headers
ActiveSheet.Name = "ListOfFiles"
With Range("A2")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File Name:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("A3:F3").Font.Bold = True
Worksheets("ListOfFiles").Range("A1").Value = pPath
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
' list all files included subfolders
Range("A3").Select
Lastrow = Range("A1048576").End(xlUp).Row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
"B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ListOfFiles").Sort
.SetRange Range("A3:F" & Lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
NextCode:
MsgBox "No files Selected!!"
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A1048576").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path & FileItem.Name
Cells(r, 2).Formula = (FileItem.Size / 1048576)
Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
' use file methods (not proper in this example)
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:F").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Under Tools, set a reference to 'Microsoft Scripting Runtime'.
#Tadas: "...but somehow it doesn't even show up as a macro and I can not run it."
Try declaring the sub as Public, e.g. Public Sub FileListingAllFolder() .
Private subs and private functions do not show up in the Macros list.
I became motivated to provide for myself with a kind of universal function which returns a collection of folder objects plus optionally all sub-folders all in ascending order. The collection then may be used for any purpose just by looping through the collection. The function looks as follows:
Public Function Folders(Optional ByVal fo_spec As String = vbNullString, _
Optional ByVal fo_subfolders As Boolean = False, _
Optional ByRef fo_result As String) As Collection
' ----------------------------------------------------------------------------
' Returns all folders in a folder (fo_spec) - optionally including all
' sub-folders (fo_subfolders = True) - as folder objects in ascending order.
' When no folder (fo_spec) is provided a folder selection dialog request one.
' When the provided folder does not exist or no folder is selected the
' the function returns with an empty collection. The provided or selected
' folder is returned (fo_result).
' ----------------------------------------------------------------------------
Static cll As Collection
Static Queue As Collection ' FiFo queue for folders with sub-folders
Static Stack As Collection ' LiFo stack for recursive calls
Static foStart As Folder
Dim aFolders() As Variant
Dim fl As File
Dim flStart As Folder
Dim fo1 As Folder
Dim fo2 As Folder
Dim fso As New FileSystemObject
Dim i As Long
Dim j As Long
Dim s As String
Dim v As Variant
If cll Is Nothing Then Set cll = New Collection
If Queue Is Nothing Then Set Queue = New Collection
If Stack Is Nothing Then Set Stack = New Collection
If Queue.Count = 0 Then
'~~ Provide the folder to start with - when not provided by fo_spec via a selection dialog
If fo_spec <> vbNullString Then
If Not fso.FolderExists(fo_spec) Then
fo_result = fo_spec
GoTo xt
End If
Set fo1 = fso.GetFolder(fo_spec)
Else
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the desired folder!"
.InitialFileName = CurDir
.AllowMultiSelect = False
If .Show <> -1 Then GoTo xt
Set fo1 = fso.GetFolder(.SelectedItems(1))
End With
End If
Set foStart = fo1
Else
'~~ When recursively called (Queue.Count <> 0) take first sub-folder queued
Set fo1 = Queue(1)
End If
For Each fo2 In fo1.SubFolders
cll.Add fo2
If fo1.SubFolders.Count <> 0 And fo_subfolders Then
Queue.Add fo2
End If
Next fo2
Stack.Add cll ' stack result in preparation for the function being called resursively
If Queue.Count > 0 Then
Queue.Remove 1
End If
If Queue.Count > 0 Then
Folders Queue(1).Path ' recursive call for each folder with subfolders
End If
xt: Set fso = Nothing
If Stack.Count > 0 Then
Set cll = Stack(Stack.Count)
Stack.Remove Stack.Count
End If
If Stack.Count = 0 Then
If cll.Count > 0 Then
'~~ Unload cll to array, when fo_subfolders = False only those with a ParentFolder foStart
ReDim aFolders(cll.Count - 1)
For Each v In cll
aFolders(i) = v
i = i + 1
Next v
'~~ Sort array from A to Z
For i = LBound(aFolders) To UBound(aFolders)
For j = i + 1 To UBound(aFolders)
If UCase(aFolders(i)) > UCase(aFolders(j)) Then
s = aFolders(j)
aFolders(j) = aFolders(i)
aFolders(i) = s
End If
Next j
Next i
'~~ Transfer array as folder objects to collection
Set cll = New Collection
For i = LBound(aFolders) To UBound(aFolders)
Set fo1 = fso.GetFolder(aFolders(i))
cll.Add fo1
Next i
End If
Set Folders = cll
If Not foStart Is Nothing Then fo_result = foStart.Path
End If
Set cll = Nothing
End Function
The function had been tested as follows:
Private Sub Folders_Test()
Const TEST_FOLDER = "E:\Ablage\Excel VBA\DevAndTest"
Dim v As Variant
Dim cll As Collection
Dim s As String
Dim sStart As String
Set cll = Folders("c:\XXXX", True, sStart)
s = "1. Test: Folders in a provided non-existing folder ('" & sStart & "')"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
Debug.Assert cll.Count = 0
Set cll = Folders(TEST_FOLDER, , sStart)
s = "2. Test: Folders in the provided folder '" & sStart & "' (without sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(TEST_FOLDER, True, sStart)
s = "3. Test: Folders in the provided folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(, True, sStart)
s = "4. Test: Folders in the manually selected folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
End Sub
I am running the following working Macro on word visual basic. Each time I run it, the macro successfully generates the report how I want it to; but then I look in the task manager and I see that an instance of excel is still running. I run the debugger over the code, the debugger goes through the final line:
oExcel.quit
and yet it still doesn't terminate the application!
Sub WriteExtension()
'
' WriteExtension Macro
'
'
copyFile
Dim nWord As New Document
word.Application.ScreenUpdating = False
Set nWord = Documents.Open("c:\output\report\here\report", Visible:=False)
'initialize excel variables
Dim oExcel As Excel.Application
Dim oWorkbook As workbook
Dim oWorksheet As worksheet
'initialize excel object
Set oExcel = New Excel.Application
oExcel.ScreenUpdating = False
Set oWorkbook = oExcel.Workbooks.Open("c:\spreadsheet\here\spreadsheet.xlsx")
Set oWorksheet = oWorkbook.Worksheets(Sheets("Extensions").Index)
'setup loop variables
Dim tempString As String
Dim delim As String
Dim i As Long
Dim bkMark As Bookmark
Dim questions(13) As String
questions(0) = 13
questions(1) = 15
questions(2) = 17
questions(3) = 19
questions(4) = 29
questions(5) = 31
questions(6) = 33
questions(7) = 36
questions(8) = 38
questions(9) = 40
questions(10) = 42
questions(11) = 46
questions(12) = 48
delim = "#"
tempString = delim & Join(questions, delim)
Dim bmrange As Range
For i = 1 To 78
If (InStr(1, tempString, delim & i & delim, vbTextCompare)) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If (Cells(4, i + 6) = 1) Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
ElseIf (InStr(1, tempString, delim & (i - 1) & delim, vbTextCompare)) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If (Cells(4, i + 6) = 1) Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
Else
nWord.Bookmarks.Item("BM" & i).Range.InsertAfter (Cells(4, i + 6))
End If
Next i
Dim filePath As String
Dim fileName As String
Dim newName As String
' save the file as a PDF and close the PDF
filePath = "c:\output\report\here\report"
fileName = Cells(4, 13) & Cells(4, 12) & Cells(4, 79) & ".pdf"
newName = filePath & fileName
nWord.SaveAs2 fileName:=newName, FileFormat:=wdFormatPDF
' Close things
nWord.Close False
oWorkbook.Close False
oExcel.Quit
End Sub
I suspect that your issue is related to your unqualified Sheets and Cells references.
Set oWorksheet = oWorkbook.Worksheets(Sheets("Extensions").Index) should probably just be Set oWorksheet = oWorkbook.Worksheets("Extensions") (no need to get the index of a sheet by using its name just to get a reference to the sheet, when you can just index it by its name) and Cells(4, i + 6) should probably be oWorksheet.Cells(4, i + 6).
I could replicate your issue before I made those changes (although sometimes the code would just crash), but once I fixed them Excel correctly closed at the End Sub. (It didn't disappear after the oExcel.Quit because oExcel wasn't Nothing yet.)
Sub WriteExtension()
'
' WriteExtension Macro
'
'
copyFile
Dim nWord As New Document
word.Application.ScreenUpdating = False
Set nWord = Documents.Open("c:\output\report\here\report", Visible:=False)
'initialize excel variables
Dim oExcel As Excel.Application
Dim oWorkbook As workbook
Dim oWorksheet As worksheet
'initialize excel object
Set oExcel = New Excel.Application
oExcel.ScreenUpdating = False
Set oWorkbook = oExcel.Workbooks.Open("c:\spreadsheet\here\spreadsheet.xlsx")
Set oWorksheet = oWorkbook.Worksheets("Extensions")
'setup loop variables
Dim tempString As String
Dim delim As String
Dim i As Long
Dim bkMark As Bookmark
Dim questions(13) As String
questions(0) = 13
questions(1) = 15
questions(2) = 17
questions(3) = 19
questions(4) = 29
questions(5) = 31
questions(6) = 33
questions(7) = 36
questions(8) = 38
questions(9) = 40
questions(10) = 42
questions(11) = 46
questions(12) = 48
delim = "#"
tempString = delim & Join(questions, delim)
Dim bmrange As Range
For i = 1 To 78
If (InStr(1, tempString, delim & i & delim, vbTextCompare)) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If oWorksheet.Cells(4, i + 6) = 1 Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
ElseIf InStr(1, tempString, delim & (i - 1) & delim, vbTextCompare) Then
Set bmrange = nWord.Bookmarks("BM" & (i)).Range
If oWorksheet.Cells(4, i + 6) = 1 Then
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = True
Else
nWord.ContentControls.Add(wdContentControlCheckBox, bmrange).Checked = False
End If
Else
nWord.Bookmarks.Item("BM" & i).Range.InsertAfter (oWorksheet.Cells(4, i + 6))
End If
Next i
Dim filePath As String
Dim fileName As String
Dim newName As String
' save the file as a PDF and close the PDF
filePath = "c:\output\report\here\report"
fileName = oWorksheet.Cells(4, 13) & oWorksheet.Cells(4, 12) & oWorksheet.Cells(4, 79) & ".pdf"
newName = filePath & fileName
nWord.SaveAs2 fileName:=newName, FileFormat:=wdFormatPDF
' Close things
nWord.Close False
oWorkbook.Close False
oExcel.Quit
'Optional: Set Excel objects to Nothing so that Excel closes now instead of at End Sub
Set oWorkbook = Nothing
Set oExcel = Nothing
End Sub
Just a short question, how to generate a barcode in excel worksheet? The barcode-text has been specified in a cell.
(Not intent to mass generate barcodes which otherwise can be done in MS Word.)
Select the range where barcode-text is written:
Then run the following script:
Sub INSERT_BARCODE()
Const BarcodeWidth As Integer = 156
Dim ws As Worksheet, WdApp
Set ws = ActiveSheet
Set WdApp = CreateObject("Word.Application")
With WdApp.Documents.Add
.PageSetup.RightMargin = .PageSetup.PageWidth - .PageSetup.LeftMargin - BarcodeWidth
.Fields.Add(Range:=.Range, Type:=-1, Text:="DISPLAYBARCODE " & CStr(Selection.Value) & " CODE39 \d \t", PreserveFormatting:=False).Copy
End With
ws.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
WdApp.Quit SaveChanges:=False
Set WdApp = Nothing
End Sub
Note:
Change the encoding rule as you like. This example uses CODE39 rule. Refer https://msdn.microsoft.com/en-us/library/hh745901(v=office.12).aspx for more details.
Adjust the BarcodeWidth interger to best fit the barcode.
BR~
This is massively over-specced for what you need, but you can pull the bits out of it as required.
Sub Call_Barcode_Service()
Dim strResource As String
Dim strSize As String
Dim iHgt As Integer
Dim iWth As Integer
Dim iGap As Integer
Dim PictureGrab As String
Dim lngLastRow As Long
strSize = UCase(InputBox("How Big?", "Small, Medium or Large?", "L"))
Select Case strSize
Case Is = "S"
iWth = 150
iHgt = 45
iGap = 3
Case Is = "M"
iWth = 150
iHgt = 60
iGap = 4
Case Is = "L"
iWth = 240
iHgt = 75
iGap = 5
Case Else
iWth = 250
iHgt = 75
iGap = 5
End Select
Set sel = Selection.SpecialCells(xlTextValues)
Set news = Worksheets.Add()
news.Name = "Barcodes"
Set op = news.Range("A1")
For Each acc In sel
strResource = acc.Value
PictureGrab = "http://www.barcodesinc.com/generator/image.php?code=" & strResource & "&style=197&type=C128B&width=" & iWth & "&height=" & iHgt & "&xres=1&font=1"
Set sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, op.Left, op.Top, iWth, iHgt)
With sh
.Name = strResource
.Line.Visible = False
.Fill.UserPicture PictureGrab
End With
Set op = op.Offset(iGap + 1, 0).Range("A1")
Next
Range("G1").Select
End Sub
I use word with Macro :
Sub Macro1()
'
' Macro1 Macro
' Test Barcode
'
Dim codei As String
Dim codej As String
For I = 1 To 1 '0
For J = 1 To 2 '0
codei = CStr(I)
While Len(codei) < 2
codei = "0" & codei
Wend
codej = CStr(J)
While Len(codej) < 4
codej = "0" & codej
Wend
codei = codei & codej
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeText Text:="DisplayBarcode " & codei & " Code128 \t"
Selection.TypeParagraph
Selection.Fields.Update
Next J
Next I
End Sub
I have seen this asked multiple times but none of the solutions offered have solved my issue- I continue to get this error even though I have used the same code in multiple other applications with no errors. I have included the code below and hope that someone can spot the issue that I am just failing to see!
Sub CreateJobsGraphsPrincipalCategory()
'Initial variables
Dim wbnew As Workbook
Dim wsnew As Worksheet
Dim Datasheet As Worksheet
'Dataset variables
Dim BeneficiaryList(0 To 10000), PrincipalList(0 To 10000), CheckRange As String
Dim NumberRows, RowNumber As Long
Dim Isduplicate, intPrincipal, intStatus, intLineItem As Integer
Dim PrincipalColumn, StatusColumn, LineItemColumn As String
Dim PrincipalRange, StatusRange, LineItemRange As String
Dim PrincipalNumber, BeneficiaryNumber As Integer
'New PivotChart variables
Dim objPivotcache As PivotCache
Dim objPivotTable As PivotTable
Dim bcount As Integer
Dim ProsperatorArray(1 To 25) As String
Dim BusinessNameColumn, BeneficiaryName, BeneficiaryNameFind As String
Dim objPivot As PivotTable, objPivotRange As Range, objChart As Chart
Dim LastColumnNumber As Double
'Setup workbooks
Dim CurrentWorkbook As Workbook
Dim SaveToWorkbook As Workbook
'Stop screen updating and calculating furing processing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Select overall datasheet
Worksheets("DataforPrincipals").Activate
Set Datasheet = ActiveSheet
'Find last column. Start from column 30 as it will not be less than this
LastColumnNumber = 30
LastColumnValue = Datasheet.Cells(1, LastColumnNumber)
While LastColumnValue <> ""
LastColumnNumber = LastColumnNumber + 1
LastColumnValue = Datasheet.Cells(1, LastColumnNumber)
Wend
LastColumnNumber = LastColumnNumber - 1
'LastColumnValue = Datasheet.Cells(1, LastColumnNumber)
LastColumnValue = Getcolumn(LastColumnNumber)
'get last row
LastRowNumber = 1
LastRowRange = "A" & LastRowNumber
LastRowValue = Datasheet.Cells(LastRowNumber, 1)
While LastRowValue <> ""
LastRowNumber = LastRowNumber + 1
LastRowRange = "A" & LastRowNumber
LastRowValue = Datasheet.Cells(LastRowNumber, 1)
Wend
LastRowNumber = LastRowNumber - 1
PivotRange = "A" & "1" & ":" & LastColumnValue & LastRowNumber
'Creating Pivot cache
Set objPivotcache = ActiveWorkbook.PivotCaches.Create(xlDatabase, "'DataforPrincipals'!" & PivotRange)
'Create Arrays for Beneficiaries and Principals
'Get Columns for filtering and checking
PrincipalColumn = FindDataColumnHeading("Principal")
' StatusColumn = FindDataColumnHeading("Status")
LineItemColumn = FindDataColumnHeading("Line Item")
BusinessNameColumn = FindDataColumnHeading("Business Name")
RowNumber = 2
NumberRows = 0
CheckRange = BusinessNameColumn & RowNumber
PrincipalNumber = 1
BeneficiaryNumber = 1
While Datasheet.Range(CheckRange) <> ""
NumberRows = NumberRows + 1
PrincipalRange = PrincipalColumn & RowNumber
' StatusRange = StatusColumn & RowNumber
LineItemRange = LineItemColumn & RowNumber
' If Datasheet.Range(StatusRange) = "Active" Then
If Datasheet.Range(LineItemRange) = "Turnover" Then
BeneficiaryList(BeneficiaryNumber) = Datasheet.Range(CheckRange)
BeneficiaryNumber = BeneficiaryNumber + 1
'Check if principal is in the dataset yet
If RowNumber = 2 Then
PrincipalList(PrincipalNumber) = UCase(Trim(Datasheet.Range(PrincipalRange)))
Else
PrincipalNumber = PrincipalNumber + 1
Isduplicate = 0
For i = 1 To PrincipalNumber
If PrincipalList(i) = UCase(Trim(Datasheet.Range(PrincipalRange))) Then
Isduplicate = 1
End If
Next i
If Isduplicate = 0 Then
PrincipalList(PrincipalNumber) = UCase(Trim(Datasheet.Range(PrincipalRange)))
Else
PrincipalNumber = PrincipalNumber - 1
End If
End If
End If
' End If
RowNumber = RowNumber + 1
CheckRange = BusinessNameColumn & RowNumber
Wend
Set CurrentWorkbook = Application.ActiveWorkbook
' Set wbnew = Workbooks.Add
'wbnew = ActiveWorkbook.Name
CurrentWorkbook.Activate
For i = 1 To PrincipalNumber
PrincipalNameFind = PrincipalList(i)
If PrincipalList(i) <> PrincipalList(i - 1) Then
If InStr(1, PrincipalList(i), "(") > 0 Then
PrincipalName = Left(PrincipalList(i), 25) & 0
Else
PrincipalName = Left(PrincipalList(i), 25)
End If
'Adding new worksheet
Worksheets("DataforPrincipals").Activate
Set wsnew = Worksheets.Add
wsnew.Name = PrincipalName & "JC"
Worksheets(PrincipalName & "JC").Activate
'Creating Pivot table
Set objPivotTable = objPivotcache.CreatePivotTable(wsnew.Range("A1"))
'set Beneficiary row field
'Setting Fields
With objPivotTable
With .PivotFields("Principal")
.Orientation = xlPageField
.CurrentPage = "ALL"
.ClearAllFilters
.CurrentPage = PrincipalNameFind
End With
'set data fields (PI TO, TO)
With .PivotFields("Category")
.Orientation = xlRowField
End With
.AddDataField .PivotFields("PI Total Staff"), "PI Jobs", xlSum
.AddDataField .PivotFields("Current Total Staff"), "Current Jobs", xlSum
.AddDataField .PivotFields("Job Growth"), "Job Growth ", xlSum
With .PivotFields("PI Jobs")
.NumberFormat = "#"
End With
With .PivotFields("Current Jobs")
.NumberFormat = "#"
End With
With .PivotFields("Job Growth ")
.NumberFormat = "#%"
End With
End With
' Access the new PivotTable from the sheet's PivotTables collection.
Set objPivot = ActiveSheet.PivotTables(1)
' Add a new chart sheet.
Set objChart = Charts.Add
' Create a Range object that contains
' all of the PivotTable data, except the page fields.
Set objPivotRange = objPivot.TableRange1
' Specify the PivotTable data as the chart's source data.
With objChart
.ShowAllFieldButtons = False
.SetSourceData objPivotRange
.ChartType = xlColumnClustered
.ApplyLayout (5)
With .ChartTitle
.Text = " Employment Growth performance per Category"
End With
.SeriesCollection(1).HasDataLabels = False
.SeriesCollection(2).HasDataLabels = False
.SeriesCollection(3).HasDataLabels = False
.Axes(xlCategory).HasTitle = False
.DataTable.Select
End With
If InStr(1, PrincipalList(i), "(") > 0 Then
PrincipalName = Left(PrincipalList(i), 25) & 0
Else
PrincipalName = Left(PrincipalList(i), 25)
End If
ActiveSheet.Name = PrincipalName & " JCG"
If Sheetslist = "" Then
Sheetslist = PrincipalName & " JCG"
Else
Sheetslist = Sheetslist & ", " & PrincipalName & " JOBS"
End If
End If
Next i
'Copy to new file
Set CurrentWorkbook = Application.ActiveWorkbook
DirectoryName = Sheets("Run Automated").Range("B1")
For i = 1 To PrincipalNumber
If PrincipalList(i) <> PrincipalList(i - 1) Then
With Worksheets("Run Automated")
NameFileInitial = .Range("B2") & " " & PrincipalList(i) & ".xlsm"
End With
If InStr(1, PrincipalList(i), "(") > 0 Then
PrincipalName = Left(PrincipalList(i), 25) & 0
Else
PrincipalName = Left(PrincipalList(i), 25)
End If
'Set sheets to save
sheet1save = PrincipalName & " TC"
sheet2save = PrincipalName & " TOC"
sheet7save = PrincipalName & "JC"
sheet8save = PrincipalName & " JCG"
Set CurrentWorkbook = Application.ActiveWorkbook
Namefile = DirectoryName & "\" & NameFileInitial
Workbooks.Open Namefile
Set SaveToWorkbook = Application.ActiveWorkbook
Application.DisplayAlerts = False
CurrentWorkbook.Sheets(Array(sheet1save, sheet2save, sheet7save, sheet8save)).Move Before:=SaveToWorkbook.Sheets(1)
ActiveWorkbook.Close (True)
Application.DisplayAlerts = True
CurrentWorkbook.Activate
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub