I have a macro in excel vba that runs a shell to execute a simple pdf editor by command line, exports a list of the page names and numbers, searches for a keyword to find the page we want, gets the page num, and then extracts that page from the pdf file.
I've realised this macro would serve better as a standalone entity, and was wondering what is required to take the code out of excel, and run it from a .vbs file.
I tried direct copy and paste and it didnt like the letter "A" in the word "As" in the first line.
Sub PDF_GetUFPlan()
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Integer
wsh.Run "C:\Users\johnmcs\Desktop\pdftk.exe C:\Users\johnmcs\Desktop\FULL.PDF burst output C:\Users\johnmcs\Desktop\output.txt", windowStyle, waitOnReturn
Dim hf As Integer: hf = FreeFile
Dim lines() As String, i As Long
Open "C:\Users\johnmcs\Desktop\doc_data.txt" For Input As #hf
lines = Split(Input$(LOF(hf), #hf), vbNewLine)
Close #hf
For i = 0 To UBound(lines)
If InStrRev(lines(i), "UPPER FLOOR PLAN") > 0 Then
For x = i To UBound(lines)
If InStrRev(lines(x), "BookmarkPageNumber: ") > 0 Then
Dim UFpagenum As Integer, PagenumPosi As Integer
PagenumPosi = InStrRev(lines(x), " ")
PagenumPosi = Len(lines(x)) - PagenumPosi
UFpagenum = Right(lines(x), PagenumPosi)
GoTo extractpage
End If
Next
End If
Debug.Print "Line"; i; "="; lines(i)
Next
extractpage:
wsh.Run "C:\Users\johnmcs\Desktop\pdftk.exe C:\Users\johnmcs\Desktop\FULL.PDF cat " & UFpagenum & " output C:\Users\johnmcs\Desktop\page" & UFpagenum & ".pdf", windowStyle, waitOnReturn
End Sub
Sub PDF_GetUFPlan()
Dim wsh
Set wsh = CreateObject("WScript.Shell") ' NB we also have wscript.createobject
Dim waitOnReturn
waitOnReturn = True
Dim windowStyle
windowStyle = 1
Dim errorCode
So here, the beginning is fixed. You cannot Dim as anything. Everything is a variant. Everything MUST be late bound so all sets must be done with CreateObject - no set x = new thing but set x = CreateObject("thing.application").
Remember VB6/VBA supports vbs feature set. vbs is compatable (a design goal) with vb6/vba.
VBscript does not support
Dim variable_name As variable_type
variable declaration....all variables are of type variant.
Just type:
Dim variable_name
Not technically a necessity, but (sigh... I can't believe I'm saying this) you should consider hungarian notation for VBScript. As the other answerers pointed out, VBScript is not a strongly typed language. You should rename your variables so it is clear what type they are to any future maintainer.
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim boolWaitOnReturn : waitOnReturn = True
Dim intWindowStyle : windowStyle = 1
Dim intErrorCode
Related
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.
I figure that I could post this as a unique way of returning output as text instead of integers to see if this can help others that are having the same issue as I am having.
What I'm trying to accomplish is holding the output of the command, but then channeling a specific output out as a text instead of being interger based.
Here's what I have so far, and I'm currently stuck on filtering the output. I know that I can use the mid command, but since the output in general from this command is fluid, I can't use mid to count specific characters.
The command in question is PowerShell.exe manage-bde -status C:
The output is this:
Volume C: [OSDisk]
[OS Volume]
Size: 118.24 GB
BitLocker Version: Windows 7
Conversion Status: Fully Encrypted
Percentage Encrypted: 100%
Encryption Method: AES 256
Protection Status: Protection On
Lock Status: Unlocked
Identification Field: None
Key Protectors:
Numerical Password
TPM
I need to pull some information from say for instance Conversion Status. I want it to tell me if it's 100%, or 0%...or whatever it is. I can't seem to pull just that line.
Here's what I have so far.
dim outputArray
dim inputText
dim message
Dim strText
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
inputText = strText
outputArray = split(inputText,"Converstion Status:")
for each x in outputArray
message = message & x & vbCRLF
next
msgbox message
Loop
This does a line by line pull, and I know that Conversion Status is the 3rd line, so maybe something to that effect of channeling that line and echoing the 100% to a variable that I can store as a separate output.
Update: I decided not to go through the approach of parsing the output to a text file. There has to be a better way and shorter code to accomplish this methodology, plus if Bitlocker variables get changed around on the output, my line methodology might not work.
I'm now trying to see if I can use the for /F search approach to find the string and set the variable. The goal for me to do all of this is to add it to a registry key that will contain these values for reporting
Here's my revised code.
dim outputArray
dim inputText
dim message
Dim strText
dim line
dim testCase
dim strConversion
dim Currentline
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
strConversion = "for /F ""delims="" %%a in (strText) do do findstr /M /i /C:'Conversion' C:\%i var=%%a"
Wscript.echo strConversion
Loop
This does a line by line pull, and I know that Conversion Status is the 3rd line, so maybe something to that effect of channeling that line and echoing the 100% to a variable that I can store as a separate output.
Update: I decided not to go through the approach of parsing the output to a text file. There has to be a better way and shorter code to accomplish this methodology, plus if Bitlocker variables get changed around on the output, my line methodology might not work.
I'm now trying to see if I can use the for /F search approach to find the string and set the variable. The goal for me to do all of this is to add it to a registry key that will contain these values for reporting.
Here's my revised code.
dim outputArray
dim inputText
dim message
Dim strText
dim line
dim testCase
dim strConversion
dim Currentline
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
strConversion = "for /F ""delims="" %%a in (strText) do findstr /M /i /C:'Conversion' C:\%i var=%%a"
Wscript.echo strConversion
Loop
So far when running it, it parrots back the line back 14 times which is the number of lines when you run the command straight. So, it is seeing it, just not fully parsing the data. "Conversion" is one the strings that I'm having it check for.
Another reason I don't want to do longer code is this is part of a script that already has quite a few lines, and this will be a final sub process.
Try to store the output into array like this code :
Option Explicit
Dim arrData,Data
If Not WScript.Arguments.Named.Exists("elevate") Then
CreateObject("Shell.Application").ShellExecute WScript.FullName _
,WScript.ScriptFullName & " /elevate", "", "runas", 1
WScript.Quit
End If
arrData = Run_PS_Script
MsgBox arrData(6)
'To get all data from this loop For...Next
For Each Data in arrData
MsgBox Data
Next
'*****************************************************************
Function Run_PS_Script()
Dim WshShell,Command,PSFile,ret,fso,file,text,Temp
Set WshShell = CreateObject("WScript.Shell")
Temp = WshShell.ExpandEnvironmentStrings("%Temp%")
Command = "cmd /c echo manage-bde -status C: ^|" &_
"Out-File %temp%\output.txt -Encoding ascii > %temp%\PSFile.ps1"
PSFile = WshShell.Run(Command,0,True)
ret = WshShell.Run("powershell.exe -ExecutionPolicy Unrestricted -File %temp%\PSFile.ps1",0,True)
Set fso = CreateObject("Scripting.FileSystemObject")
text = ReadFile(Temp &"\output.txt","byline")
Run_PS_Script=text
End Function
'*****************************************************************
Function ReadFile(path,mode)
Const ForReading = 1
Const TriStateUseDefault = -2
Dim objFSO,objFile,i,contents,strLine
Set objFSO = CreateObject("Scripting.FileSystemObject")
If mode = "unicode" Then
Set objFile = objFSO.opentextfile(path,,,true)
contents = objFile.ReadAll
ReadFile = contents
objFile.Close
End If
If mode = "byline" then
Set objFile = objFSO.OpenTextFile(path,ForReading)
Dim arrFileLines()
i = 0
Do Until objFile.AtEndOfStream
Redim Preserve arrFileLines(i)
strLine = objFile.ReadLine
strLine = Trim(strLine)
If Len(strLine) > 0 Then
arrFileLines(i) = strLine
i = i + 1
ReadFile = arrFileLines
End If
Loop
objFile.Close
End If
If mode = "all" Then
Set objFile = objFSO.OpenTextFile(path,ForReading)
contents = objFile.ReadAll
ReadFile = contents
objFile.Close
End If
End Function
'*****************************************************************
Okay, I want to post another variation again. How about this?
dim outputArray
dim inputText
dim message
Dim strText
Dim MyArray
conversion = "Conversion Status:"
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
inputText = strText
outputArray = split(inputText,"Conversion Status:")
for each i in outputArray
output = i
next
position = InStr(1, strText,conversion, 1)
msgbox position
Loop
I've got it now where it will return the 0 or 5 value for the line. How can I convert the 5 response back to actual text that came from that line?
Here is an example of pulling values from an array of strings in VBS:
' let us mock out our expected data returned from the disk
Dim sampleData(100)
sampleData(0) = "Volume C: [OSDisk]"
sampleData(1) = "[OS Volume]"
sampleData(2) = ""
sampleData(3) = " Size: 118.24 GB"
sampleData(4) = " BitLocker Version: Windows 7"
sampleData(5) = " Conversion Status: Fully Encrypted"
sampleData(6) = " Percentage Encrypted: 100%"
sampleData(7) = " Encryption Method: AES 256"
sampleData(8) = " Protection Status: Protection On"
sampleData(9) = " Lock Status: Unlocked"
sampleData(10) = " Identification Field: None"
sampleData(11) = " Key Protectors:"
sampleData(12) = " Numerical Password"
sampleData(13) = " TPM"
'create a function to parse out the values you want
Function returnValueFromData(sampleData,fieldName)
For each infoLine in sampleData
If InStr(infoline,fieldName) Then
infoline = Trim(Replace(infoline,fieldName,""))
returnValueFromData = infoline
End If
Next
End Function
'now, we can use our function above to grab whatever field we want
'get the size of the disk
dim size
size = returnValueFromData(sampleData,"Size:")
wscript.echo size
'get the lock status of the disk
dim lockStatus
lockStatus = returnValueFromData(sampleData,"Lock Status:")
wscript.echo lockStatus
'shorthand to get the encryption algorithm
wscript.echo returnValueFromData(sampleData,"Encryption Method:")
I'm trying to pull text from a bunch of XML files into Word. I'm working from a list of files and have found that some of them don't actually exist in the folder. So, I'm using this function to check whether the files actually exist before opening them. But I'm still getting error 52 (Bad file name or number).
This is the function:
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function
And this is the code I'm calling it from:
Sub PullContent()
Dim docList As Document
Dim docCombinedFile As Document
Dim objFileListTable As Table
Dim objRow As Row
Dim strContent As String
Dim strFileCode As String
'Code # for the current file. (Pulled in temporarily, output to the Word doc.)
Dim strFilename As String
'Name of XML file. Created based on strFileCode
Set docCombinedFile = Documents.Add
'The new doc which will list all warnings
Dim strXml As String
'String variable that holds the entire content of the data module
Dim strInvalidCodes
'String listing any invalid file codes. Displayed at the end.
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Documents.Open FileName:="C:\Users\kelly.keck\Documents\Triton MTS\IETMs - Test\IETMList.docx"
Set docList = Documents("IETMList.docx")
Set objFileListTable = docList.Tables(1)
For Each objRow In objFileListTable.Rows
strFileCode = objRow.Cells(4).Range.Text
strFileCode = Left(strFileCode, Len(strFileCode) - 2)
strFilename = strFileCode & ".xml"
strPath = "C:\Applications\xml\"
If FileThere(strPath & strFileCode) = True Then
'MsgBox (strPath & strFilename)
strXml = FSO.OpenTextFile(strPath & strFilename).ReadAll
Else
strInvalidCodes = strInvalidCodes & vbCr & strFileCode
End If
Next
MsgBox ("The following filenames were invalid: " & vbCr & strInvalidCodes)
End Sub
Getting this error seems to defeat the purpose of having a function to check if a file exists, but I'm not sure what's wrong with the function.
A bit late to the party, but this hasn't had an accepted answer yet.
I generally use this method to test if a file exists, and your code uses FileSystemObject already so could use that reference.
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I believe that you need to be sure that FileThere is actually returning the Boolean value you intend. It would be more reliable if you checked the Len property (the number of characters) or checked whether it actually returns the empty string.
The following is more verbose than absolutely necessary in order to make the logic clear. If you were to use Len, instead, then you'd check Len(Dir(FileName)) > 0
Function FileThere(FileName as String) as Boolean
Dim bFileExists as Boolean
If Dir(FileName) = "" Then
bFileExists = False
Else
bFileExists = True
End If
FileThere = bFileExists
End Function
Is there any SQL equivalent of "%" sign in VBA?
I need to return a few files just with some characters in the middle.
Help really appreciated!
For instance here is my code: I need to download all file that has in the name 2013 from that webpage and save and call them differently. Is this mission possible?
Sub Sample()
Dim strURL As String
Dim strPath As String
Dim i As Integer
strURL = "http://cetatenie.just.ro/wp-content/uploads/Ordin-********.2013.pdf"
strPath = "C:\Documents and Settings\ee28118\Desktop\178.pdf"
Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)
If Ret = 0 Then
MsgBox "File successfully downloaded"
Else
MsgBox "Unable to download the file"
End If
End Sub
You can use the Like Operator.
Characters in pattern Matches in string
? Any single character.
* Zero or more characters.
# Any single digit (0–9).
[charlist] Any single character in charlist.
[!charlist] Any single character not in charlist
Example :
Dim MyCheck
MyCheck = "aBBBa" Like "a*a" ' Returns True.
MyCheck = "F" Like "[A-Z]" ' Returns True.
MyCheck = "F" Like "[!A-Z]" ' Returns False.
MyCheck = "a2a" Like "a#a" ' Returns True.
MyCheck = "aM5b" Like "a[L-P]#[!c-e]" ' Returns True.
MyCheck = "BAT123khg" Like "B?T*" ' Returns True.
MyCheck = "CAT123khg" Like "B?T*" ' Returns False.
When you navigate to the uploads folder, you get a directory listing of all the files in it. You can loop through the hyperlinks on that listing and test each to see if it meets your criterion and, if so, download it. You need a reference to MSXML and MSHTML. Here's an example.
Sub Sample()
Dim sUrl As String
Dim xHttp As MSXML2.XMLHTTP
Dim hDoc As MSHTML.HTMLDocument
Dim hAnchor As MSHTML.HTMLAnchorElement
Dim Ret As Long
Dim sPath As String
Dim i As Long
sPath = "C:\Documents and Settings\ee28118\Desktop\"
sUrl = "http://cetatenie.just.ro/wp-content/uploads/"
'Get the directory listing
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "GET", sUrl
xHttp.send
'Wait for the page to load
Do Until xHttp.readyState = 4
DoEvents
Loop
'Put the page in an HTML document
Set hDoc = New MSHTML.HTMLDocument
hDoc.body.innerHTML = xHttp.responseText
'Loop through the hyperlinks on the directory listing
For i = 0 To hDoc.getElementsByTagName("a").Length - 1
Set hAnchor = hDoc.getElementsByTagName("a").Item(i)
'test the pathname to see if it matches your pattern
If hAnchor.pathname Like "Ordin-*.2013.pdf" Then
Ret = UrlDownloadToFile(0, sUrl & hAnchor.pathname, sPath, 0, 0)
If Ret = 0 Then
Debug.Print sUrl & hAnchor.pathname & " downloaded to " & sPath
Else
Debug.Print sUrl & hAnchor.pathname & " not downloaded"
End If
End If
Next i
End Sub
Edit
I assumed that URLDownloadToFile was already written. I didn't write one, I just used the below function to test the code that iterates through the files. You can use it to make sure the above code works for you, but you'll need to write the actual code to download the file eventually. With all the arguments to URLDownloadToFile, I'm surprised it doesn't exist already.
Function UrlDownloadToFile(lNum As Long, sUrl As String, sPath As String, lNum1 As Long, lNum2 As Long) As Long
UrlDownloadToFile = 0
End Function
Try below code : The boolean function would return true if the string has the string 2013 in it.
Sub Sample()
Dim result As Boolean
result = has2013("http://cetatenie.just.ro/wp-content/uploads/Ordin-********.2013.pdf")
Debug.Print result
result = has2013("http://cetatenie.just.ro/wp-content/uploads/Ordin-********.2014.pdf")
Debug.Print result
End Sub
Function has2013(lnk As String) As Boolean
has2013 = lnk Like "*2013*"
End Function
in VBA use the LIKE function with wildcard characters:
here is an example (copied from Ozgrid Forums)
Dim sht As Worksheet
For Each sht In ActiveWorkbook.Worksheets
If sht.Name Like "FRI*" Then
'Add code for Friday sheets
Else
If sht.Name Like "MON*" Then
'Add code for Monday sheets
End If
End If
Next
The multiplication character * takes the place of zero or more characters, whereas ? takes the place of exactly 1 character, and # takes the place of 1 number. There are other more specific char. matching strategies if you only want to match certain characters.
so there you go!
Also, you could take a look at Ozgrid Forums: Using Regular Expressions in VBA
To get a list of the files on the server, read up on FTP (using DIR) at Mr Excel - List files using FTP
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"