Option Explicit
_____________________________________________________________________________________
Function UniqueImageNames(ByVal Path As String, Optional ByVal Filter As String, Optional Ext As Variant, Optional KeepTNflag As Boolean, Optional StripToBare As Boolean, Optional LooseFlag As Boolean) As Collection
' returns collection. use Collection2Array function if Array wanted
' default is exact match. flag allows simply to be successful string search
' StripToBare overrides Filter
Dim bool As Boolean, NumInFilter As Boolean
Dim LenExt As Integer
Dim fn As String
Dim FileList As New Collection
Dim f, fls As Variant
If IsMissing(Ext) Then Ext = ".jpg"
If Left(Ext, 1) <> "." Then
Ext = "." & Ext
End If
LenExt = Len(Ext)
' is ending number in the filter? -> this is n.g. when there is a dash in the file name
NumInFilter = InStr("0123456789", Right(Filter, 1)) <> 0 And Left(Right(Filter, 2), 1) = "-"
NumInFilter = NumInFilter Or InStr("0123456789", Right(Filter, 1)) <> 0 And InStr("0123456789", Left(Right(Filter, 2), 1)) <> 0 And Left(Right(Filter, 3), 1) = "-"
Set fls = CreateObject("Scripting.FileSystemObject").GetFolder(Path).Files
For Each f In fls
If Right(f, LenExt) = Ext Then
' remove file extension (.jpeg extension is not allowed)
f = DropStr(f, -LenExt)
' blank out master images
If Right(f, 2) = "-f" Then
f = DropStr(f, -2)
ElseIf Right(f, 3) = "-ff" Then
f = DropStr(f, -3)
End If
' check for filter
If 0 <> Len(Filter) Or StripToBare Then
fn = ExtractFilename(f)
' strip off number, but not if number is in the filter
If StripToBare Or Not NumInFilter Then
If InStr("0123456789", Right(fn, 1)) <> 0 And Left(Right(fn, 2), 1) = "-" Then
fn = DropStr(fn, -2)
ElseIf InStr("0123456789", Right(fn, 1)) <> 0 And InStr("0123456789", Left(Right(fn, 2), 1)) <> 0 And Left(Right(fn, 3), 1) = "-" Then
fn = DropStr(fn, -3)
End If
End If
' then test
If StripToBare Then
If Right(fn, 3) = "-tn" Then
fn = DropStr(fn, -3)
End If
On Error Resume Next
FileList.Add fn, fn
On Error GoTo 0
GoTo NextLoop
End If
' we have a tight and a loose way of selecting
If LooseFlag Then
bool = InStr(fn, Filter) = 0
Else
bool = Filter <> fn
End If
If bool Then
GoTo NextLoop
End If
End If
' remove thumbnails
If KeepTNflag Then
If Right(f, 3) = "-tn" Then
On Error Resume Next
FileList.Add f, f
On Error GoTo 0
End If
ElseIf Right(f, 3) <> "-tn" Then
On Error Resume Next
FileList.Add f, f
On Error GoTo 0
End If
End If
NextLoop:
Next f
' return collection
Set UniqueImageNames = FileList
End Function
_____________________________________________________________________________________
Function ReturnImageLink(ByVal Path As String, ByVal EntryType As String, Optional ByVal Filter As String, Optional ByVal Prefix As String) As String
' arg: 1-Path, 2-EntryType, 3-Filter, 4-Prefix
' Entryes supported:
' 0 - nothing. Default.
' 1 - surround with
xx
' 9 - add
to end
Dim AltString As String, File As String, H As String
Dim SizeFS As Variant
' create filename
File = Path & "\" & Filter
' clean up name to use as alt string
AltString = Replace(Filter, "-", " ")
' check for full-size image existence
If FileExists(File & "-f.jpg") Then
SizeFS = GetImageSize(File & "-f.jpg")
' build image string
H = "
"
Else
H = "
"
End If
' return
If EntryType = 1 Then
H = "" & H & "
"
ElseIf EntryType = 9 Then
H = H & vbCrLf & "
"
End If
ReturnImageLink = H & vbCrLf
End Function
_____________________________________________________________________________________
Function CreateImageLinks(ByVal Path As String, ByVal EntryType As String, Optional ByVal Filter As String, Optional ByVal Prefix As String, Optional WidePicFlag As Boolean, Optional Ext As Variant, Optional ByVal KeepTNflag As Boolean, Optional LooseFlag As Boolean) As String
' EntryType:
' 0 - interlace with 's. Default.
' 1 - surround with
xx
' 2 - same as 1, but has leading
with expectation title will be added to each cell
' 3 - surround with xx |
' 4 - surround with xx
' 5 - surround with xx
' 6 - surround with xx
' 7 - surround with xx
' 8 - surround with and
' 9 - interlace with
's
' 10 - javascript slide show (all found will be in slide show) -> all must be same size
' 11 - cell container for thumbnails
Dim FileList As Collection
Dim i As Integer
Dim H As String, k As Integer, StrRes As String, W As String
Dim File, Size As Variant
If IsMissing(Ext) Then Ext = ".jpg"
StartAgain:
Set FileList = UniqueImageNames(Path, Filter, Ext, KeepTNflag, , LooseFlag)
If FileList.Count = 0 And Ext = ".jpg" Then
Ext = ".webp"
GoTo StartAgain
End If
' maybe they put in a bad path?
If FileList.Count = 0 Then
Application.StatusBar = False
If 0 <> Len(Filter) Then
W = ", or filter is too tight for " & Filter
Else
W = ""
End If
MsgBox "No " & Ext & " files found to process" & W & ". Check path. Aborting.", vbCritical, "No Files!"
CreateImageLinks = ""
End
End If
If EntryType = 10 Then
Size = GetImageSize(FileList(1) & Ext)
' this can be replaced by WorksheetFunction.SpellNumber() in newer version
' StrConv(strText, vbProperCase)
StrRes = "" & FileList.Count & " Page Article
" & vbCrLf & vbCrLf
StrRes = StrRes & "" & vbCrLf & vbCrLf
i = 1
TryAgain:
k = InputBox("Suffix for Slide Show (1 or 2):", "Suffix Needed", "1")
If k <> 1 And k <> 2 Then
MsgBox "Can only enter a 1 or 2.", vbCritical, "Try Again"
GoTo TryAgain
End If
Else
StrRes = ""
End If
For Each File In FileList
H = ImageString(File, Prefix, Ext, WidePicFlag)
' add container around it
If EntryType = 0 Then
StrRes = StrRes & H & vbCrLf
ElseIf EntryType = 1 Then
StrRes = StrRes & "
" & H & "
" & vbCrLf
ElseIf EntryType = 2 Then
StrRes = StrRes & "
" & vbCrLf
StrRes = StrRes & "
" & H & "
" & vbCrLf
ElseIf EntryType = 3 Then
StrRes = StrRes = "
" & H & " | " & vbCrLf
ElseIf EntryType = 4 Then
StrRes = StrRes & "
" & H & "" & vbCrLf
ElseIf EntryType = 6 Then
StrRes = StrRes & "
" & H & "" & vbCrLf
ElseIf EntryType = 5 Then
StrRes = StrRes & "
" & H & "" & vbCrLf
ElseIf EntryType = 7 Then
StrRes = StrRes & "
" & H & "" & vbCrLf
ElseIf EntryType = 8 Then
StrRes = StrRes & "
" & vbCrLf
StrRes = StrRes & H & vbCrLf
StrRes = StrRes & "
" & vbCrLf
ElseIf EntryType = 9 Then
StrRes = StrRes & H & vbCrLf & "
" & vbCrLf
ElseIf EntryType = 10 Then
StrRes = StrRes & "
" & vbCrLf
StrRes = StrRes & "
" & i & " / " & FileList.Count & "
" & vbCrLf
StrRes = StrRes & H & vbCrLf
StrRes = StrRes & "
" & vbCrLf
i = i + 1
ElseIf EntryType = 11 Then
W = ExtractFilename(File)
StrRes = StrRes & "
" & vbCrLf
End If
If EntryType = 0 Then
StrRes = StrRes & "
"
End If
StrRes = StrRes & vbCrLf
Next File
If EntryType = 10 Then
StrRes = StrRes & "❮" & vbCrLf
StrRes = StrRes & "❯" & vbCrLf
StrRes = StrRes & "
" & vbCrLf
Else
' remove any stray at the end
If Right(StrRes, 5) = "" & vbCrLf Then
StrRes = DropStr(StrRes, -5)
End If
End If
CreateImageLinks = StrRes
End Function
_____________________________________________________________________________________
Function ImageString(File As Variant, Prefix As String, ByVal Ext As String, WidePicFlag As Boolean) As String
Dim AltString As String, W As String
Dim Size, SizeFS As Variant
' clean up name to use as alt string
AltString = ExtractFilename(File)
If 0 <> InStr(AltString, "_") Then
AltString = Left(AltString, InStr(AltString, "_") - 1)
End If
AltString = Replace(AltString, "-", " ")
' sometimes add class to not have max-width to be 100%
W = ""
If WidePicFlag Then
' we normally allow processing without the web-size image needing to be present, but not for this
If FileExists(File & Ext) Then
Size = GetImageSize(File & Ext)
If 1200 < Size(0) Then
W = " class=""widepic"""
End If
Else
MsgBox "When running with WidePic option you need the web-size image to also be present.", vbCritical, "Missing File"
End
End If
End If
' check for full-size image existence
If FileExists(File & "-f" & Ext) Then
SizeFS = GetImageSize(File & "-f" & Ext)
' build image string
ImageString = "
"
Else
ImageString = "
"
End If
End Function
_____________________________________________________________________________________
Private Sub DisplayImageLinks()
' is button on ImageUtils sheet
'EntryType:
' 0 - interlace with
's. Default.
' 1 - surround with
xx
' 2 - same as 1, but has leading
with expectation title will be added to each cell
' 3 - surround with xx |
' 4 - surround with xx
' 5 - surround with xx
' 6 - surround with xx
' 7 - surround with xx
' 8 - surround with and
' 9 - interlace with
's
' 10 - javascript slide show (all found will be in slide show) -> all must be same size
' 11 - cell container for thumbnail
Dim KeepTNflag As Boolean, WidePicFlag As Boolean
Dim i As Integer, k As Integer
Dim EntryType As String, Ext As String, Filter As String, Path As String, Prefix As String, S As String, StrRes As String
Path = GetImagePath
Prefix = Range("CreateLinksPrefix").Value
Filter = Range("CreateLinksFilter").Value
EntryType = Range("CreateLinksType").Value
If Len(EntryType) = 0 Then EntryType = 0
Ext = Range("CreateLinksFile").Value
If Len(Ext) = 0 Then Ext = ".jpg"
i = Range("CreateLinksUL").Row
KeepTNflag = False
WidePicFlag = Range("CreateLinksWide").Value
ClearImageLinks
RestoreInputCells "CreateLinksFilter"
Application.StatusBar = "Getting filenames..."
StrRes = CreateImageLinks(Path, EntryType, Filter, Prefix, WidePicFlag, Ext, KeepTNflag, True)
' ~~ print to sheet
If Len(StrRes) > 0 Then
With Sheets("ImageUtils")
Do
S = Left(StrRes, InStr(StrRes, vbCrLf) - 1)
.Cells(i, 1).Value = S
i = i + 1
StrRes = DropStr(StrRes, Len(S) + 2)
Loop While Len(StrRes) > 0
End With
End If
Application.StatusBar = False
End Sub
_____________________________________________________________________________________
Private Sub RemoveLinkBlankRowsImg()
' is button on ImageUtils sheet
RemoveLinkBlankRows "CreateLinksUL", 1
End Sub
_____________________________________________________________________________________
Private Sub PutImageLinksIntoClipboard()
' is button on ImageUtils sheet
Dim EndRow As Integer, StartRow As Integer
Dim Col As String
With Sheets("ImageUtils")
StartRow = .Range("CreateLinksUL").Row
If Range("CreateLinksUL").Value = "Width" Then
Col = "D"
StartRow = StartRow + 1
Else
Col = "A"
End If
EndRow = .Range(Col & "65536").End(xlUp).Row
If EndRow >= StartRow Then
.Range(Col & StartRow & ":" & Col & EndRow).Copy
End If
End With
End Sub
_____________________________________________________________________________________
Sub ClearImageLinks()
' is button on ImageUtils sheet
Application.ScreenUpdating = False
If ActiveCell.Row > Range("CreateLinksUL").Row Then
Range("CreateLinksUL").Select
End If
Sheets("ImageUtils").Range("A" & Range("CreateLinksUL").Row & ":E65536").Clear
End Sub
_____________________________________________________________________________________
Private Sub ClearMore()
' is button on ImageUtils sheet
ClearImageLinks
Range("ImgUtilPath2").Clear
RestoreInputCells "ImgUtilPath2"
Range("ListFilter").Clear
RestoreInputCells "ListFilter"
Range("Filter").Clear
RestoreInputCells "Filter"
Range("CreateLinksFilter").Clear
RestoreInputCells "CreateLinksFilter"
End Sub
_____________________________________________________________________________________