So, before I place my code, I'll explain what I am trying to do, because I can't test the script myself due to what it is supposed to do, effecting what it must do. I know this is a bit odd, but bear with me please.
Once every two weeks or so, we currently run batch files to update a specific tool on all the WS's in our organization.
Yes, we do have tool propagation software, but as this specific tool is extremely important, we don't trust it's distribution to any automated method which have proven in most cases to fail without us being able to understand the reason.
So, I wrote a few simple command batch files which run the installation command, and write the output to a text file which we then manually go through to find which ws's it was installed on, and which it wasn't.
The ws's on which it was not installed are the ws's we know we know due to the failure, that we have additional issues with and we then put all our effort into finding and fixing those issues.
As you can imagine, it's a time consuming effort, and I have decided I want to automate as much as possible of the manual check, in order to know quickly which ws's failed, and the fail code.
I start out with a list of ws names in excel.
For example,
K190ASSn1.domainname
m930eastgate.domainname
n190alka.domainname
n190amsv.domainname
n190amzi.domainname
N190ARME.domainname
N190AVMA.domainname
N190AVNT.domainname
n190chockstest.domainname
N190DLCR.domainname
N190DNBS.domainname
N190edsh.domainname
n190ehma2.domainname
N190EISH.domainname
I wrote my script to do the following:
Read all the ws names from column A into an array.
Loop through the array, and use the Shell function to call an external cmd file which then runs, and writes the result of the run into a TXT file located in a directory on the D drive called "Minstall".
I then read the names of all the files created in that directory into a new array.
I sort both arrays from A to Z (using a script I found online) to get everything in the same order for the next stage.
I then loop through the file names in the 2nd array, and read each file into a text field which I then parse to find the result of the script run.
That result is then written into a third array in the same logical position of the file name I read.
Finally, I re-write the file names back to the worksheet, overwriting what was there, and in the adjacent column, I write the run result from the relevant cell position in the third array.
I will then end up with a file that contains all the data in one visible point (I hope).
At a later stage, I will add a script that will email the relevant team with a list of the ws's they need to deal with (Those with any run result different from zero), and what they need to do. But that's not for the here and now.
Since if I run the code and it works (I hope) it would perform the update, and I do not yet want to do that, what I am really looking for, is additional eyes to go over my code, to see if what I wrote for each action as defined above is correct and will work, and if there is a way to perhaps write what I did, better.
In general, I went over each stage and everything "looks" good.
Anyone willing to assist here ?
Added by request of #CDP1802:
Examples of the two different results that can be found in the text files. One contains a result of zero, meaning that the script worked. The other contains a code of 1603, which is a generic "there's a problem captain but I don't know what it is" response from M$ msiexec.
The spaces between the lines of the text are what appear in the actual text file.
Example 1 (0 response)
PsExec v2.33 - Execute processes remotely
Copyright (C) 2001-2021 Mark Russinovich
Sysinternals - www.sysinternals.com
C:\Windows\system32>msiexec /i "\\server\Minstall\Installation.msi" /qn ACCEPTEULA=YES REPORTSERVER=server.domainname USESSL=TRUE REPORTSERVERPORT=443 IGNORESSLERRORS=TRUE InstallCertificates=yes /l*v C:\Windows\TEMP\install_log4258289.txt
Connecting to K190LPRTLV4.iaadom...
Starting PSEXESVC service on K190LPRTLV4.iaadom...
Copying authentication key to K190LPRTLV4.iaadom...
Connecting with PsExec service on K190LPRTLV4.iaadom...
Copying d:\Install425.bat to K190LPRTLV4.iaadom...
Starting d:\Install425.bat on K190LPRTLV4.iaadom...
Install425.bat exited on K190LPRTLV4.iaadom with error code 0.
Example 2 (1603 response)
PsExec v2.33 - Execute processes remotely
Copyright (C) 2001-2021 Mark Russinovich
Sysinternals - www.sysinternals.com
C:\Windows\system32>msiexec /i "\\server\Minstall\Installation.msi" /qn ACCEPTEULA=YES REPORTSERVER=server.domainname USESSL=TRUE REPORTSERVERPORT=443 IGNORESSLERRORS=TRUE InstallCertificates=yes /l*v C:\Windows\TEMP\install_log4258289.txt
Connecting to K190LPRTLV3.iaadom...
Starting PSEXESVC service on K190LPRTLV3.iaadom...
Copying authentication key to K190LPRTLV3.iaadom...
Connecting with PsExec service on K190LPRTLV3.iaadom...
Copying d:\Install425.bat to K190LPRTLV3.iaadom...
Starting d:\Install425.bat on K190LPRTLV3.iaadom...
Install425.bat exited on K190LPRTLV3.iaadom with error code 1603.
The updated code is as follows:
Option Explicit
Sub Check_Files()
Const Col_Names = "A"
Const Col_Result = "B"
Const Row_Text = 4 'first line of text and result
Dim wb As Workbook
Dim wsMain As Worksheet
Dim WSNames() As String 'Will hold all the ws names as an array read from column A
Dim WSResult() 'Will hold result for specific ws
Dim DirectoryListArray() As string
ReDim DirectoryListArray(3000) 'Set the directory listing array size to 3000 as a max count
Dim NumberArray() As Long
Dim lastrow As Long, FileCount As Long, NumberCount As Long, r As Long, i As Long, j As Long
Dim awsname as string, strDir As string, strPath As string
Dim item as variant
Dim ReadFile As String, text As String, textline As String, RetCode As Integer
Set wb = ActiveWorkbook
With wb
Set wsMain = .Sheets("Main")
End With
'Copy ws names into array for speed
With wsMain
lastrow = .Cells(.Rows.Count, Col_Names).End(xlUp).Row
If lastrow < Row_Text Then
MsgBox "No ws names found in column " & Col_Names, vbCritical
Exit Sub
End If
WSNames = .Cells(1, Col_Names).Resize(lastrow).Value2
ReDim WSResult(1 To lastrow)
End With
'Write how many names were read into array
Cells(1,3) = "Number of names read into array is " & lastrow
'loop through all ws names and run the batch file for each one
For r = Row_Text To UBound(WSNames)
awsname = WSNames(r, 1) 'Read in next ws name from array
Runcmd(awsname)
Next r
'Write how many batch files were run into worksheet
Cells(2,3) = "Number of batch files run is " & r
'count how many text files have been created
strDir = "D:\Minstall"
strPath = strDir & "\*.txt"
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$(strPath)
Do While MyFile <> ""
DirectoryListArray(FileCount) = MyFile
MyFile = Dir$
FileCount = FileCount + 1
Loop
'Reset the size of the array without losing its values by using Redim Preserve
Redim Preserve DirectoryListArray(FileCount - 1)
'Write how many text files were found
Cells(3,3) = "Number of txt files found is " & FileCount
''Debug.Print writes the results to the Immediate window (press Ctrl + G to view it)
'For FileCount = 0 To UBound(DirectoryListArray)
'Debug.Print DirectoryListArray(FileCount)
'Next FileCount
'Sort the arrays so that we have the same order in both arrays
'Since both arrays should in effect have the same amount of elements
'sorting names array from A to Z
For i = LBound(WSNames) To UBound(WSNames)
For j = i + 1 To UBound(WSNames)
If UCase(WSNames(i,1)) > UCase(WSNames(j,1)) Then
Temp = WSNames(j,1)
WSNames(j,1) = WSNames(i,1)
WSNames(i,1) = Temp
End If
Next j
Next i
'sorting file array from A to Z
For i = LBound(DirectoryListArray) To UBound(DirectoryListArray)
For j = i + 1 To UBound(DirectoryListArray)
If UCase(DirectoryListArray(i,1)) > UCase(DirectoryListArray(j,1)) Then
Temp = DirectoryListArray(j,1)
DirectoryListArray(j,1) = DirectoryListArray(i,1)
DirectoryListArray(i,1) = Temp
End If
Next j
Next i
NumberCount = 0
'Loop through files in directory based on what's in array
For i = LBound(DirectoryListArray) To UBound(DirectoryListArray)
ReadFile = "D:\Minstall" & "\" & DirectoryListArray(NumberCount)
ReadFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
RetCode = InStr(text, "with error code ")
NumFound = Mid(text, posLat + 16, 1)
If NumFound > 0 Then
NumFound = Mid(text, posLat + 16, 4)
'Write the number found into the number array
NumberArray(NumberCount) = NumFound
NumberCount = NumberCount + 1
Else
'Write the number found into the number array
NumberArray(NumberCount) = NumFound
NumberCount = NumberCount + 1
End If
Next i
'Write the ws name into the worksheet and write the number found to the cell to the right of the ws name in the worksheet
For i = LBound(WSNames) To UBound(WSNames)
Cells(j, Col_Names) = WSNames(i,1)
Cells(j, Col_Result) = NumberCount(i,1)
j = j + 1
Next i
End Sub
Sub Runcmd(awsname)
Dim PathToBatch as string
'Set the path and batch file with the ws name as a parameter for the batch to run
PathToBatch = "D:\min425.cmd" & " " & awsname
Call Shell(PathToBatch, vbNormalFocus)
End Sub
The main changes are using a FileSystemObject to read the text files, a Regular Expression to extract the error code, and a WScript.Shell object to run the batch file so macro waits for the script to complete. I have commented out the RunCmd line and replaced it with a RunTest that creates a text file so you can test it.
Option Explicit
Sub Check_Files()
Const DIR_OUT = "D:\Minstall"
Const COL_NAMES = "A"
Const COL_RESULTS = "B"
Const COL_TS = "C" ' timestamp
Const COL_ERR = "D" ' Shell errors
Const ROW_START = 4 'first line of text and result
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, arNames, awsname As String
Dim result As String, txtfile As String
Dim i As Long, LastRow As Long, n As Long, r As Long, colour As Long
Dim t0 As Single: t0 = Timer
Set wb = ThisWorkbook
Set ws = wb.Sheets("Main")
With ws
' read names into array
LastRow = .Cells(.Rows.Count, COL_NAMES).End(xlUp).Row
n = LastRow - ROW_START + 1
If n < 1 Then
MsgBox "No records found on " & ws.Name, vbCritical
Exit Sub
Else
Set rng = .Cells(ROW_START, COL_NAMES).Resize(n)
arNames = rng.Value2
'Write how many names were read into array
.Cells(1, 3) = "Number of names read into array is " & n
End If
' clear results
With rng.Offset(, 1).Resize(, 3)
.Clear
.Interior.Pattern = xlNone
End With
' run commands with WsSCript
Dim WShell As Object
Set WShell = CreateObject("WScript.Shell")
For i = 1 To UBound(arNames)
awsname = arNames(i, 1)
r = ROW_START + i - 1
' RUN COMMANDS
.Cells(r, COL_ERR) = RunTest(awsname, DIR_OUT)
'.Cells(r, COL_ERR) = RunCmd(WShell, awsname, DIR_OUT)
.Cells(r, COL_TS) = Format(Now, "yyyy-mm-dd HH:MM:SS") ' timestamp
Next
Set WShell = Nothing
'Write how many batch files were run into worksheet
.Cells(2, 3) = "Number of batch files run is " & UBound(arNames)
' read text files with FSO, parse with regex
Dim FSO As Object, ts As Object, regex As Object, txt As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = False
.MultiLine = True
.IgnoreCase = True
.Pattern = "with error code (\d+)"
End With
n = 0
' process text file
For i = 1 To UBound(arNames)
r = ROW_START + i - 1
awsname = arNames(i, 1)
txtfile = DIR_OUT & awsname & ".txt"
result = ""
' does file exist for this machine
If FSO.fileExists(txtfile) Then
' read file
n = n + 1
Set ts = FSO.openTextfile(txtfile)
txt = ts.readall
ts.Close
' extract error number from text
If regex.test(txt) Then
result = regex.Execute(txt)(0).submatches(0)
End If
' error codes
If result = "0" Then
colour = RGB(0, 255, 0) ' green
Else
colour = RGB(255, 255, 0) ' yellow
End If
Else
result = "No Text File"
colour = RGB(255, 0, 0) ' red
End If
' result
With .Cells(r, COL_RESULTS)
.Value2 = result
.Interior.Color = colour
End With
Next
.Cells(3, 3) = "Number of txt files found is " & n
.Columns.AutoFit
End With
MsgBox "Text files found for " & n, vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Function RunTest(awsname As String, folder As String) As String
Dim FSO, ts, errno: Set FSO = CreateObject("Scripting.FileSystemObject")
If Rnd() < 0.3 Then errno = 0 Else errno = Int(10000 * Rnd())
Set ts = FSO.createTextFile(folder & awsname & ".txt")
ts.write "This is with error code " & errno & "." & vbCrLf & vbCrLf
ts.Close
RunTest = "Test"
End Function
Function RunCmd(WShell, awsname As String, folder As String) As String
MsgBox "RunCmd DISABLED", vbCritical: End
'Const SCRIPT = "D:\min425.cmd"
'Dim cmd: cmd = SCRIPT & " " & awsname
'RunCmd = WShell.Run(cmd, vbNormal, True) ' waittocomplete
End Function
I wrote below script but get hung up on this part of the code:
If TargetWb.Sheets("Expenses").Range("F61").Offset(0, i - 1).Value = CVErr(xlErrNA) Then GoTo Skip Else GoTo Continue
What I'm trying to do: if the value of the cell returns #N/A as part of a function I would like to move to next loop. Any recommendation on how to accomplish this?
Thanks in advance for solutions. Also always open to recommendations on how to better structure this code, as I'm still a beginner.
Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Dim S_Deal As Range
Dim i As Integer
'SourceWb - Workbook were data is copied from
'TargetWb - Workbook were data is copied to and links are stored
Application.ScreenUpdating = False
Set TargetWb = ThisWorkbook
filePath = ThisWorkbook.Sheets("Expenses").Range("S4").Value
Set SourceWb = Workbooks.Open(filePath)
For i = 1 To 6
If TargetWb.Sheets("Expenses").Range("F61").Offset(0, i - 1).Value = CVErr(xlErrNA) Then GoTo Skip Else GoTo Continue
Continue:
Set S_Deal = TargetWb.Sheets("Expenses").Cells(11, 5 + i)
SourceWb.ActiveSheet.Range("OPEX_Control").Value = S_Deal.Value
TargetWb.Sheets("Expenses").Range("F12:F15").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("P9:P12").Value
TargetWb.Sheets("Expenses").Range("F18:F21").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("o14:o17").Value
TargetWb.Sheets("Expenses").Range("F23:F26").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("o19:o22").Value
TargetWb.Sheets("Expenses").Range("F29").Offset(0, i - 1).Value = SourceWb.ActiveSheet.Range("o25").Value
Skip:
Next i
Application.ScreenUpdating = True
End Sub
If you want to check whether the excel function return #N/A in vba, you can use the following code:
If Application.WorksheetFunction.IsNA(Cells(intRow, x)) Then
Since what you want is the execute a code unless the the wb.function is not #N/A, by re-arrange your If VBA code should be able to achieve your desired outcome.
If Application.WorksheetFunction.IsNA(TargetWb.Sheets("Expenses").Range("F61")) = false then
{your code}
end if
next i
So when the wb function return #N/A, it will not execute the code in between and go to next loop
I am attempting to work on a code which will allow me to check two lines of all my text files in a folder.
Each text file will be structured like so:
NS1234 <--- A random reference number on the first line
Approve < Reject or Approve on the second line
At the moment the code only reads one text file which I specify the name of, however I want it to scan all .txt files.
Next, When I open my spread sheet I will have the following set-up:
Column A Column
NS1234
I want my code to scan all text files to check for any matching reference number from column A against all the text files.
And then where a match is found insert either 'Approve' or 'Reject', where this is written on the second line of the text file, into the corresponding row in column s
Code:
Public Sub test()
Dim fn As Integer
fn = FreeFile
Open "Z:\NS\Approval\NS32D1QR.txt" For Input As fn
Dim wholeFile As String
wholeFile = Input(LOF(fn), #fn)
Close #fn
Dim splitArray
splitArray = Split(wholeFile, vbCrLf)
Dim lineNum As Integer
lineNum = 2
Dim i As Integer, intValueToFind As Integer
intValueToFind = NS32D1QR
For i = 1 To 500 ' Revise the 500 to include all of your values
If Cells(i, 1).Value = intValueToFind And splitArray(lineNum - 1) = "Approve" Then
Range("S" & ActiveCell.Row).Value = "Approve"
End If
Next i
End Sub
i 'm not sure about the test that you made in your loop but it seems to me that the info where on the 2 first lines so no use to loop or to use special variables there. Let me know if this work properly or not! ;)
Here is a sub to test, as it is a function you can either loop on it or use it in Excel workbook.
Sub test()
With Sheets("Sheet1")
For i = 2 To .Rows(.Rows.Count).End(xlUp).Row
.Cells(i, "S") = Get_AorP(.Cells(i, "A"))
Next i
End With
End Sub
Here is what you wanted to do, converted to a function :
Public Function Get_AorP(ByVal Value_to_Find As String) As String
Dim fn As Integer, _
Txts_Folder_Path As String, _
File_Name As String, _
wholeFile As String, _
splitArray() As String, _
i As Integer
On Error GoTo ErrHandler
Txts_Folder_Path = "Z:\NS\Approval\"
File_Name = Dir(Txts_Folder_Path & "*.txt")
While File_Name <> vbNullString
fn = FreeFile
Open Txts_Folder_Path & File_Name For Input As fn
wholeFile = Input(LOF(fn), #fn)
Close #fn
MsgBox File_Name
splitArray = Split(wholeFile, vbCrLf)
If UBound(splitArray) < 2 Or LBound(splitArray) > 1 Then
'avoid empty text files
Else
If InStr(1, splitArray(0), Value_to_Find) <> 0 Then
If InStr(1, splitArray(1), "Approve") Then
Get_AorP = "Approve"
Exit Function
Else
If InStr(1, splitArray(1), "Reject") Then
Get_AorP = "Reject"
Exit Function
Else
'Nothing to do
End If
End If
Else
'not the good value
End If
End If
File_Name = Dir()
Wend
Get_AorP = "No matches found"
Exit Function
ErrHandler:
Get_AorP = "Error during the import." & vbCrLf & Err.Number & " : " & Err.Description
End Function
Can anyone tell me how to improve this macro?
All the macro does is it just reads an Excel file for a list a accounts to update in an application (SmarTerm Beta). It technically already accomplishes the goal, but is there a way to code it so that while it’s reading the Excel file, the coordinates of the cells from which to read the account numbers and also the coordinates of the cells in which to write an output don’t depend on a "pre-selected" a cell? The risk with selecting a cell is that if someone were to accidentally select a different cell while the macro is running, everything will get screwed up.
Here's my current code:
Public oExcelObj As Object
Function WaitSystem(Optional NoDialog as Variant) As Boolean
Dim nContinue as Integer
Dim nTimeOut as Integer 'In seconds.
'The default timeout for each command is 3 minutes.
'Increase this value if your host requires more time
'for each command.
nTimeOut = 10
If IsMissing(NoDialog) then NoDialog = False
'Wait for response from host.
Session.EventWait.Timeout = nTimeOut
Session.EventWait.EventType = smlPAGERECEIVED
Session.EventWait.MaxEventCount = 1
WaitSystem = True
If Session.EventWait.Start = smlWAITTIMEOUT Then
If NoDialog Then
WaitSystem = False
Else
nContinue = QuerySyncError()
If nContinue <> ebYes then WaitSystem = False
End If
End If
Set LockStep = Nothing
End Function
'Establish link. Search for Excel.
Function OleLinkConnection
Const XlMaximized = &HFFFFEFD7
Titlebar$ = AppFind$("Microsoft Excel")
If Titlebar$ <> "" Then
bIsExcelActive = True
If AppGetState(Titlebar$) = ebMinimized Then
AppSetState 2, Titlebar$
End If
Else
bIsExcelActive = False
End If
If bIsExcelActive Then
'Create Excel Object using current instance of Excel.
Set oExcelObj = GetObject(, "Excel.Application")
Else
'Create Excel Object using a new instance of Excel.
Set oExcelObj = CreateObject("Excel.Application")
End If
Version = oExcelObj.Application.Version
oExcelObj.ScreenUpdating = True
oExcelObj.Displayalerts = True
oExcelObj.Visible = true
End Function
Sub JPBmacro
Dim AccountNumber As String
Dim Temp As Integer
Begin Dialog StartDialogTemplate ,,211,74,"Run JPBmacro?"
OKButton 60,12,92,20,.Proceed
CancelButton 60,40,92,20,.Exit
End Dialog
Dim StartDialog As StartDialogTemplate
r% = Dialog(StartDialog)
If r% = 0 Then End
g$ = "G:\DATA\outputfile.xlsx"
oleCode = OleLinkConnection
oExcelObj.Workbooks.Open g$
oExcelObj.Range("A1").Select ‘<----This selects the cell from which all coordinates are based off of. The coordinates of oExcelObj.ActiveCell.Offset(Y,X).Value VBA depend on selecting a cell.
NEXTACCOUNT:
Temp = 0
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
While AccountNumber <> ""
Session.SendKey "CLEAR"
If WaitSystem = False Then End
Session.Send "ACTU " & AccountNumber
Session.SendKey "ENTER"
If WaitSystem = False Then End
If Trim(Session.ScreenText(4,6,1,22)) = "INVALID ACCOUNT NUMBER" Or Trim(Session.ScreenText(4,6,1,19)) = "ACCOUNT NOT ON FILE" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(4,6,1,22))
GoTo RESTARTLOOP
End If
UPDATEIOV:
If Trim(Session.ScreenText(13,76,1,1)) = "Y" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = "Account already flagged as institutional."
Else
Session.Row = 13
Session.Column = 76
Session.send "Y"
Session.SendKey "ENTER"
If WaitSystem = False Then End
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(24,2,1,50))
End If
RESTARTLOOP:
Temp = Temp + 1
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
Wend
ENDNOW:
oExcelObj.Workbooks.Close
MsgBox "All Done!"
End Sub
Why not keep the reference to the first cell?
Dim rng as Range
Set rng = oExcelObj.Range("A1")
i=1
...
x = rng.Cell(i,1).Value
'Or faster yet is reading all the values into an variant array.
Dim array() as Variant
array = rng.Resize(N,M).Value
' Work with array as
x = array(i,1)
Given the comment from assylias and that another poster has since "answered" with this approach:
I can't see where oExcelObj is instantiated? Or how you are referring to a specific sheet.
Regardless of which,
you can avoid select by setting a range, ie Set rng1 = oExcelObj.Sheets(1).Range("A1")
and then use offsets from rng1.
The user won't be able to interfere while the code is running
I am wanting to try something and I'm fairly sure it's possible, but not really sure!!
In MS Excel (2003) can I write a VBA script which will open a location (eg: s://public/marketing/documents/) and list all the documents located within there (filename)?
The ultimate goal would be to have the document name, date last modified, date created and modified by name.
Is this possible? I'd like to return any found values in rows on a sheet. eg: type: FOLDER, type: Word Doc etc.
Thanks for any info!
Done that recently. Use the DSOFile object. In Excel-VBA you first need to create a reference to Dsofile.dll ("DSO OLE Document Properties Reader 2.1" or similar). Also check you have a reference to the Office library
First you may want to select the file path which you want to examine
Sub MainGetProps()
Dim MyPath As String
MyPath = GetDirectoryDialog()
If MyPath = "" Then Exit Sub
GetFileProps MyPath, "*.*"
End Sub
Let's have a nice Path selection window
Function GetDirectoryDialog() As String
Dim MyFD As FileDialog
Set MyFD = Application.FileDialog(msoFileDialogFolderPicker)
With MyFD
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
GetDirectoryDialog = .SelectedItems(1)
End If
End With
End Function
Now let's use the DSO object to read out info ... I reduced the code to the bare necessary
Private Sub GetFileProps(MyPath As String, Arg As String)
Dim Idx As Integer, Jdx As Integer, MyFSO As FileSearch, MyRange As Range, MyRow As Integer
Dim DSOProp As DSOFile.OleDocumentProperties
Set DSOProp = New DSOFile.OleDocumentProperties
Set MyRange = ActiveSheet.[A2] ' your output is nailed here and overwrites anything
Set MyFSO = Application.FileSearch
With MyFSO
.NewSearch
.LookIn = MyPath
.SearchSubFolders = True ' or false as you like
.Filename = Arg
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
MsgBox .FoundFiles.Count & " file(s) found." ' to see what you will get
For Idx = 1 To .FoundFiles.Count
DSOProp.Open .FoundFiles(Idx) ' examine the DSOProp element in debugger to find all summary property names; not all may be filled though
Debug.Print .FoundFiles(Idx)
Debug.Print "Title: "; DSOProp.SummaryProperties.Title
Debug.Print "Subject: "; DSOProp.SummaryProperties.Subject
' etc. etc. write it into MyRange(Idx,...) whatever
' now hunt down the custom properties
For Jdx = 0 To DSOProp.CustomProperties.Count - 1
Debug.Print "Custom #"; Jdx; " ";
Debug.Print " Name="; DSOProp.CustomProperties(Jdx).Name;
If DSOProp.CustomProperties(Jdx).Type <> dsoPropertyTypeUnknown Then
Debug.Print " Value="; DSOProp.CustomProperties(Jdx).Value
Else
Debug.Print " Type=unknowwn; don't know how to print";
End If
MyRow = MyRow + 1
Next Jdx
DSOProp.Close
Next Idx
Else
MsgBox "There were no files found."
End If
End With
End Sub
and that should be it
good luck MikeD