I have the following code which I use to get date properties of some jpg files. I am trying to have it so I can extract day() month() and year() from this. It works most of the time but on occasion, there are some rogue ? in there. I have tried getproperty1 = Replace(getproperty1, "?", "") however this does not work (and wasnt really expecting it to)
intPos = InStrRev(strFile, "\")
strPath = Left(strFile, intPos)
strName = Mid(strFile, intPos + 1)
''debug.print intPos & " .. " & strPath & " .. " & strName
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strPath)
Set objFolderItem = objFolder.ParseName(strName)
If Not objFolderItem Is Nothing Then
getproperty1 = objFolder.GetDetailsOf(objFolderItem, n)
If getproperty1 = vbNullString Then
getproperty1 = objFolder.GetDetailsOf(objFolderItem, 4)
End If
I am wanting it to always be readable as a date at least, as I will be passing it all back to a duplicate file (see Rotate a saved image with vba for more of an idea as to what I do with it) using some more code I have modified from Chip Pearson's site (http://www.cpearson.com/excel/FileTimes.htm) to write it back to the file which takes the datetime as Double (so will be running Dateserial()+Timeserial() at that point. There are reasons stopping me passing datetime directly between the two as I sometimes need to make amendments in between the two bits of code)
I have used a character strip function to iterate through each individual character, eliminating anything that isnt a number, ":" or a space, then passed it through DateValue() to get it as a recognisable date format. Works like a charm now!
Function stripChars(chrStrp As String)
stripChars = ""
For cnt = 1 To Len(chrStrp)
tmpChar = Mid(chrStrp, cnt, 1)
If Val(tmpChar) <> 0 Or tmpChar = "0" Or tmpChar = "/" Or tmpChar = " " Or tmpChar = ":" Then
stripChars = stripChars & tmpChar
End If
Next cnt
Debug.Print stripChars
stripChars = DateValue(stripChars)
End Function
Related
I have code below to save the current workbook and attach today's date to the end of the file name. How would I modify the code so if two copies of the workbook were to be saved on the same day, the first one would save normally as "Workbook Name, Today's Date.xlsm" and the second one would save as "Workbook Name, Today's Date Copy 2.xlsm". Same thing if the workbook were to be saved 3,4,5 times a day they should save as Copy 3,4,5,etc...
Sub Save_Workbook()
Const Path = "H:\HR\Cole G\Timehseet Test Path\"
Dim FileName As String
Dim Pos As Long
Pos = InStrRev(ActiveWorkbook.Name, ".") - 1
' If there wasn't a ".", then the file doesn't have an extension and Pos = -1
If Dir(Path & Left(ActiveWorkbook.Name, Pos) & Format(Now, "d-mm-yyyy") & Mid(ActiveWorkbook.Name, Pos + 1)) <> "" Then
ActiveWorkbook.SaveAs FileName:=Path & Left(ActiveWorkbook.Name, Pos) & "copy 2" & Mid(ActiveWorkbook.Name, Pos + 1)
Else
ActiveWorkbook.SaveAs FileName:=Path & Left(ActiveWorkbook.Name, Pos) & Format(Now, "d-mm-yyyy") & Mid(ActiveWorkbook.Name, Pos + 1)
End If
End Sub
Instead of appending "Copy xxx", why not to append the time?
eg
"Workbook Name, 2018-04-05 12.30.23.xlsm"
Well, the question could be changed a bit, to get what you are looking for. In general, you are looking for a function, which splits some strings by dots and spaces and increments the last one with 1.
E.g., if this is your input:
"WorkbookName 12.12.12.xlsm"
"WorkbookName 13.18.22 Copy 230.xlsm"
"WorkbookName 12.11.19 Copy 999.xlsm"
Your function should give the folowing output:
"WorkbookName 12.12.12.xlsm"
"WorkbookName 13.18.231.xlsm"
"WorkbookName 12.11.1000.xlsm"
Once you achieve this, the saving of the workbook could be carried out through that function. This is some function that gets that output:
Sub TestMe()
Dim path1 As String: path1 = "WorkbookName 12.12.12.xlsm"
Dim path2 As String: path2 = "WorkbookName 13.18.22 Copy 230.xlsm"
Dim path3 As String: path3 = "WorkbookName 12.11.19 Copy 999.xlsm"
Debug.Print changeName(path1)
Debug.Print changeName(path2)
Debug.Print changeName(path3)
End Sub
Public Function changeName(path As String) As String
changeName = path
Dim varArr As Variant
varArr = Split(path, ".")
Dim splitNumber As Long
splitNumber = UBound(varArr)
Dim preLast As String: preLast = varArr(splitNumber - 1)
If IsNumeric(preLast) Then Exit Function
Dim lastWithSpace As String
lastWithSpace = Split(preLast)(UBound(Split(preLast)))
Dim incrementSome As String
incrementSome = Left(preLast, Len(preLast) - Len(lastWithSpace))
If IsNumeric(lastWithSpace) Then
preLast = Split(preLast)(UBound(Split(preLast))) + 1
varArr(splitNumber - 1) = incrementSome & preLast
changeName = Join(varArr, ".")
End If
End Function
The changeName function could be a bit sanitized, with some checks, whether UBound-1 exists in order to avoid error.The function splits the input string to array by . symbol and works with the pre-last value received. Then, if the value is numeric, it does nothing, but if the value looks like this 22 Copy 230, it splits once again and increments the last element with one.
At the end it returns the string.
If you need to check the date as well, then one more layer of splits and arrays should be added.
Listen, you added a comma after the original name, Great! (now use it)
Dim FileName as String, FileExtension as String
FileName = "Workbook Name, Today's Date Copy 2.xlsm"
Pos = InStrRev(FileName, ".") - 1
FileExtension = ".xlsx" ' <-- Set a default
If Pos > 0 then
FileExtension = Mid(FileName, Pos)
FileName = Left(FileName, Pos)
End if
FileExtension has been pulled out from the FileName, and the Filename doesn't have an extension anymore. Now lets go after the Comma
Pos = InStrRev(FileName, ",")
If Pos2 > 0 then FileName = Left(FileName, Pos2 -1)
That was easy, FileName has now been cleaned of the Date and Copy junk. While you could have looked for the copy before we cleaned it, I think it's easier to just try a few times, since you're going to want to check if the file exists anyway.
You can alternatively just add the time like PhantomLord mentioned.
Dim Try as long
Dim FullName as String
Try = 0
FullName = Path & FileName & Format(Now, ", d-mm-yyyy") & FileExtension
' Lets put a safety limit to stop the code if something goes wrong
Do While Try < 1000 And Dir(FullName) = vbNullString
Try = Try + 1
FullName = Path & FileName & Format(Now, ", d-mm-yyyy") & " Copy " & IIF(Try > 1, Try, vbNullString) & FileExtension
Loop
ActiveWorkbook.SaveAs FileName:=FullName
I even thru in the IIF() for fun!
In the project I'm working on all of my code is in modules which each have a varying number of procedures. I'm trying to export VBA code procedures one by one into folders named after their respective module. I already have code to export whole modules but I like the challenge of this one and it's more fun to track changes this way!
The export code below works for every module except itself because of the way that I check for the start and end of a function/sub. It's a circular problem, really, because it thinks the phrases from the checks are the start of a new sub!
If anyone has a more creative solution for marking the beginning and end of a function or sub that will work here or has a way to tweak mine I would really appreciate it!
Sub ExportVBCode2()
'NOTE: Globals will be included with the first procedure exported, not necessarily the procedure(s) they're used in
Dim directory As String
directory = "C:\Users\Public\Documents\VBA Exports" & "\"
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
' If fso.FolderExists(Left(directory, Len(directory) - 1)) Then
' fso.deletefolder Left(directory, Len(directory) - 1)
' End If
If Len(Dir(directory, vbDirectory)) = 0 Then
MkDir directory
End If
Dim VBComponent As Object
Dim Fileout As Object
Dim i As Long
Dim currLine As String
Dim currLineLower As String
Dim functionString As String
Dim functionName As String
Dim funcOrSub As String
For Each VBComponent In ThisWorkbook.VBProject.VBComponents
If VBComponent.Type = 1 Then 'Component Type 1 is "Module"
If Len(Dir(directory & "\" & VBComponent.Name & "\", vbDirectory)) = 0 Then
MkDir directory & VBComponent.Name
End If
For i = 1 To VBComponent.CodeModule.CountOfLines
currLine = RTrim$(VBComponent.CodeModule.Lines(i, 1))
currLineLower = LCase$(currLine)
'TODO need a more clever solution for the if check below, because it catches ITSELF. Maybe regex ?
If (InStr(currLineLower, "function ") > 0 Or InStr(currLineLower, "sub ") > 0) And InStr(currLineLower, "(") > 0 And InStr(currLineLower, ")") > 0 Then
'this is the start of a new function
Select Case InStr(currLineLower, "function ")
Case Is > 0
funcOrSub = "function"
Case Else
funcOrSub = "sub"
End Select
functionName = Mid(currLine, InStr(currLineLower, funcOrSub) + Len(funcOrSub & " "), InStr(currLine, "(") - InStr(currLineLower, funcOrSub) - Len(funcOrSub & " "))
End If
functionString = functionString & currLine & vbCrLf
If Trim$(currLineLower) = "end sub" Or Trim$(currLineLower) = "end function" Then
'this is the end of a function
Set Fileout = fso.CreateTextFile(directory & "\" & VBComponent.Name & "\" & functionName & ".txt", True, True)
Fileout.Write functionString
Fileout.Close
functionString = ""
functionName = ""
End If
Next i
End If
Next VBComponent
End Sub
I think the key to the problem is to check if the line contains the term "function" contains also a left parenthesis after the function name. For example: Private Function foo(. So you expect to count 1 space character and at least 1 left parenthesis before the next space or comma character.
Interesting problem here. This line of code works through multiple iterations until it reaches a point where it throws an Run-time error 91 at me: "Object Variable or With block variable not set". This is occurring in a function designed to find a deal number. The entire program is an end of day email generation program that sends attachments to various different counter-parties. The error occurs on the ** line. For additional color, temp deal is not empty when execution is attempted. There doesn't appear to be any extraneous trailing or leading spaces either. Thanks in advance!
Function getPDFs(cFirm As Variant, iFirm As Variant, row_counter As Variant, reportsByFirm As Worksheet, trMaster As Worksheet, trSeparate As Variant, trName As Variant, reportDate As Variant) As String
dealCol = 1
Dim locationArray() As String
Dim DealArray() As String
cDes = "_vs._NY"
iDes = "_vs._IC"
filePath = "X:\Office\Confirm Drop File\"
dealNum = reportsByFirm.Cells(row_counter, dealCol)
FileType = ".pdf"
If InStr(1, dealNum, "-") > 0 Then
DealArray() = Split(dealNum, "-")
tempDeal = DealArray(LBound(DealArray))
Else
tempDeal = dealNum
End If
'Finds deal location in spread sheet for further detail to obtain file path
**trLocation = trMaster.Columns(2).Find(What:=tempDeal).Address
locationArray() = Split(trLocation, "$")
trRow = locationArray(UBound(locationArray))
'Formats client names for 20 characters and removes punctuation (".") in order to stay within convention of file naming
cFirmFormatted = Trim(Left(cFirm, 20))
iFirmFormatted = Trim(Left(iFirm, 20))
'Finds clearing method
clMethod = trMaster.Cells(trRow, 6).Value
Select Case clmethod
Case "Clport"
'Prevents naming convention issues with punctuations in the name
If InStr(1, cFirmFormatted, ".") > 0 Then
cFirmFormatted = Replace(cFirmFormatted, ".", "")
End If
getPDFs = filePath & cFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & cFirmFormatted & cDes & FileType
Case "ICE"
If InStr(1, iFirmFormatted, ".") > 0 Then
iFirmFormatted = Replace(iFirmFormatted, ".", "")
End If
getPDFs = filePath & iFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & iFirmFormatted & iDes & FileType
End Select
End Function
Your code assumes that trLocation is always found, if it isn't found then you will receive an error because you don't have a range to return the .Address property for.
Try testing the result first:
Dim testLocation As Excel.Range
Set testLocation = trMaster.Columns(2).Find(tempDeal)
If Not testLocation Is Nothing Then
trLocation = testLocation.Address
'// Rest of code here...
Else
MsgBox "Cannot find """ & tempDeal & """!"
Exit Function
End If
I would like to seek help regarding on getting the last modified date of a file in a Sharepoint. What VBA code/command will I use in order to execute it.
I would like to show this "Last Modified Date" of the file in a MsgBox when a command button is clicked.
Your prompt response is very much appreciated.
I've been trying to figure this out for a while and I stumbled upon something in another line of inquiry that led me to a solution.
In your VBA window, go to Tools -> References, and then scroll down and check the box next to "Microsoft Scripting Runtime".
Then when you specify your link it's going to read like this:
FileDateTime("//site.com/page/file.xlsx").
No "http:" Once I did that, it worked like a charm.
This one had me scratching my head for a bit too...
Make sure to add "#ssl" following the root URL e.g
FileDateTime("\\site.com#ssl\file.xlsx")
You can use
FileDateTime ( file_path )
to get the date and time of when a file was created or last modified.
For more information please visit the below link..
VBA Help
Sub TestWhen()
SPFilePath = "http://teams.MyCompany.com/sites/PATH/PATH/Fulfillment/Forms/AllItems.aspx"
SPFileName = "2021_MyFileName.xlsx"
MsgBox SPFileName & " last modified on" & SPLastModified(SPFilePath, SPFileName)
End Sub
Function SPLastModified(SPUrl As String, SPFName As String)
Dim IE As Object
Dim PagesHTML As String
Dim Dadate As String
Dim DaDateEnd As String
Dim arr() As String
arr = Split(OutString, " ")
Dim LastChange As Variant
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate SPUrl
Do Until .readyState = 4
DoEvents
Loop
Do While .busy: DoEvents: Loop
Do Until .readyState = 4
DoEvents
Loop
PagesHTML = ie.document.DocumentElement.outerHTML
End With
' Get to File
Dadate = InStr(PagesHTML, "FileLeafRef" & Chr(34) & ": " & Chr(34) & SPFName)
' Get to Modified Date
ModifiedText = "Modified" & Chr(34) & ": "
Dadate = Dadate + InStr(Mid(PagesHTML, Dadate), ModifiedText)
OutString = Mid(PagesHTML, Dadate + Len(ModifiedText), 27)
arr = Split(OutString, " ")
LastChange = arr(1) & " " & arr(2)
LastChange = arr(0) & "/" & Mid(arr(1), 6) & "/" & Mid(arr(2), 6, 4) & " " & LastChange
SPLastModified = LastChange
End Function
I have a folder with thousands of files, and a spreadsheet that has 2 pieces of information:
DocumentNumber Revision
00-STD-GE-1234-56 3
I need to find and concatenate all files in the folder than match this document number and revision combination into this format:
00-STD-GE-1234-56_3.docx|00-STD-GE-1234-56_3.pdf
The pdf must be last
sometimes the file is named without the last 3 chars of the document number (if they are -00 they are left off)
sometimes the revision is separated using "_" and sometimes using "_r"
I have the code working, but it takes a long time (this sheet has over 7000 rows, and this code is 20 file comparisons per row against a network file system), is there an optimization for this?
''=============================================================================
Enum IsFileOpenStatus
ExistsAndClosedOrReadOnly = 0
ExistsAndOpenSoBlocked = 1
NotExists = 2
End Enum
''=============================================================================
Function IsFileReadOnlyOpen(FileName As String) As IsFileOpenStatus
'ExistsAndClosedOrReadOnly = 0
'ExistsAndOpenSoBlocked = 1
'NotExists = 2
With New FileSystemObject
If Not .FileExists(FileName) Then
IsFileReadOnlyOpen = 2 ' NotExists = 2
Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
End If
End With
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileReadOnlyOpen = 0 'ExistsAndClosedOrReadOnly = 0
Case 70: IsFileReadOnlyOpen = 1 'ExistsAndOpenSoBlocked = 1
Case Else: IsFileReadOnlyOpen = 1 'Error iErr
End Select
End Function 'IsFileReadOnlyOpen
''=============================================================================
Function BuildAndCheckPath(sMasterPath As String, sLegacyDocNum As String, sRevision As String) As String
Dim sLegacyDocNumNoSheet As String
sLegacyDocNumNoSheet = Left(sLegacyDocNum, Len(sLegacyDocNum) - 3)
Dim sFileExtensions
sFileExtensions = Array(".doc", ".docx", ".xls", ".xlsx", ".pdf")
Dim sRevisionSpacer
sRevisionSpacer = Array("_", "_r")
Dim i As Long
Dim j As Long
Dim sResult As String
'for each revision spacer option
For i = LBound(sRevisionSpacer) To UBound(sRevisionSpacer)
'for each file extension
For j = LBound(sFileExtensions) To UBound(sFileExtensions)
'Check if the file exists (assume a sheet number i.e. 00-STD-GE-1234-56)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
If sResult = "" Then
sResult = sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
Else
sResult = sResult & "|" & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
End If
End If
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
If sResult = "" Then
sResult = sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
Else
sResult = sResult & "|" & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
End If
End If
Next j
Next i
BuildAndCheckPath = sResult
End Function
It's hard to tell without seeing your dataset, but perhaps this approach could be implemented (note the use of Wildcards):
UNTESTED
Const Folder As String = "C:\YourFolder\"
Dim File as Object
Dim XLSFile As String
Dim PDFFile As String
Dim ConCat() As String
Dim DocNos() As Variant
Dim DocRev() As Variant
Dim i As Long
DocNos = Range("A1:A10") '<--Your list of Document #s.
DocRev = Range("B1:B10") '<--Your list of Revision #s.
ReDim ConCat(1 To UBound(DocNos))
'Loop through your Document numbers.
For i = LBound(DocNos) To UBound(DocNos)
'Loop through the folder.
File = Dir(Folder)
Do While File <> ""
'Check the filename against the Document number. Use a wildcard at this _
'point as a sort of "gatekeeper"
If File Like Left(DocNos(i), Len(DocNos(i)) - 3) & "*"
'If the code makes it to this point, you just need to match file _
'type and revision.
If File Like "*_*" & DocRev(i) And File Like "*.xls*" Then
XLSFile = File
ElseIf File Like "*_*" & DocRev(i) File Like "*.pdf" Then
PDFFile = File
End If
If XLSFile <> "" And PDFFile <> "" Then
ConCat(i) = XLSFile & "|" & PDFFile
XLSFile = vbNullString
PDFFile = vbNullString
End If
End If
File = Dir
Loop
Next i
To print the results to your sheet (Transpose pastes the results of the array in one column instead of putting the results in one row), you could use something like this:
Dim Rng As Range
Set Rng = Range("C1")
Rng.Resize(UBound(ConCat),1).Value = Application.Transpose(ConCat)
This approach loops through each document number from your spreadsheet, and then checks each file in the folder to see if it matches the document number, document type, and revision number. Once it finds a match for both .xls* and .pdf types, it concatenates the filenames together.
See this great SO post regarding looping through files.
See this site for more info about the Dir function.
See this article regarding wilcard character usage when comparing strings.
Hope that helps!
Seems to me you are doing unnecessary file existence checks even in cases where a file has already been found. Assuming that talking with your network drive is indeed what takes up most of your execution time, then there's a place to optimise.
What you're doing is this:
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
'...
End If
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
'Wait a minute... why ask me to look again if I already found it?
'He must not mind the extra waiting time... ok, here we go again.
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'...
End If
I think you want to look for your file under a different filename if and only if you haven't found it under the first filename pattern. Can do this using an Else clause:
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
Else
'Didn't find it using the first filename format.
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
Else
Err.Raise 53, , _
"File not found even though I looked for it in two places!"
End If
End If
This can theoretically cut your number of tries by up to half; likely less in practice, but you'll get the largest benefit if you check the most common filename pattern first. The benefit will be proportionally larger if you have a greater number of filename patterns; from your question I understand you have 4 different combinations?
If you have more than 2 patterns to check, then nesting a bunch of Else clauses will look silly and be difficult to read; instead you can do something like this:
Dim foundIt As Boolean
foundIt = False
If Not foundIt And IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
foundIt = True
End If
If Not foundIt And IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
foundIt = True
End If
'...
'... check your other patterns here...
'...
If Not foundIt Then
Err.Raise 53, , _
"File not found even though I looked for it various places!"
End If