Read item titles from SharePoint Document Library into Array using Excel VBA - vba

I need to read all the item titles for all the documents in a SharePoint document library directly into an Array using Excel VBA. I can't seem to successfully use FileSystemObject and I do not want to map the document library to a drive letter as the macro will be distributed and widely used.
The SharePoint site has an https address
I have looked at this thread about referencing scrrun.dll but it does not work because I cannot change the trust settings on my local domain
This thread looked promising, but again it seems to use FileSystemObject which might be my hang up.
This thread on the SharePoint stackexchange site works well for reading in a list of files as a worksheet object, but I don't know how it could be adapted to be pushed directly into an array.
I tend to receive Error 76 "Bad Path", but I am easily able to execute on local (C:) files.
I have tried using a WebDAV address - like the answer I gave to this thread - but it too encounters a "Bad Path" error.
There must be a way to read in the contents of a SharePoint document library directly into an array that does not violate my local security policies and doesn't depend upon an excel worksheet.

Ok I am going to self answer. I'm not 100% thrilled with my solution, but it does suffice within my constraints. Here are the high level points:
Use VBA to create BAT files that have the "Net Use" command within them.
Reference the WebDAV address of the document library and find an available drive letter
I doubt that any of my users already have 26 mapped drives...).
Once the document library is mapped it can be iterated through using FileSystemObject commands and the item titles can be loaded into a two dimensional array.
The code will have to be modified to allow for 3 the listing of subfolders
The location of the file count in the ListMyFiles sub would have to be changed or another dimension would have to be added to the array.
Here is the code - I will try to credit all Stack solutions that were integrated into this answer:
Private Sub List_Files()
Const MY_FILENAME = "C:\BAT.BAT"
Const MY_FILENAME2 = "C:\DELETE.BAT"
Dim i As Integer
Dim FileNumber As Integer
Dim FileNumber2 As Integer
Dim retVal As Variant
Dim DriveLetter As String
Dim TitleArray()
FileNumber = FreeFile
'create batch file
For i = Asc("Z") To Asc("A") Step -1
DriveLetter = Chr(i)
If Not oFSO.DriveExists(DriveLetter) Then
Open MY_FILENAME For Output As #FileNumber
'Use CHR(34) to add escape quotes to the command prompt line
Print #FileNumber, "net use " & DriveLetter & ": " & Chr(34) & "\\sharepoint.site.com#SSL\DavWWWRoot\cybertron\HR\test\the_lab\Shared Documents" & Chr(34) & " > H:\Log.txt"
Close #FileNumber
Exit For
End If
Next i
'run batch file
retVal = Shell(MY_FILENAME, vbNormalFocus)
' NOTE THE BATCH FILE WILL RUN, BUT THE CODE WILL CONTINUE TO RUN.
'This area can be used to evaluate return values from the bat file
If retVal = 0 Then
MsgBox "An Error Occured"
Close #FileNumber
End
End If
'This calls a function that will return the array of item titles and other metadata
ListMyFiles DriveLetter & ":\", False, TitleArray()
'Create code here to work with the data contained in TitleArray()
'Now remove the network drive and delete the bat files
FileNumber2 = FreeFile
Open MY_FILENAME2 For Output As #FileNumber2
Print #FileNumber2, "net use " & DriveLetter & ": /delete > H:\Log2.txt"
Close #FileNumber2
retVal = Shell(MY_FILENAME2, vbNormalFocus)
'Delete batch file
Kill MY_FILENAME
Kill MY_FILENAME2
End Sub
Here is the function that will read through the directory and return the array of file information:
Sub ListMyFiles(mySourcePath As String, IncludeSubFolders As Boolean, TitleArray())
Dim MyObject As Object
Dim mySource As Object
Dim myFile As File
Dim mySubFolder As folder
Dim FileCount As Integer
Dim CurrentFile As Integer
'Dim TitleArray()
Dim PropertyCount As Integer
CurrentFile = 0
Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(mySourcePath)
FileCount = mySource.Files.Count
ReDim TitleArray(0 To FileCount - 1, 4)
'On Error Resume Next
For Each myFile In mySource.Files
PropertyCount = 1
TitleArray(CurrentFile, PropertyCount) = myFile.Path
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.Name
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.Size
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.DateLastModified
CurrentFile = CurrentFile + 1
Next
'The current status of this code does not support subfolders.
'An additional dimension or a different counting method would have to be used
If IncludeSubFolders = True Then
For Each mySubFolder In mySource.SubFolders
Call ListMyFiles(mySubFolder.Path, True, TitleArray())
Next
End If
End Sub
Thank you to Chris Hayes for his answer to find empty network drives; thank you to Kenneth Hobson on ozgrid for his expanded answer on listing files in a directory. The rest of the code is ancient and I dredged it out of a folder I last touched in 2010.

