" & 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
____________________________________________________________________________________