We'll also add value by creating shortcuts in a shortcut folder. When a shortcut of an image is created Windows Explorer will use the image itself. This means you can leave all the image files in situ but collate one large folder with copies of the image.
A curious note about the code is the multiplicity of Scripting libraries out there. I nearly always use Microsoft Scripting Runtime for its dictionaries. There is another scripting library called {"Microsoft Shell Controls and Automation",shell32.dll} which I thought I'd need to create a shortcut. It turns out the CreateShortcut method is in {"Windows Script Host Object Model",wshom.ocx}
TODO: compile an exhaustive list of all the scripting libraries to make sure I miss no goodies.
Here is the standard module modLookForPictureFiles.bas
Option Explicit
Option Private Module
'* Tool->References Microsoft Scripting Runtime
'* Tool->References Windows Script Host Object Model
Private m_fso As New Scripting.FileSystemObject
Private m_oWsh As New WshShell
Private msDIR As String
Private Sub Test()
'* my blog does not like angle brackets - grrrr!
msDIR = " " & Chr$(60) & "DIR" & Chr$(62) & " "
'* ASSUMES YOU HAVE DONE c:\dir *.* /s > c:\temp\cdrive_star_dot_star_20170203.txt
Dim sImageShortcutsFolder As String
sImageShortcutsFolder = "n:\ImageShortcuts"
Debug.Assert m_fso.FolderExists(sImageShortcutsFolder)
Sheet1.Cells.Clear
Dim sPipedOutputPath As String
sPipedOutputPath = "c:\temp\cdrive_star_dot_star_20170203.txt"
Dim dicLongListResults As Scripting.Dictionary
Debug.Assert m_fso.FileExists(sPipedOutputPath)
'Dim dic As Scripting.Dictionary
ReadDirForwardSlashSCreateImageShortcuts sImageShortcutsFolder, sPipedOutputPath, dicLongListResults
Debug.Assert dicLongListResults.Count = Sheet1.Cells(1, 1).CurrentRegion.Rows.Count
'PasteResults dicLongListResults, 1
'Debug.Print VBA.Join(dicLongListResults.Keys, vbNewLine)
'Stop
End Sub
Private Sub PasteResults(ByVal dicLongListResults As Scripting.Dictionary, ByVal lResultIndex As Long)
If dicLongListResults.Count > 0 Then
Dim vResults As Variant
vResults = Application.Transpose(dicLongListResults.Keys)
Dim rngOrigin As Excel.Range
Set rngOrigin = Sheet1.Cells(lResultIndex, 1)
Debug.Assert IsEmpty(rngOrigin.Value)
rngOrigin.Resize(dicLongListResults.Count) = vResults
dicLongListResults.RemoveAll
End If
End Sub
Private Function ReadDirForwardSlashSCreateImageShortcuts(ByVal sImageShortcutsFolder As String, ByVal sPipedOutputPath As String, _
ByRef pdicLongListResults As Scripting.Dictionary)
Dim lResultIndex As Long: lResultIndex = 1
Dim lSavedResultIndex As Long: lSavedResultIndex = 1
Dim dicInterimResults As Scripting.Dictionary
Set dicInterimResults = New Scripting.Dictionary
If m_fso.FileExists(sPipedOutputPath) Then
Dim txtIn As Scripting.TextStream
Set txtIn = m_fso.OpenTextFile(sPipedOutputPath)
Set pdicLongListResults = New Scripting.Dictionary
Dim lLineNumber As Long
lLineNumber = 0
Dim sLine As String
sLine = txtIn.ReadLine
While Not txtIn.AtEndOfStream
DoEvents
lLineNumber = lLineNumber + 1
Dim bIsFileHeader As Boolean
bIsFileHeader = IsFileHeader(sLine, lLineNumber)
Dim bIsBlankLine As Boolean
bIsBlankLine = IsBlankLine(sLine)
Dim sDirectory As String
Dim bIsDirectoryHeader As Boolean
bIsDirectoryHeader = IsDirectoryHeader(sLine, sDirectory)
Dim bIsTrailerLine As Boolean
bIsTrailerLine = IsTrailerLine(sLine)
If bIsTrailerLine Then
PasteResults dicInterimResults, lSavedResultIndex
lSavedResultIndex = lResultIndex
End If
Dim bIsEntryLine As Boolean
bIsEntryLine = IsEntryLine(bIsFileHeader, bIsDirectoryHeader, bIsTrailerLine, bIsBlankLine)
Dim bIsFileLine As Boolean
bIsFileLine = IsFileLine(bIsEntryLine, sLine)
If bIsFileLine Then
Dim sFileName As String
sFileName = Trim$(Mid$(sLine, 37))
Dim lLastDotInstr As Long
lLastDotInstr = VBA.InStrRev(sFileName, ".")
If lLastDotInstr > 0 Then
Dim sLastFiveChars As String
sLastFiveChars = Left$(Mid$(sFileName, lLastDotInstr) & " ", 5)
Debug.Assert Len(sLastFiveChars) = 5
Debug.Assert Left$(sLastFiveChars, 1) = "."
Dim lFileTypeFound As Long
lFileTypeFound = VBA.InStr(1, "|.jpeg|.jpg |.tiff|.gif |.bmp |.png |.img |", "|" & sLastFiveChars & "|", vbTextCompare)
If lFileTypeFound > 0 Then
Dim sFullPath As String
sFullPath = m_fso.BuildPath(sDirectory, sFileName)
If m_fso.FileExists(sFullPath) Then
Dim filImage As Scripting.File
Set filImage = m_fso.GetFile(sFullPath)
Dim sShortCut As String
sShortCut = m_fso.BuildPath(sImageShortcutsFolder, CreateLinkFileExtensionEquiv(filImage.Name))
CreateShortcut sShortCut, sFullPath
Set filImage = Nothing
End If
pdicLongListResults.Add sFullPath, 0
dicInterimResults.Add sFullPath, 0
lResultIndex = lResultIndex + 1
End If
End If
End If
sLine = txtIn.ReadLine
Wend
txtIn.Close
Set txtIn = Nothing
End If
End Function
Private Function IsTrailerLine(ByVal sLine As String) As Boolean
If (VBA.InStr(1, sLine, "File(s)", vbTextCompare) > 0) Then
IsTrailerLine = True
End If
End Function
Private Function IsBlankLine(ByVal sLine As String) As Boolean
IsBlankLine = (Len(Trim(sLine)) = 0)
End Function
Private Function IsFileLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
If bIsEntryLine Then
If (VBA.InStr(1, sLine, msDIR, vbTextCompare) = 0) Then
IsFileLine = True
End If
End If
End Function
Private Function IsSubdirectoryLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
If bIsEntryLine Then
If (VBA.InStr(1, sLine, msDIR, vbTextCompare) > 0) Then
IsSubdirectoryLine = True
End If
End If
End Function
Private Function IsEntryLine(ByVal bIsFileHeader As Boolean, ByVal bIsDirectoryHeader As Boolean, ByVal bIsTrailerLine As Boolean, ByVal bIsBlankLine As Boolean) As Boolean
IsEntryLine = (Not bIsFileHeader) And (Not bIsDirectoryHeader) And (Not bIsTrailerLine) And (Not bIsBlankLine)
End Function
Private Function IsDirectoryHeader(ByVal sLine As String, ByRef psDirectory As String) As Boolean
If VBA.InStr(1, sLine, " Directory of ", vbTextCompare) > 0 Then
psDirectory = Trim(Mid$(sLine, 15))
IsDirectoryHeader = True
End If
End Function
Private Function IsFileHeader(ByVal sLine As String, ByVal lLineNumber As Long) As Boolean
If lLineNumber <= 2 Then
IsFileHeader = (VBA.InStr(1, sLine, " Volume ", vbTextCompare) > 0)
End If
End Function
Private Function CreateShortcut(ByVal sShortCut As String, ByVal sTargetPath As String)
If Not m_fso.FileExists(sShortCut) Then
Dim oShortcut As WshShortcut
Set oShortcut = m_oWsh.CreateShortcut(sShortCut)
oShortcut.TargetPath = sTargetPath
oShortcut.Save
End If
End Function
Private Function CreateLinkFileExtensionEquiv(ByVal sFile_Name As String) As String
Dim vSplit As Variant
vSplit = VBA.Split(sFile_Name, ".")
If UBound(vSplit) > LBound(vSplit) Then
vSplit(UBound(vSplit)) = "lnk"
End If
CreateLinkFileExtensionEquiv = Join(vSplit, ".")
End Function
No comments:
Post a Comment