Related

VBA macro doesn't count/name files in a directory properly

I’ve made a simply macro to change names of files in a directory. At first it seemed correct, but then I’ve noticed something strange. For instance there is 48 files in a directory and initially the macro numbers files properly – “1”, “2”, “3” and so forth (in Immediate window the variable “i” changes from 1 to 49), but if I run the macro several times, sometimes the variable “i” changes from 1 to 148 and a first number of files starts from 100: “100”, “101”, “102” et cetera. Then I run the macro again and it counts files properly, then – again – an error mentioned above occurs … and so on. I don’t see any rule in it. Any help is greatly appreciated.
Sub nameChange()
Dim source As FileSystemObject
Dim fold As folder
Dim fObj As File
Dim path As String, newName As String, number As String, ext As String
Dim i As Long
On Error GoTo closeSub
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End With
Set source = New FileSystemObject
Set fold = source.GetFolder(path)
i = 1
newName = InputBox("New name")
For Each fObj In fold.Files
ext = Mid(fObj.Name, (InStrRev(fObj.Name, ".")))
Name fObj As path & "\" & newName & i & ext
i = i + 1
Next fObj
closeSub:
Exit Sub
End Sub

VBA - Unable to map drive to sharepoint on another computer

I'm mapping to the company's sharepoint drive using VBA. The intention is to save local file to sharepoint, and delete local file and unmapped the drive after success.
On my machine(Windows 10 64bits), the code works perfectly fine, successfully mapped the drive, created folder and file, successfully uploaded to sharepoint and unmap the drive.
However, when I run the same excel workbook that contains the same code on my colleague's computer(Window 7), it failed. There's no error being shown, except that it keeps on loading and loading until Excel Not Responsive. I tried manually mapping the drive, it success.
I tried to debug and found out that the code stops (keeps on loading) at MsgBox "Hello" but could not figure out what's missing.
Both are using Excel 2016
Any help and suggestions are appreciated. let me know if more info is needed. Thanks in advance.
This is my vba code
Sub imgClicked()
Dim fileName As String
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
Dim objFSO As Object
Dim strMappedDriveLetter As String
Dim strPath As String
Dim spPath As String
strPath = "https://company.com/sites/test/test 123/" 'example path
spPath = AvailableDriveLetter + ":\test.xlsm" 'example path
copyPath = folderPath + "\copyPath\"
'Add reference if missing
Call AddReference
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
If Not Len(strMappedDriveLetter) > 0 Then
strMappedDriveLetter = AvailableDriveLetter
If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
Exit Sub
End If
End If
' Check file/folder path If statement here
End With
Set objFSO = Nothing
End Sub
Code for getting available drive
' Returns the available drive letter starting from Z
Public Function AvailableDriveLetter() As String
' Returns the last available (unmapped) drive letter, working backwards from Z:
Dim objFSO As Object
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = Asc("Z") To Asc("A") Step -1
Select Case objFSO.DriveExists(Chr(i))
Case True
Case False
Select Case Chr(i)
Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway...
Case Else
AvailableDriveLetter = Chr(i)
Exit For
End Select
End Select
Next i
Set objFSO = Nothing
MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive
MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive
End Function
Function to Map drive
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
Dim objNetwork As Object
If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
MapDrive = True
MsgBox "Successfully Created the Drive!"
Set objNetwork = Nothing
End Function
Code for MappedDrive
Public Function GetMappedDrives() As Variant
' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine
Dim objFSO As Object
Dim objDrive As Object
Dim arrMappedDrives() As Variant
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim arrMappedDrives(1 To 2, 1 To 1)
For i = Asc("A") To Asc("Z")
If objFSO.DriveExists(Chr(i)) Then
Set objDrive = objFSO.GetDrive(Chr(i))
If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
End If
arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter...
arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
End If
Next i
GetMappedDrives = arrMappedDrives
Set objDrive = Nothing
Set objFSO = Nothing
End Function
Public Function IsAlreadyMapped(strPath As String) As String
' Tests if a given network path is already mapped on the users machine
' (Returns corresponding drive letter or ZLS if not found)
Dim strMappedDrives() As Variant
Dim i As Long
strMappedDrives = GetMappedDrives
For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
IsAlreadyMapped = strMappedDrives(1, i)
Exit For
End If
Next i
Set objNetwork = Nothing
End Function
Add Reference
Sub AddReference()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Procedure imgClicked is calling function AvailableDriveLetter multiple times. Remember that the function has to execute each time you refer to it.
I ran imgClicked (assuming that's the procedure you start with) and I was told, twice, "Next available letter = Z" and "Hello" and then it crashed Excel (perhaps getting stuck in a loop of creating FileSystem objects to look for an available drive letter?)
Try assigning AvailableDriveLetter to a variable (string) at the beginning of the procedure and referring to the variable each time you need the value, and see if you still have the issue.
(Remember to save before execution -- I get frustrated when troubleshooting "application hanging" issues because I keep forgetting to save my changes and then lose them on the crash!)
If this doesn't work, add a breakpoint (F9) on the End Function line after your "Hello" box and see if the code stops there. (I have trouble believing the MsgBox or End Function are the culprit.) If not, which procedure runs after that?
One more thing whether the issue is resolved or not:
Add Option Explicit at the very beginning of your module and then Compile the project and fix your missing variable declaration(s).
This is recommended whenever troubleshooting an issue as a means to eliminate variable declaration issues as a possible cause.

Removing compatibility mode on 1000+ word documents

I have a folder containing about 1200 word documents that are all saved in Compatibility Mode. Does anyone know of a way to convert every one of these files so that the documents are no longer in Compatibility Mode?
Open up a cmd window in your folder and type dir /s /b >> filename.txt to get a plaintext list of all the files in the path. That will give a textfile listing all files in the directory.
Use that as the input for the following
Since you're going to do it on 1000 files, I would set a break point at doc.close to test it out on the first few if I were you.
Sub SaveAsDocX(FileListFullPath As String)
'for saving to new filename
Dim newname As String
'array of docs, items in that array, document object from those items
Dim docs As Variant
Dim item As Variant
Dim doc As Document
docs = getfiles(FileListFullPath)
For Each item In docs
If Right(item, 4) = ".doc" Then
Set doc = Application.Documents.Open(FileName:=item)
doc.Activate
newname = item & " - updated.docx"
'first save as new format then update compatibility, then save again
doc.SaveAs2 FileName:=newname, FileFormat:=wdFormatDocumentDefault
ActiveDocument.SetCompatibilityMode (wdCurrent)
doc.SaveAs2 FileName:=newname, FileFormat:=wdFormatDocumentDefault
doc.Close
End If
Next
End Sub
Function getfiles(Optional FileName As String = "Dir.txt")
Dim FileList() As String
Open FileName For Input As #1
FileList = Split(Input$(LOF(1), #1), vbCrLf)
Close #1
getfiles = FileList
End Function

Excel macro to read input from files created today only

I have an application that exports daily reports in txt format.
I have a macro that extracts certain lines of data from those reports and puts them in an output xls file. my macro's input directory is curently a separate folder that i manually move today's reports into.
I'd like for my macro to be able to just read from the default report folder and only read files created with today's date.
the naming convention of the report files is as follows:
1101_16_16_AppServiceUser_YYYYMMDDhhmmssXXX.txt
not sure what the last 3 digits on the file name represents, but they're always numbers.
Help?
WOW that was fast! thanks... fist time using stackoverflow.
I guess i should include the code that pulls data and dumps it to excel... here it is:
Sub PullLinesFromEPremisReport()
Dim FileName, PathN, InputLn As String
Dim SearchFor1, SearchFor2, OutpFile As String
Dim StringLen1, StringLen2 As Integer
Dim colFiles As New Collection
Dim bridgekey As String
PathO = "C:\Documents and Settings\GROMERO\Desktop\CM reconciliation\output\"
PathN = "C:\Documents and Settings\GROMERO\Desktop\CM reconciliation\input\"
FileName = Dir(PathN)
While FileName <> ""
colFiles.Add (FileName)
FileName = Dir
Wend
SearchFor1 = "BRIDGE KEY"
StringLen1 = Len(SearchFor1)
OutpFile = "RESULTS.xls"
Open PathO & OutpFile For Output As #2
For Each Item In colFiles
Open PathN & Item For Input As #1
Do Until EOF(1) = True
Line Input #1, InputLn
If (Left(LTrim$(InputLn), StringLen1) = SearchFor1) Then
bridgekey = InputLn
End If
Loop
Close #1
Next Item
Close #2
End Sub
Daniel's answer is correct, but using the FileSystemObject requires a couple of steps:
Make sure you have a reference to "Microsoft Scripting Runtime":
Then, to iterate through the files in the directory:
Sub WorkOnTodaysReports()
'the vars you'll need
Dim fso As New FileSystemObject
Dim fldr As Folder
Dim fls As Files
Dim fl As File
Set fldr = fso.GetFolder("C:\Reports")
Set fls = fldr.Files
For Each fl In fls
'InStr returns the position of the substring, or 0 if not found
' EDIT: you can explicitly use the reliable parts of your file name
' to avoid false positives
If InStr(1, fl.Name, "AppServiceUser_" & Format(Now, "YYYYMMDD")) > 0 Then
'Do your processing
End If
Next fl
End Sub
EDIT: So I think, from the code you posted, you could send PathN to the main Reports folder like you desire, then just modify your While statement like so:
While FileName <> ""
If InStr(1, FileName, "AppServiceUser_" & Format(Now, "YYYYMMDD")) > 0 Then
colFiles.Add (FileName)
End If
FileName = Dir
Wend
Two ways you can do this off the top of my head. Assuming you are using a File via the FileSystemObject.
Do an Instr on the file.Name looking for Format(Date, "YYYYMMDD") within the string.
Or use a far simpler approach loop through the files and within your loop do this:
If File.DateCreate >= Date Then
'Do something
end if
Where File is the actual variable used to for looping through the files.
If fileName like "*AppServiceUser_" & Format(Now, "YYYYMMDD") & _
"#########.txt" Then
'good to go
End If

Using VBA to get extended file attributes

Trying to use Excel VBA to capture all the file attributes from files on disk, including extended attributes. Was able to get it to loop through the files and capture the basic attributes (that come from the file system):
File Path
File Name
File Size
Date Created
Date Last Accessed
Date Last Modified
File Type
Would also like to capture the extended properties that come from the file itself:
Author
Keywords
Comments
Last Author
Category
Subject
And other properties which are visible when right clicking on the file.
The goal is to create a detailed list of all the files on a file server.
You say loop .. so if you want to do this for a dir instead of the current document;
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, XXX)
Next
Where XXX is an attribute column index, 9 for Author for example.
To list available indexes for your reference you can replace the for loop with;
for i = 0 To 40
debug.? i, oDir.GetDetailsOf(oDir.Items, i)
Next
Quickly for a single file/attribute:
Const PROP_COMPUTER As Long = 56
With CreateObject("Shell.Application").Namespace("C:\HOSTDIRECTORY")
MsgBox .GetDetailsOf(.Items.Item("FILE.NAME"), PROP_COMPUTER)
End With
You can get this with .BuiltInDocmementProperties.
For example:
Public Sub PrintDocumentProperties()
Dim oApp As New Excel.Application
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim title As String
title = oWB.BuiltinDocumentProperties("Title")
Dim lastauthor As String
lastauthor = oWB.BuiltinDocumentProperties("Last Author")
Debug.Print title
Debug.Print lastauthor
End Sub
See this page for all the fields you can access with this: http://msdn.microsoft.com/en-us/library/bb220896.aspx
If you're trying to do this outside of the client (i.e. with Excel closed and running code from, say, a .NET program), you need to use DSOFile.dll.
'vb.net
'Extended file stributes
'visual basic .net sample
Dim sFile As Object
Dim oShell = CreateObject("Shell.Application")
Dim oDir = oShell.Namespace("c:\temp")
For i = 0 To 34
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(oDir, i) & vbCrLf
For Each sFile In oDir.Items
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(sFile, i) & vbCrLf
Next
TextBox1.Text = TextBox1.Text & vbCrLf
Next
I was finally able to get this to work for my needs.
The old voted up code does not run on windows 10 system (at least not mine). The referenced MS library link below provides current examples on how to make this work. My example uses them with late bindings.
https://learn.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof.
The attribute codes were different on my computer and like someone mentioned above most return blank values even if they are not. I used a for loop to cycle through all of them and found out that Title and Subject can still be accessed which is more then enough for my purposes.
Private Sub MySubNamek()
Dim objShell As Object 'Shell
Dim objFolder As Object 'Folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("E:\MyFolder")
If (Not objFolder Is Nothing) Then
Dim objFolderItem As Object 'FolderItem
Set objFolderItem = objFolder.ParseName("Myfilename.txt")
For i = 0 To 288
szItem = objFolder.GetDetailsOf(objFolderItem, i)
Debug.Print i & " - " & szItem
Next
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Lucky discovery
if objFolderItem is Nothing when you call
objFolder.GetDetailsOf(objFolderItem, i)
the string returned is the name of the property, rather than its (undefined) value
e.g. when i=3 it returns "Date modified"
Doing it for all 288 values of I makes it clear why most cause it to return blank for most filetypes
e.g i=175 is "Horizontal resolution"