Option Explicit _____________________________________________________________________________________ Private Sub ProcessOneBookSS() ' is button on SlideShows sheet ProcessSlideShow GetSlideShowRow("SSRowNum") End Sub _____________________________________________________________________________________ Sub ProcessAllBookSS() ' called by other modules ProcessAllBookSub Range("SSFilter").Value End Sub _____________________________________________________________________________________ Sub ProcessAllBookSub(Filter As String) ' is button on SlideShows sheet ' called by other modules ' this changes in .htaccess: RedirectMatch permanent /1900s/1907/w([0-9]*.jpg) /1900s/1907/wp$1 Dim Okay As Boolean Dim i As Integer For i = 1 To Range("SSInputMatrix").Rows.Count If Range("SSInputMatrix").Cells(i, 5).Value <> "" Then Okay = True If Len(Filter) > 0 Then If 0 = InStr(Range("SSInputMatrix").Cells(i, 5).Value, Filter) Then Okay = False End If If Okay Then DoEvents Application.StatusBar = "Processing " & i & " - " & ExtractFilename(Range("SSInputMatrix").Cells(i, 5).Value) & "..." ProcessSlideShow i End If End If Next i Application.StatusBar = False End Sub _____________________________________________________________________________________ Private Sub ProcessSlideShow(RowNum As Integer) ' in addition to options in sheet comments, there are actions that are activated by file existence in the folder: ' NextFolder.txt - the next slide show to lead into -> not yet implemented ' Captions.txt - one row for each for optional caption ' for -f data is stored under filename of web-sized image, but for original way is raw number, e.g. 00 ' captions can also be used for titles on the index page. see option on sheet to turn on ' Subheadings.txt - adds subheadings to index page ' Heading.txt - adds a heading above the arrows -> no carriage return at end ' can have uline and italic spans ' image files can be either jpg or webp files files, but not mixed. webp files cannot have original-size files ' image files have two naming conventions. activate -f as option on sheet ' thumbnails: tp01.jpg xx-tn.jpg ' web-size files: wp01.jpg xx.jpg ' original-size files: p01.jpg xx-f.jpg [xx files processed in alphabetical order) ' N.B. the p01 style can have skipped numbers. so they can line up with pages in a book ' -f resizing and other file management is on the ImageUtils sheet ' multiple images can be on the same page. they end with -1, -2, etc. max of 9. ' the trigger is the -1 does not have a thumbnail. the thumbnail is named as the body without the suffix Dim BackFlg As Boolean, BorderOn As Boolean, CapOrderFlag As Boolean, IndxCapFlag As Boolean Dim CaptionFlag As Boolean, UseFs As Boolean, CovLbl As Boolean, MultiFlag As Boolean Dim i As Integer, k As Integer, PubNum As Integer Dim BackLinks As String, Fldr As String, ArrowPath As String, Title As String, T1 As String, t2 As String Dim Heading As String, PubType As String, PubTypeSpacer As String, Path As String Dim IndTitle As String, NumFmt As String, H As String, NextFN As String, PrevFN As String Dim NextGif As String, NextFT As String, PrevGif As String, PrevFT As String Dim AltStr As String, Ext As String, S As String, Fmt As String, t As String, tempP As String, tempWP As String Dim Captions, FileList, ListPs, ListRaw, ListTPs, ListWPs, SizeFS, SubHeadList, temp, v As Variant ' PubNum-PubType: 0-nothing, 1-Catalog, 2-Folder, 3-Pages, 4-Photo, 5-Slide PubNum = Range("SSInputMatrix").Cells(RowNum, 1).Value If PubNum <> 5 Then temp = Array("", "Catalog", "Folder", "Pages", "Photo") PubType = temp(PubNum) End If If Len(PubType) > 0 Then PubTypeSpacer = " " End If CovLbl = Range("SSInputMatrix").Cells(RowNum, 2).Value BackFlg = Range("SSInputMatrix").Cells(RowNum, 3).Value ' Option Code: 1- give htm images a border ' (Additive) 2- use -f files ' 4- add captions to index thumbnails ' 8- use captions for image order t = Dec2Bin(Range("SSInputMatrix").Cells(RowNum, 4).Value, 4) BorderOn = Mid(t, 1, 1) = "1" UseFs = Mid(t, 2, 1) = "1" IndxCapFlag = Mid(t, 3, 1) = "1" CapOrderFlag = Mid(t, 4, 1) = "1" Path = Range("SSInputMatrix").Cells(RowNum, 5).Value Fldr = ExtractFilename(Path) If RowNum = 0 Then Sheets("SlideShows").Select Range("SSRowNum").Select MsgBox "You must select a Row Number to process.", vbCritical, "No Row!" Exit Sub End If If Len(Path) = 0 Then Sheets("SlideShows").Select Range("SSInputMatrix").Cells(RowNum, 5).Select MsgBox "There is no Path on the selected row.", vbCritical, "No Path!" Exit Sub ElseIf Not FileExists(Path) Then Sheets("SlideShows").Select Range("SSInputMatrix").Cells(RowNum, 5).Select MsgBox "There is an Invalid Path on the selected row (#" & RowNum & ")", vbCritical, "Invalid Path!" Exit Sub End If ' to get path to arrows, we look for a folder with arrow images ArrowPath = "" If Not FileExists(ConvertDotsToPath(Path, ArrowPath & "arrow_left.gif")) Then ArrowPath = "../images/" If Not FileExists(ConvertDotsToPath(Path, ArrowPath & "arrow_left.gif")) Then ArrowPath = "../" & ArrowPath If Not FileExists(ConvertDotsToPath(Path, ArrowPath & "arrow_left.gif")) Then ArrowPath = "../" & ArrowPath If Not FileExists(ConvertDotsToPath(Path, ArrowPath & "arrow_left.gif")) Then ArrowPath = "../" & ArrowPath End If End If End If End If ' we have optional captions ' data is stored under filename of web-sized image, but for original way is raw number CaptionFlag = FileExists(Path & "\Captions.txt") If CaptionFlag Then Captions = ReadInDelimData(Path & "\Captions.txt", "|") ElseIf IndxCapFlag Then MsgBox "Can't have Index Titles without having Captions", vbCritical, "No Captions.txt file" Exit Sub End If If CapOrderFlag And Not CaptionFlag Then MsgBox "Can't have Captions Order without having Captions", vbCritical, "No Captions.txt file" Exit Sub End If ' we may have optional heading and backlinks If FileExists(Path & "\Heading.txt") Then temp = ReturnFileAsArrayOfRows(Path & "\Heading.txt") ReDim Preserve temp(1) Heading = temp(0) BackLinks = temp(1) End If ' we have a default backlinks If BackLinks = "" Then S = ReadInFile(Path & "\index.htm") S = DropStr(S, InStr(S, """backlinks") + 11) S = Left(S, InStr(S, "") - 1) If PubType = "Pages" Then t = "Page" Else t = PubType End If BackLinks = S & " " & t & PubTypeSpacer & "Thumbnails →" End If ' we may have optional subheadings If FileExists(Path & "\Subheadings.txt") Then SubHeadList = ExtractDataNames(Path & "\Subheadings.txt") End If ' ~~~~~ option to use -f files instead of sequencially numbered. ~~~~~ If UseFs Then ' get list of thumbnail files in folder ListTPs = SelectJpgs(Path & "\images", "-tn") ' see what type of image files we have If Right(ListTPs(1), 4) = "webp" Then Ext = ".webp" Else Ext = ".jpg" End If ' format for numeric digits in page numbers (the htm page names need this) i = UBound(ListTPs) NumFmt = Left("000000", WorksheetFunction.Max(2, Len(Format(i + 1)))) ' page numbers v = Iota(i, 1) ReDim ListPs(i) ReDim ListWPs(i) ' when in caption order If CapOrderFlag Then ListRaw = ReturnColumn(Captions, 0) ' we have to check that images and entries in captions match For i = 0 To UBound(ListTPs) If Not IsMember(ListRaw, DropStr(ListTPs(i), -(3 + Len(Ext)))) Then MsgBox "An image file was not found in CaptionsText file:" & vbLf & vbLf & ListTPs(i), vbCritical, "Can't Index" Exit Sub End If Next i For i = 0 To UBound(ListRaw) If Not IsMember(ListTPs, ListRaw(i) & "-tn" & Ext) Then MsgBox "A row was found in CaptionsText file that has no image:" & vbLf & vbLf & ListRaw(i), vbCritical, "Can't Index" Exit Sub End If Next i Else ReDim ListRaw(UBound(ListTPs)) For k = 0 To UBound(ListRaw) ' extract raw file name (remove extension and -tn) S = ListTPs(k) S = DropStr(S, -(3 + Len(Ext))) ListRaw(k) = S Next k End If ' save all the names to use later For k = 0 To UBound(ListRaw) ListTPs(k) = "images/" & ListRaw(k) & "-tn" & Ext ListPs(k) = "images/" & ListRaw(k) & "-f" & Ext ListWPs(k) = "images/" & ListRaw(k) & Ext Next k ' ~~~~~ vector of page numbers (based on what we find on the drive) ~~~~~ Else ' find web-sized images v = SelectJpgs(Path & "\images", "tp") ' see what type of image files we have If Right(v(1), 4) = "webp" Then Ext = ".webp" Else Ext = ".jpg" End If ReDim ListRaw(UBound(v)) ReDim ListPs(UBound(v)) ReDim ListTPs(UBound(v)) ReDim ListWPs(UBound(v)) ' reduce to numbers For i = 0 To UBound(v) v(i) = DropStr(v(i), -Len(Ext)) v(i) = CInt(DropStr(v(i), 2)) Next i ' format for numeric digits in page numbers ' we do it this convoluted way, as we allow skipping numbers and highest could be above count NumFmt = Left("000000", WorksheetFunction.Max(2, Len(Format(v(UBound(v)))))) ' we build the raw file first, so we have something to match in captions file For i = 0 To UBound(v) ListRaw(i) = Format(v(i), NumFmt) Next i ' save all the names to use later For i = 0 To UBound(v) ListPs(i) = "images/" & "p" & ListRaw(i) & Ext ListTPs(i) = "images/" & "tp" & ListRaw(i) & Ext ListWPs(i) = "images/" & "wp" & ListRaw(i) & Ext Next i End If ' ~~~~~ thumbnail code for index page ~~~~~ ' loop for pictures (and create lots of little cells) For i = 0 To UBound(v) ' this left pads with 0's Fmt = Format(v(i), NumFmt) ' does this thumbnail have a title? If IndxCapFlag Then IndTitle = ReturnMatrixCell(Captions, ListRaw(i), 0, 1) End If ' our anchor string S = "" ' some have subheadings If Not IsEmpty(SubHeadList) Then temp = Iota2(SubHeadList, "p" & Fmt) If Not IsEmpty(temp) Then t = ExtractData(Path & "\Subheadings.txt", "p" & Fmt, 1) If Left(t, 4) = "
" & vbCrLf
End If
End If
' image alt string
' remove extra from front (all in front of dash)
k = InStr(T1, "-")
If 0 < k Then
T1 = DropStr(T1, k + 1)
End If
AltStr = " alt=""" & Replace(T1, """", """)
' most images these days get a border
If BorderOn Then
AltStr = AltStr & """ style=""border:1px solid;"
End If
MultiFlag = False
If UseFs Then
If Not FileExists(Path & "\" & ListWPs(i)) Then
MultiFlag = True
k = 1
tempP = DropStr(ListPs(i), -6) & "-" & k & "-f.jpg"
tempWP = DropStr(ListWPs(i), -Len(Ext)) & "-" & k & Ext
GoTo AddImages
End If
End If
' check for full-size image existence
tempP = ListPs(i)
tempWP = ListWPs(i)
' loop for images
AddImages:
S = Path & "\" & tempP
If FileExists(S) Then
SizeFS = GetImageSize(S)
' build image string
H = H & "" & vbCrLf
Else
H = H & "
" & vbCrLf
End If
' maybe more images
If MultiFlag Then
k = k + 1
tempWP = DropStr(ListWPs(i), -Len(Ext)) & "-" & k & Ext
If FileExists(Path & "\" & tempWP) Then
tempP = DropStr(ListPs(i), -7) & k & "-f.jpg"
H = H & "
" & vbCrLf
GoTo AddImages
End If
End If
' when using -f files, we like to know the file name
' If UseFs Then
' H = H & "
" & ListRaw(i) & vbCrLf
' End If
' save
SaveIfChanged Path & "\w" & Format(v(i), NumFmt) & ".htm", H & "" & vbCrLf
Next i
End Sub
_____________________________________________________________________________________
Private Function ConvertDotsToPath(ByVal WinPath As String, ByVal DotPath As String) As String
Dim n As Integer
Dim Locs As Variant
n = CountInString(DotPath, "../")
' convert from web slash to Windows slash
DotPath = Replace(DotPath, "/", "\")
If n = 0 Then
ConvertDotsToPath = WinPath & "\" & DotPath
Else
DotPath = DropStr(DotPath, 3 * n)
Locs = AllInStr(WinPath, "\")
WinPath = Left(WinPath, Locs(UBound(Locs) + 1 - n))
ConvertDotsToPath = WinPath & DotPath
End If
End Function
_____________________________________________________________________________________
Function GetSlideShowRow(RowRange As String, Optional PathFlag As Boolean, Optional RequireFlag As Boolean) As Variant
' can return path instead of default number
Dim Row As Integer
Dim Name As String
Row = Range(RowRange).Value
' we assume PathFlag is turned on
If RequireFlag And Row = 0 Then
Range(RowRange).Select
MsgBox "Must enter row number.", vbCritical, "Needs Input"
End
ElseIf Row = 0 Then
Name = InputBox("Path:", "Path")
If Name = "" Then End
GetSlideShowRow = Name
Exit Function
' we check quality of row number and album name existence
' -> we should implement fractions here
ElseIf Row < 1 Or Row > Range("SSInputMatrix").Rows.Count Then
Sheets("SlideShows").Select
Range(RowRange).Select
MsgBox "Must enter row number within range of input matrix: 1 to " & Range("SSInputMatrix").Rows.Count & ".", vbCritical, "Aborted!"
End
ElseIf 0 < InStr(Range(RowRange).Value, ".") Then
Sheets("SlideShows").Select
Range(RowRange).Select
MsgBox "Row Number must be Integer.", vbCritical, "Aborted!"
End
End If
If PathFlag Then
Name = Range("SSInputMatrix").Cells(Row, 5).Value
If Len(Name) = 0 Then
Sheets("SlideShows").Select
Range("SSInputMatrix").Cells(Row, 5).Select
MsgBox "Folder Path for selected row is empty.", vbCritical, "Aborted!"
End
End If
GetSlideShowRow = Name
Else
GetSlideShowRow = Row
End If
End Function
_____________________________________________________________________________________
Private Sub ViewSlideShowAlbum()
' is button on SlideShows sheet
ActiveWorkbook.FollowHyperlink GetSlideShowRow("SSRowNum", True) & "\index.htm"
End Sub
_____________________________________________________________________________________
Private Sub SortInputRangeSS()
' is button on SlideShows sheet
Range("SSInputMatrix").Sort Key1:=Range("F8")
Sheets("SlideShows").Select
End Sub
_____________________________________________________________________________________
Private Sub BuildSlideShowSitemap()
' is button on SlideShows sheet
CreateSiteMapFromOtherSheet GetSlideShowRow("SSRowNum", True)
End Sub
_____________________________________________________________________________________
Private Sub RunNavCodeForRow()
' is button on SlideShows sheet
AddNavCodeFromOtherSheet ExtractPath(GetSlideShowRow("SSRowNum", True), True)
End Sub
_____________________________________________________________________________________
Private Sub RenameToPxx()
' is button on SlideShows sheet
' reads *all* image files in folder and renames Pxx, or Pxxx
Dim i As Integer, StartNum As Integer
Dim Ext As String, f As String, Path As String, Prefix As String
Dim DumNames, FileNames As Variant
f = Range("SSRowNum").Value
If f = "" Or f = "0" Then
Path = InputBox("Path:", "Path")
If Path = "" Then Exit Sub
Else
Path = GetSlideShowRow("SSRowNum", True)
If vbOK <> MsgBox("Are you sure you want to rename ALL files in?" & vbLf & vbLf & ExtractFilename(Path), vbQuestion + vbOKCancel, "Confirmation Needed") Then
Exit Sub
End If
Path = Path & "\images"
End If
f = InputBox("Starting number:", "Number", 1)
If f = "" Then Exit Sub
StartNum = CInt(f)
' are these always in alpha order?
FileNames = ListFiles(Path, "jpg", False, True)
Ext = ".jpg"
Prefix = "\p"
If IsEmpty(FileNames) Then
FileNames = ListFiles(Path, "webp", False, True)
Ext = ".webp"
Prefix = "\wp"
End If
If IsEmpty(FileNames) Then
MsgBox "No jpg or webp files found in folder.", vbCritical, "No Files!"
Exit Sub
End If
If UBound(FileNames) > 98 Then
f = "000"
Else
f = "00"
End If
' we first have to loop and give all a dummy name (we could be reordering exisitng p00's)
ReDim DumNames(UBound(FileNames))
For i = 0 To UBound(FileNames)
DumNames(i) = ExtractPath(FileNames(i)) & "xx" & ExtractFilename(FileNames(i))
Name FileNames(i) As DumNames(i)
Next i
' loop to rename
For i = 0 To UBound(FileNames)
Name DumNames(i) As Path & Prefix & Format(i + StartNum, f) & Ext
Next i
End Sub
_____________________________________________________________________________________
Private Sub EditCaptions()
' button on SlideShows sheet
' if file doesn't exist, gives user the option of creating a new empty file
' if number of images has increased it adds to file bottom
Dim UseFs As Boolean
Dim Ct As Integer, k As Integer, LenExt As Integer, RowNum As Integer
Dim D As String, Ext As String, Path As String, PathName As String, res As String, S As String
Dim ListImgs As Variant
RowNum = GetSlideShowRow("SSRowNum", False, True)
PathName = Range("SSInputMatrix").Cells(RowNum, 5).Value & "\Captions.txt"
' we check if number of images has increased
If FileExists(PathName) Then
D = ReadInFile(PathName)
Ct = CountInString(D, "|")
' we give option of creating if file doesn't exist
Else
If vbOK <> MsgBox("File does not exist:" & vbLf & vbLf & PathName & vbLf & vbLf & "Click OK to create one.", vbCritical + vbOKCancel, "No File to Edit!") Then
Exit Sub
End If
D = ""
Ct = 0
End If
UseFs = Mid(Dec2Bin(Range("SSInputMatrix").Cells(RowNum, 4).Value, 2), 2, 1) = "1"
Path = Range("SSInputMatrix").Cells(RowNum, 5).Value
If UseFs Then
ListImgs = SelectJpgs(Path & "\images", "-tn")
Else
ListImgs = SelectJpgs(Path & "\images", "tp")
End If
If Ct > UBound(ListImgs) + 1 Then
MsgBox "You have fewer images than rows in the Captions file.", vbCritical, "Aborted"
Exit Sub
ElseIf Ct < UBound(ListImgs) + 1 Then
MsgBox 1 + UBound(ListImgs) - Ct & " rows were added to the Captions file.", vbCritical, "Updating..."
' length of file extension
LenExt = Len(ExtractExtension(ListImgs(1))) + 1
' strip to raw file name, which we use as row prefix. the original are just numbers
For k = Ct To UBound(ListImgs)
S = ListImgs(k)
If UseFs Then
S = DropStr(S, -(3 + LenExt))
Else
S = DropStr(S, -LenExt)
S = DropStr(S, 2)
End If
res = res & S & "|" & vbCrLf
Next k
SaveFile PathName, D & res
End If
CallNotepad PathName
End Sub
_____________________________________________________________________________________
Private Sub FindUnusedCaptions()
' button on SlideShows sheet
Dim UseFs As Boolean
Dim i As Integer, j As Integer, RowNum As Integer
Dim Path As String, PathName As String, res As String
Dim Captions, FileList As Variant
RowNum = GetSlideShowRow("SSRowNum")
Path = GetSlideShowRow("SSRowNum", True)
PathName = Path & "\Captions.txt"
If FileExists(PathName) Then
Captions = SortMatrix(ReadInDelimData(PathName, "|"), 0)
' find images
If FileExists(Path & "/images") Then
Path = Path & "/images"
End If
UseFs = Mid(Dec2Bin(Range("SSInputMatrix").Cells(RowNum, 4).Value, 4), 3, 1) = "1"
If UseFs Then
FileList = SelectJpgs(Path, "-")
For i = 0 To UBound(FileList)
FileList(i) = DropStr(FileList(i), -4)
Next i
Else
FileList = SelectJpgs(Path, "wp")
For i = 0 To UBound(FileList)
FileList(i) = FileList(i)
FileList(i) = DropStr(FileList(i), -4)
FileList(i) = DropStr(FileList(i), 2)
Next i
End If
' loop to check
For i = 0 To UBound(Captions)
For j = 0 To UBound(FileList)
If Captions(i, 0) = FileList(j) Then GoTo Found
Next j
res = res & vbLf & Captions(i, 0) & "|" & Captions(i, 1)
Found:
Next i
If res <> "" Then
MsgBox "Unused Captions:" & vbLf & res, vbInformation, "Not Used"
End If
Else
MsgBox "File does not exist:" & vbLf & vbLf & PathName & vbLf & vbLf & "Use SlideShow Option Usage button to find which shows have Caption files.", vbCritical, "No File to Check!"
End If
End Sub
_____________________________________________________________________________________
Private Sub SortCaptions()
' button on SlideShows sheet
Dim PathName As String
Dim Captions As Variant
PathName = GetSlideShowRow("SSRowNum", True) & "\Captions.txt"
If FileExists(PathName) Then
Captions = SortMatrix(ReadInDelimData(PathName, "|"), 0)
SaveIfChanged PathName, ArrayToDelimString(Captions, "|")
Else
MsgBox "File does not exist:" & vbLf & vbLf & PathName & vbLf & vbLf & "Use SlideShow Option Usage button to find which shows have Caption files.", vbCritical, "No File to Sort!"
End If
End Sub
_____________________________________________________________________________________
Private Sub OpenSSFolder()
' button on SlideShows sheet
CallExplorer GetSlideShowRow("SSRowNum", True)
End Sub
____________________________________________________________________________________