I am using some code i harvested from the internet to read the metadata from files in a folder.
To create the shell folder object i need to pass the path to the shell app object.
I am using the following code:
Sub ReadMetadata()
Dim iShell
Dim iDir
Dim iFile As Variant
Dim RowEntry As Double
RF_FolderToRead = "C:\test"
Set iShell = CreateObject("Shell.Application")
'ActiveCell.Value = RF_FolderToRead
Set iDir = iShell.Namespace(RF_FolderToRead)
'Set iDir = iShell.Namespace(ActiveCell.Value)
If iDir Is Nothing Then
MsgBox "Folder Not Found"
Set iShell = Nothing
Exit Sub
End If
RowEntry = 1
For Each iFile In iDir.Items
If Right(iFile.Name, 3) = "m4a" Or Right(iFile.Name, 3) = "mp3" Then
DoEvents
ArtistName = iDir.GetDetailsOf(iFile, 20)
TrackName = iDir.GetDetailsOf(iFile, 21)
With ActiveSheet
.Cells(RowEntry, ActiveCell.Column).Value = ArtistName
.Cells(RowEntry, ActiveCell.Column + 1).Value = TrackName
End With
RowEntry = RowEntry + 1
End If
Next iFile
Set iShell = Nothing
Set iDir = Nothing
Set iFile = Nothing
End Sub
The above code does not set the iDir Object, and does not throw an error, however uncommenting the line which sets activecell.value to the RF_FolderToRead, and that which then passes activecell.value to iShell works fine.
Can anyone reproduce this strange behaviour, or suggest a reason and/or a workaround that does not involve writing to a cell first?
Any and all assistance is greatly appreciated!
Related
I am running the following code. The code is for finding some particular values in all the Excel sheets in a folder.
It gives me the error
"Sorry, we couldn't find the file. Is it possible it was moved, renamed or deleted?"
when it executes
Set wbSlave = Workbooks.Open(filename:=myfilname)
Please help.
Sub find_cells()
Dim i, j As Integer
Dim cell_content As String
Dim total_values As Long
Dim cell_location As Range
Dim cell_address As String
Dim sht As Worksheet
Dim myfilname As String
Dim fldrpath As String
Dim wbMaster As Workbook
Dim wbSlave As Workbook
Dim currentfilename As String
Set wbMaster = ThisWorkbook
j = 3
total_values = Application.WorksheetFunction.CountA(wbMaster.Sheets("Engine").Range("A:A"))
fldrpath = "C:\test\"
myfilname = Dir(fldrpath & "*.xls*")
Application.ScreenUpdating = False
Do While myfilname <> ""
'myfilname = Dir()
Set wbSlave = Workbooks.Open(filename:=myfilname)
For Each sht In wbSlave.Sheets
For i = 2 To total_values
cell_content = wbMaster.Sheets("Engine").Range("A" & i).Value
With sht.UsedRange
Set cell_location = .Find(cell_content, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
If Not cell_location Is Nothing Then
cell_address = cell_location.Address
Do
wbMaster.Sheets("Sheet1").Columns(j).Value = cell_location.EntireColumn.Value
j = j + 1
Set cell_location = .FindNext(cell_location)
Loop While Not cell_location Is Nothing And cell_location.Address <> cell_address
End If
End With
Set cell_location = Nothing
If i = total_values Then Exit For
Next i
Next
myfilname = Dir()
Loop
End Sub
The Dir function returns only the matching filename - no path. Then if you try to open it and you are currently not in a correct folder, you get this error.
Set a watch to the variable myfilname or just add Debug.Print myfilname and you see it right away.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dir-function
I have this code that searches a separate workbook, on a particular sheet and gives me the data in the next cell of what I have searched. This works fine if the searched item is found but I can't seem to adapt the code if the searched item is not found. When this happens I just want to return a message to the label on the user form that the item is not found. I have watched and read tutorials and tried using If Not Is Nothing but I just can't seem to get it to work.
I'd be grateful if someone could help? Many thanks.
Dim departments As Workbook
Dim searchItem As String
Dim foundItem As String
Set departments = Workbooks.Open("C:\Users\MyPc\Desktop\Department References.xls")
searchItem = UserForm1.Textbox1.Value
If Menu.optionBtnDepartmentOne = True Then
foundItem = departments.Worksheets("Department One").Range("D2:D10000").Find(searchItem).Offset(0, 1).Value
ElseIf Menu.optionBtnDepartmentTwo = True Then
foundItem = departments.Worksheets("Department Two").Range("D2:D10000").Find(searchItem).Offset(0, 1).Value
ElseIf Menu.optionBtnDepartmentThree = True Then
foundItem = departments.Worksheets("Department Three").Range("D2:D10000").Find(searchItem).Offset(0, 1).Value
End If
UserForm1.Label = foundItem
Workbooks("Department References").Close SaveChanges:=False
Have you thougth of writing it as a function? And if the function returns "something" then there is the message you wanted. So it would look like this:
Sub fill_UF()
Dim searchItem as string
SearchItem = UserForm1.Textbox1.Value
If foundItem(searchItem)= "Did not Find item" then
Msgbox foundItem(searchItem)
goto ending
End if
UserForm1.Label = foundItem(searchItem)
ending:
End sub
'
Function foundItem(searchItem as string)
Dim departments As Workbook
'Dim searchItem As String
'Dim foundItem As String
Set departments = Workbooks.Open("C:\Users\MyPc\Desktop\Department References.xls")
'searchItem = Cstr(searchItem) ' sometimes you need to add this
If Menu.optionBtnDepartmentOne = True Then
foundItem = departments.Worksheets("Department One").Range("D2:D10000").Find(searchItem).Offset(0, 1).Value
Goto ending
ElseIf Menu.optionBtnDepartmentTwo = True Then
foundItem = departments.Worksheets("Department Two").Range("D2:D10000").Find(searchItem).Offset(0, 1).Value
Goto ending
ElseIf Menu.optionBtnDepartmentThree = True Then
foundItem = departments.Worksheets("Department Three").Range("D2:D10000").Find(searchItem).Offset(0, 1).Value
Goto ending
End If
foundItem = "Did not Find item"
ending:
Workbooks("Department References").Close SaveChanges:=False
End function
Try this.
It might need some editing to work, but the idea is there.
I have script to scan a folder for files with a file name containing a certain text. The script works but it stops after sometime without finishing the scan of the complete folder (I reached 16663 scans, is there a limit?). I can't figure out why the script stops. Any help is greatly appreciated.
I initially used the code posted in this post Get list of sub-directories in VBA
Update: The drive I'm scanning is a network drive. My assumption now is that due to a hick-up in the connection the script stops. At the moment I'm trying different approaches to work around this...
Sub LoopThroughFilePaths()
Application.StatusBar = True
Application.ScreenUpdating = False
Counter = 1
Dim strPath As String
strPath = "V:\50" ' folder to scan
Dim myArr
myArr = GetSubFolders(strPath)
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Used Function GetSubFolders
Function GetSubFolders(RootPath As String)
Application.ScreenUpdating = False
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Dim output As String
Dim StrFileOut As String
VAR_01_output = "D:\output" 'Location to copy found files to
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
Dim StrFile As String
StrFile = Dir(fld + "\*labsuite*") 'wild card search for files
Do While Len(StrFile) > 0
StrFileOut = Format(Now(), "hh-mm-ss") & "_" & StrFile ' rename files
FileCopy fld + "\" + StrFile, VAR_01_output + "\" + StrFileOut 'copy found files to output folder
StrFile = Dir
Loop
For Each sf In fld.SubFolders
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
Counter = Counter + 1
On Error Resume Next
myArr = GetSubFolders(sf.Path)
On Error Resume Next
'ActiveWorkbook.Sheets(1).Cells(1, 1).Value = Counter
Application.StatusBar = sf.Path
DoEvents
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
I have a working VBA script that pulls specific form fields from a specified PDF file into a spreadsheet. However I have several hundred PDFs that I need to do this for, so I'd like to loop through files in a directory and perform the same action.
Conveniently I have an old VBA script that loops through Word files in a directory and imports the content of each just how I'd like.
I hardly know VBA but I've adapted scripts in several language including VBA to meet my needs. I thought this would take 10 minutes but its taken several hours. Can somebody please look at my script below and tell me where I'm going wrong? I assume it has something to do with the Word and Acrobat libraries having different requirements, but even my loop isn't displaying the test message.
PS I have Acrobat Pro installed.
My Script (Non-Working)
Private Sub CommandButton1_Click()
Dim f As String: f = "C:\temp\ocopy"
Dim s As String: s = Dir(f & "*.pdf")
Dim AcroApp As Acrobat.CAcroApp
Dim theForm As Acrobat.CAcroPDDoc
Dim jso As Object
Dim text1, text2 As String
Dim col As Integer: col = 1
Do Until s = ""
Set AcroApp = CreateObject("AcroExch.App")
Set theForm = CreateObject("AcroExch.PDDoc")
theForm.Open (f & s)
Set jso = theForm.GetJSObject
text1 = jso.getField("Name of serviceRow1").Value
text2 = jso.getField("Who are the key contacts?").Value
MsgBox text1
MsgBox "text1"
Sheet1.Cells(col, 1).Value = text1
Sheet1.Cells(col, 2).Value = text2
col = col + 1: s = Dir
theForm.Close
AcroApp.Exit
Set AcroApp = Nothing
Set theForm = Nothing
Loop
End Sub
Word Script - Works at Looping and Importing
Sub fromWordDocsToMultiCols()
Dim f As String: f = "C:\temp\Test\"
Dim s As String: s = Dir(f & "*.docx")
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim col As Integer: col = 1
On Error GoTo errHandler
Do Until s = ""
Set wdDoc = wdApp.Documents.Open(f & s)
wdDoc.Range.Copy
Sheet1.Cells(1, col).Value = s
Sheet1.Cells(2, col).PasteSpecial xlPasteValues
wdDoc.Close False: col = col + 1: s = Dir
Loop
errHandler:
If Err.Number <> 0 Then MsgBox Err.Description
If Not wdApp Is Nothing Then wdApp.Quit False
End Sub
Acrobat Script - Works as Importing One-by-One
Private Sub CommandButton1_Click()
Dim AcroApp As Acrobat.CAcroApp
Dim theForm As Acrobat.CAcroPDDoc
Dim jso As Object
Dim text1, text2 As String
Set AcroApp = CreateObject("AcroExch.App")
Set theForm = CreateObject("AcroExch.PDDoc")
theForm.Open ("C:\temp\ocopy\Minerals asset management.pdf")
Set jso = theForm.GetJSObject
' get the information from the form fiels Text1 and Text2
text1 = jso.getField("Name of serviceRow1").Value
text2 = jso.getField("Who are the key contacts within the team for this service? Please provide one contact per region").Value
Sheet1.Cells(1, 1).Value = text1
Sheet1.Cells(1, 2).Value = text2
theForm.Close
AcroApp.Exit
Set AcroApp = Nothing
Set theForm = Nothing
End Sub
Many thanks in advance.
I need to create a macro that opens an Excel file, and saves some files inside the Workbook. The problem is that when I want to run macro more than once in a short time (which unfortunately I need to do), I receive error '462': The remote server machine does not exist or is unavialiable.
I've read about this and tried to fix it: I've created a special module at the beginning to kill Excel process:
Call KillExcel
Function KillExcel()
Dim oServ As Object
Dim cProc As Variant
Dim oProc As Object
Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
For Each oProc In cProc
'Rename EXCEL.EXE in the line below with the process that you need to Terminate.
'NOTE: It is 'case sensitive
If oProc.Name = "EXCEL.EXE" Or oProc.Name = "EXCEL.EXE *32" Then
' MsgBox "KILL" ' used to display a message for testing pur
errReturnCode = oProc.Terminate()
End If
Next
End Function
But unfortunately even if I close this processes I still receive this error. The part of code where I use Excel looks like this:
Dim ark As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set ark = Excel.Workbooks.Open(FileName:=scexcel)
Set xlSheet = ark.Worksheets("Sheet1")
a = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + 1
Cells(a, 2).Value = "ABC"
Cells(a, 3).Value = "DEF"
Cells(a, 4).Value = "GHI"
Cells(a, 5).Value = "JKL"
a = a + 1
Set xlSheet = Nothing
ark.Close SaveChanges:=True
Set ark = Nothing
If it helps, the macro fails every time I run it multiple times in a short time period at line:
Set ark = Excel.Workbooks.Open(FileName:=scexcel)
Note that scexcel is the path of Excel file.
Can you please help me with this problem?
This should work for you (make sure you kill any hidden Excel.exe instances left over from your previous code first):
Dim ark As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim a As Long
Set ark = GetObject(scexcel)
ark.Application.Visible = True
Set xlSheet = ark.Worksheets("Sheet1")
With xlSheet
a = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Cells(a, 2).Value = "ABC"
.Cells(a, 3).Value = "DEF"
.Cells(a, 4).Value = "GHI"
.Cells(a, 5).Value = "JKL"
End With
Set xlSheet = Nothing
ark.Close SaveChanges:=True
Set ark = Nothing