Option Explicit Public CancelFlag As Boolean, Pflg As Boolean Public PicCount As Long Public AllErrors As String _____________________________________________________________________________________ Private Sub BuildAlbum() ' is button on Pics sheet ' --> needs all edits now in the Edit data variable functions Dim Name As String Pflg = False Name = GetAlbumName BuildAlbumSub PicPath(Name), Name, Range("PicIndFlag").Value, Range("PicHtmFlag").Value If PicDataExists(Name, "i") Then BuildAlbumSub PicPath(Name), Name, Range("PicIndFlag").Value, Range("PicHtmFlag").Value, False, True End If End Sub _____________________________________________________________________________________ Sub BuildAllAlbums() ' is button on Pics sheet. also also called by Foraging Pictures button on Dashboard ' do not insert columns on sheet Dim Okay As Boolean Dim i As Integer Dim Filter As String, Name As String Pflg = False Filter = Range("PicFilter").Value AllErrors = "" For i = 1 To Range("PicInputMatrix").Rows.Count Name = Range("PicInputMatrix").Cells(i, 4).Value IsAlbumName Name If Name <> "" Then Okay = True If Len(Filter) > 0 Then If Filter = "v" Then If Left(GetFromPicMat(Name, 3), 1) <> "v" Then Okay = False Else If 0 = InStr(Name, Filter) Then Okay = False End If End If If Okay Then BuildAlbumSub PicPath(Name), Name, Range("PicIndFlag").Value, Range("PicHtmFlag").Value, True If PicDataExists(Name, "i") Then BuildAlbumSub PicPath(Name), Name, Range("PicIndFlag").Value, Range("PicHtmFlag").Value, False, True End If End If End If Next i If 0 < Len(AllErrors) Then MsgBox "Errors found when processing:" & vbLf & vbLf & DropStr(AllErrors, -2), vbExclamation, "Error Report" End If End Sub _____________________________________________________________________________________ Sub BuildAlbumSub(ArgPath As String, ByVal PicD As String, IndFlag As Boolean, HtmFlag As Boolean, Optional AllFlag As Boolean, Optional I2flg As Boolean) ' does not delete files first. If number reduced, manually delete greater numbers ' ArgPath has to have trailing backslash ' PicD is folder name, and also plant name when plants ' reads: Pflg, PlantList, PlantListWO ' args: 1-Local Save Path, 2-album/plant name, 3-IndFlag, 4-HtmFlag, Opt: 5-AllFlag, 6-I2flg ' AllFlag - collect errors instead of reporting them immediately ' I2flg - boolean and returns straight numbers, only when there is a Custom Index ' Pflg - plant flag Dim b As Boolean, CIflg As Boolean, InlineFlag As Boolean Dim NavCodeFlag As Boolean, Vflg As Boolean, WebSizeFlag As Boolean Dim i As Integer, j As Integer, k As Integer, n As Integer, subI As Integer Dim ATitle As String, CatCode As String, f As String, H As String, HtmLink As String Dim IconPath As String, ImgLink As String, LocalGetPath As String, LocalSavePath, P As String, RetLinks As String, S As String Dim TTitle As String, t As String, WebGetPath As String Dim NextAlbum As String, NextAlbumStr As String, NextFN As String, NextGif As String, NextFT As String Dim PrevFN As String, PrevGif As String, PrevFT As String Dim FileList, Ind, IndWO, PD, PDwo, PicTitles, PIs, res, SecTitles, SubTitles As Variant IconPath = "../icons/" DoEvents Application.StatusBar = "Processing " & PicD & "..." If Not Pflg Then CatCode = GetFromPicMat(PicD, 3) Vflg = Left(CatCode, 1) = "v" End If ' ~~ our get and save paths LocalSavePath = ArgPath & Replace(PicD, " ", "_") If Pflg Then LocalGetPath = PicPath WebGetPath = "../../tours/" ElseIf Vflg Then LocalGetPath = ArgPath WebGetPath = "../" Else LocalGetPath = LocalSavePath End If ' ~~ get list of files for virtual and regular albums If Pflg Then FileList = GetPicData("temp", "list") Vflg = True Else If Vflg Then CatCode = DropStr(CatCode, 1) If Not PicDataExists(PicD, "list", AllFlag) Then Exit Sub FileList = GetPicData(PicD, "list") Else FileList = PicsInAlbum(LocalGetPath, AllFlag) If IsEmpty(FileList) Then Exit Sub End If End If n = UBound(FileList) ' ~~ we get titles If Pflg Then ' ATitle is used for: index tags and index page heading section ATitle = PlantList(Iota2(PlantListWO, PicD), 1) ' TTitle is used for: htm <title> tags and page titles TTitle = ATitle Else ATitle = GetAI(PicD, 1, AllFlag) TTitle = "Album: " & ATitle End If ' ~~ add text on Foraging albums If "F-" = Left(PicD, 2) Then ' PlantList = ReturnFileAsArrayOfRows(ForagPath & "\PlantList.txt") PlantList = GetFixedData(ForagPath & "\PlantList.txt", 3) PIs = GetPicData(PicD, "pi") End If ' ~~ do we have an optional custom index file? If Pflg Or (PicDataExists(PicD, "i") And Not I2flg) Then If Pflg Then res = GetCustIndex("temp", n) Else res = GetCustIndex(PicD, n) End If Ind = res(0) IndWO = res(1) CIflg = True Else ' not custom index Ind = Iota(n, 1) IndWO = Ind CIflg = False End If ' get picture text data ReDim PDwo(UBound(FileList)) If Vflg Then ReDim PD(UBound(FileList)) For i = 0 To UBound(PD) PD(i) = GetPicData(PicD, FileList(i)) Next i Else If Not PicDataExists(PicD, "pd", AllFlag) Then Exit Sub PD = GetPicData(PicD, "pd") End If ReDim PDwo(UBound(PD)) ' check if we have enough entries for pictures If n > UBound(PD) Then S = "There are more pictures than entries in the pd_" & PicD & ".txt file. Can't process." If AllFlag Then AllErrors = AllErrors & S & vbLf & vbLf Else Application.StatusBar = False MsgBox S, vbCritical, "Aborted!" End If Exit Sub End If ' ~~ clean up and add special text For i = 0 To UBound(PD) S = PD(i) ' we need to put a stop to the bold in the middle after the name and address j = InStr(S, "<br>") If j > 0 Then j = j - 1 S = "<strong>" & Left(S, j) & "</strong>" & DropStr(S, j) End If ' check for italics S = Replace(S, "<i>", "<span class=""italic"">") S = Replace(S, "</i>", "</span>") ' for virtual albums we tack on the source album location, but in-line index cells want without PDwo(i) = S & vbCrLf If Vflg Then ' list of pictures included ' but for plants we give them a short date for the inline index page (Pflg is only inline) If Pflg Then PDwo(i) = S & AlbumLocation(PicD, FileList(i), WebGetPath, True) & vbCrLf End If ' full link and full date S = S & AlbumLocation(PicD, FileList(i), WebGetPath, False) & vbCrLf ' or for foraging album we add scientific name ElseIf "F-" = Left(PicD, 2) Then S = S & ScientificName(PlantList, PIs(i)) & vbCrLf S = S & PlantLink(PlantList, PIs(i)) & vbCrLf End If PD(i) = S Next i If Not IndFlag Then GoTo Htm ' ~~~~~~~~~~~~~~~~~~~~ index file ~~~~~~~~~~~~~~~~~~~~ ' do we have picture titles? If PicDataExists(PicD, "pt") Then PicTitles = GetPicData(PicD, "pt") If UBound(PicTitles) <> UBound(FileList) Then Application.StatusBar = False MsgBox "Number of entries in the pt_" & PicD & ".txt file (" & UBound(PicTitles) + 1 & ") does not match number of pictures (" & UBound(FileList) + 1 & ").", vbCritical, "Aborted!" End End If Else PicTitles = Empty End If ' we have two methods of displaying thumbnails on the index page. new, and most, are inline-block If Pflg Then InlineFlag = True Else InlineFlag = GetFromPicMat(PicD, 2) <> "1" Or Not IsEmpty(PicTitles) End If ' we may have section breaks with section titles in brks_ files ' this is one of two ways to get sub-titles on the index page. original was sub_ If PicDataExists(PicD, "brks") Then SecTitles = GetPicData(PicD, "brks") Else SecTitles = Empty End If '~~~ start building index page ' ~~~ navigation links (built up front, as we need to know whether there is nav code or not) If Pflg Then ' our master list of the different plants - without botanic name i = Iota2(PlantListWO, PicD) If i = UBound(PlantListWO) Then NextAlbum = PlantListWO(0) Else NextAlbum = PlantListWO(i + 1) End If NextAlbum = Replace(NextAlbum, " ", "_") NextFN = NextAlbum If i = 0 Then PrevFN = PlantListWO(UBound(PlantListWO)) Else PrevFN = PlantListWO(i - 1) End If PrevFN = Replace(PrevFN, " ", "_") Else ' full album name NextAlbum = GetFromPicMat(PicD, 5) NextFN = Replace(NextAlbum, " ", "_") For i = 1 To Range("PicInputMatrix").Rows.Count If Range("PicInputMatrix").Cells(i, 5).Value = PicD Then PrevFN = Range("PicInputMatrix").Cells(i, 4).Value GoTo FoundAlbum End If Next i FoundAlbum: End If NavCodeFlag = PrevFN <> "" Or NextFN <> "" ' head section of index page H = "<!DOCTYPE html>" & vbCrLf H = H & "<html lang=""en""><head>" & vbCrLf H = H & "<meta charset=""UTF-8"">" & vbCrLf H = H & "<title>" & ATitle & "" & vbCrLf S = GetAI(PicD, 5) If 0 < Len(S) Then H = H & "" & vbCrLf End If H = H & "" & vbCrLf S = GetAI(PicD, 3) If 0 < Len(S) Then H = H & "" & vbCrLf End If If I2flg Then H = H & "" & vbCrLf End If H = H & "" & vbCrLf H = H & "" & vbCrLf If Not NavCodeFlag Then H = H & "" & vbCrLf End If ' when float:left we need to set the width of the first column, so all are uniform If (Not InlineFlag) And (n > 99) Then H = H & "" & vbCrLf End If H = H & "" & vbCrLf H = H & "
" & vbCrLf & vbCrLf ' ~~~ return links for index page If Pflg Then t = "#" & PlantList(Iota2(PlantListWO, PicD), 0) Else t = "" End If H = H & "
Home Page" H = H & " → List of " If Pflg Then H = H & "Plants" ElseIf Left(PicD, 2) = "F-" Then H = H & "Tours" Else H = H & "Albums" End If H = H & " → " ' add link when we have a group page (Majors don't have pages) If CatCode <> "" Then If GetCatInfo(CatCode, 6) <> "" Then H = H & "" & GetCatInfo(CatCode, 3) & " →" End If End If H = H & "
" & vbCrLf & vbCrLf ' ~~~ navigation code for index page If NavCodeFlag Then H = H & "
" & vbCrLf & "
" If 0 < Len(PrevFN) Then H = H & "← " & GetAI(PrevFN, 1) & "" End If H = H & "
" & vbCrLf H = H & "
" If 0 < Len(NextFN) Then H = H & "" & GetAI(NextFN, 1) & " →" End If H = H & "
" & vbCrLf & "
" & vbCrLf & vbCrLf End If ' ~~~ index page heading section H = H & "
" & ATitle & "
" & vbCrLf & vbCrLf & "
" & vbCrLf & "
" & vbCrLf & vbCrLf ' album/plant description If Pflg Then Else H = H & GetAI(PicD, 2) & "

" & vbCrLf ' ~~ extra table of contents when sub titles (more than one) If PicDataExists(PicD, "sub") And Not I2flg Then ' must have the number of rows equal to the number of 0s SubTitles = GetPicData(PicD, "sub") If UBound(Ind) - UBound(Without(Ind, "0")) <> UBound(SubTitles) + 1 Then MsgBox "Number of rows in sub_" & PicD & " file must equal number of 0's in i_" & PicD & " file.", vbCr, "Aborted!" End End If S = "

" End If H = H & vbCrLf & "

" & vbCrLf & vbCrLf End If ' ~~ body of index For i = 0 To n ' thumbnail image source If Vflg Then S = FileList(Ind(i) - 1) ImgLink = DropStr(S, -4) & "tn" & Right(S, 4) Else ImgLink = "tn" & Format(Ind(i), "0000") End If ' HTM link for behind thumbnail HtmLink = """" HtmLink = HtmLink & "h" & Format(Ind(i), "0000") If I2flg Then HtmLink = HtmLink & "b" HtmLink = HtmLink & ".htm"">" ' ~~~~ two ways to display thumbnails. the new is inline cells ~~~~ If InlineFlag Then ' check for a section break and optional title - alternate method (only title in file and HTML code is here) If Ind(i) = 0 Then ' print sub-titles H = H & "
" If i <> 0 Then H = H & vbCrLf & "
" & vbCrLf End If H = H & SubTitles(subI) subI = subI + 1 H = H & "
" & vbCrLf & vbCrLf GoTo EndInlineEntry End If ' check for a section break and optional title (these are files starting with brks_, which have single lines per pic) If Not IsEmpty(SecTitles) Then For j = 0 To UBound(SecTitles, 1) If Ind(i) = SecTitles(j, 0) Then If i <> 0 Then H = H & "
" & vbCrLf & vbCrLf End If If SecTitles(j, 1) <> "" Then H = H & "
" & SecTitles(j, 1) & "
" & vbCrLf End If End If Next j End If ' we find the thumbnail width res = GetImageSize(LocalGetPath & "\" & ImgLink & ".jpg") j = res(0) If j < 200 Then j = 200 ' test for really long text and needing more than 200 px wide k = Len(PD(Ind(i) - 1)) ' -> this could have an intermediate If k > 250 Then j = 320 End If ' code for cell H = H & "
" & vbCrLf ' see if this album has a pt_ file (to use as headers for the thumbnails. all HTML code is in file) If Not IsEmpty(PicTitles) Then H = H & PicTitles(Ind(i) - 1) Else H = H & Ind(i) & ": " & ClipStringNBSP(RemoveHTML(PDwo(Ind(i) - 1))) End If H = H & "" & vbCrLf H = H & "
" & vbCrLf & vbCrLf EndInlineEntry: If i = n Then H = H & "
" & vbCrLf & vbCrLf End If Else ' ~~~~ float left (the original and default) ~~~~ If Ind(i) = 0 Then ' print sub-titles H = H & "
" & SubTitles(subI) subI = subI + 1 H = H & "
" GoTo EndEntry End If H = H & "" & vbCrLf ' picture number and link ' original link when we had span.first col implemented ' H = H & "" & vbCrLf ' kludge to replace. very poor substitute ' floorborders implements this correctly If Ind(i) < 9 Then H = H & "   " ElseIf Ind(i) < 99 Then H = H & "  " Else H = H & " " End If H = H & vbCrLf ' thumbnail and link H = H & "" & vbCrLf ' album description H = H & PD(Ind(i) - 1) & vbCrLf EndEntry: H = H & "
" & vbCrLf & vbCrLf End If Next i ' ~~~~ clean up If Pflg Then t = Mid(FileList(0), 3, 4) & "-" & Year(Date) Else t = CopyrightSpan(GetAI(PicD, 4)) End If H = H & "

© " & AuthorName & " " & t & ". All rights reserved." & vbCrLf H = H & vbCrLf & "" & vbCrLf f = LocalSavePath & "\index" If I2flg Then f = f & "2" SaveIfChanged f & ".htm", H ' ~~~~~~~~~~ htm files ~~~~~~~~~~ ' ~~~~~~~~~~ htm files ~~~~~~~~~~ Htm: If Not HtmFlag Then GoTo CleanUp Ind = IndWO ' ~~ loop for files For i = 0 To n f = Format(Ind(i), "0000") ' file names of adjacent pages for navigation code If i = 0 Then PrevFN = Ind(n) PrevGif = "double_" PrevFT = "Last picture" Else PrevFN = Ind(i - 1) PrevGif = "" PrevFT = "Previous picture" End If PrevFN = "h" & Format(PrevFN, "0000") If I2flg Then PrevFN = PrevFN & "b" PrevFN = PrevFN & ".htm" NextAlbumStr = "" If i = n Then NextFN = Ind(0) NextGif = "double_" NextFT = "First picture" ' if we are on last picture and there is a next album we add another icon If NextAlbum <> "" Then NextAlbumStr = "  " & vbCrLf & "" End If Else NextFN = Ind(i + 1) NextGif = "" NextFT = "Next picture" End If NextFN = "h" & Format(NextFN, "0000") If I2flg Then NextFN = NextFN & "b" NextFN = NextFN & ".htm" ' create htm file head section H = "" & vbCrLf H = H & "" & vbCrLf H = H & "" & vbCrLf H = H & "" If Not Pflg Then H = H & "Photo: " & Ind(i) If Not CIflg Then H = H & " of " & (n + 1) H = H & ", " End If H = H & TTitle & "" & vbCrLf If I2flg Then H = H & "" & vbCrLf H = H & "" & vbCrLf H = H & "" & vbCrLf H = H & "" & vbCrLf & vbCrLf ' arrow code H = H & "

  " & vbCrLf H = H & "  " & vbCrLf H = H & "" H = H & NextAlbumStr & "
" & vbCrLf ' page title H = H & vbCrLf & "
Photo: " & Ind(i) & "" If Not CIflg Then H = H & " of " & (n + 1) H = H & ", " & TTitle & "
" & vbCrLf & vbCrLf ' description H = H & PD(Ind(i) - 1) & vbCrLf ' ~~ picture and its path for htm ' when virtual and plants we need to build links If Vflg Then S = Left(FileList(Ind(i) - 1), InStr(FileList(Ind(i) - 1), "/") - 1) f = Right(FileList(Ind(i) - 1), 4) End If If Pflg Then ImgLink = WebGetPath & S & "/" & f ElseIf Vflg Then ImgLink = f If PicD <> S Then ImgLink = "../" & S & "/" & ImgLink End If Else ImgLink = f S = "" End If ' check for web-size image existence WebSizeFlag = FileExists(LocalGetPath & S & "\w" & f & ".jpg") ' when we have a web-size, we call it instead If WebSizeFlag Then t = "\w" Else t = "\" End If ' for wide pictures we don't fit to page width (panoramas get mashed), so they get a special class res = GetImageSize(LocalGetPath & S & t & f & ".jpg") If 1200 < res(0) Then P = " class=""widepic""" Else P = "" End If ' ~~ build image string for htm If WebSizeFlag Then ' web-size image exists (in addition to the master image). so we need size of master image res = GetImageSize(LocalGetPath & S & "\" & f & ".jpg") If Vflg Then t = DropStr(ImgLink, -4) & "w" & Right(ImgLink, 4) Else t = "w" & Right(ImgLink, 4) End If H = H & "

" & vbCrLf Else ' only one size of image H = H & "

" & vbCrLf End If H = H & vbCrLf ' wrap up and save H = H & "" & vbCrLf f = LocalSavePath & "\h" & Format(Ind(i), "0000") If I2flg Then f = f & "b" SaveIfChanged f & ".htm", H Next i CleanUp: Application.StatusBar = False End Sub _____________________________________________________________________________________ Private Sub BuildTopMenu() ' builds core code index.htm file for album list Dim i As Integer, j As Integer Dim Ct As Long Dim f As String, H As String, PicD As String, t As String Dim Ind, MajorGrps, res As Variant Pflg = False MajorGrps = GetCatFilenames(True) PicCount = 0 H = "" ' loop for Major Groups For i = 0 To UBound(MajorGrps) DoEvents Application.StatusBar = "Processing " & MajorGrps(i) & "..." ' check if we have optional label t = GetCatInfo(MajorGrps(i), 3, 2) If t = "" Then t = MajorGrps(i) End If If i <> 0 Then H = H & vbCrLf & "

" & vbCrLf & vbCrLf End If ' the category heading H = H & "
" & t & "
" & vbCrLf & "
" & vbCrLf ' get group members res = GetCatMembers(MajorGrps(i)) ' sort index by full title Ind = CatSortVector(res) ' get member's info For j = 0 To UBound(res) H = H & AlbumRecord(res(Ind(j))) Next j Next i ' save f = PicPath & "index.htm" InsertIntoHtm f, H & vbCrLf ' ~~ above count was a mix of real and virtual. we want this to be a real count Ct = 0 For i = 1 To Range("PicInputMatrix").Rows.Count PicD = Range("PicInputMatrix").Cells(i, 4).Value If PicD <> "" Then DoEvents Application.StatusBar = "Counting pictures in: " & PicD & "..." ' skip private albums t = Range("PicInputMatrix").Cells(i, 3).Value If t <> "" Then res = PicsInAlbum(PicPath(PicD) & PicD) If Not IsEmpty(res) Then Ct = Ct + UBound(res) + 1 End If End If End If Next i ' update index file heading count H = ReadInFile(f) t = AuthorName & "'s Photo Albums (" i = Len(t) + InStr(H, t) - 1 j = InStr(DropStr(H, i), " ") t = Left(H, i) & Format(Ct, "#,##0") & DropStr(H, i + j - 1) SaveIfChanged f, t, H Application.StatusBar = False End Sub _____________________________________________________________________________________ Private Sub BuildCategoryMenus() Dim AlphaSortFlag As Boolean, I2flg As Boolean ' SeasonSortFlag As Boolean Dim Char2Drop As Integer, i As Integer, j As Integer, k As Integer Dim ATitle As String, Bod As String, f As String, H As String Dim NavCode As String, NextFN As String, PrevFN As String Dim CatNames, FileNames, Ind, IndA, IndD, IndS, Titles As Variant Pflg = False ' get list of categories (in order of Top menu) CatNames = GetCatFilenames(False) ' create css file H = "/* Generated by the BuildCategoryMenus VBA macro */" & vbCrLf H = H & ".navbar {width:100%; padding:0; display:flex; flex-wrap:wrap; justify-content:space-between; white-space:nowrap;" & vbCrLf H = H & " padding-top:0.5em; width:calc(100vw - 32px);}" & vbCrLf H = H & ".right {margin-left:auto;}" & vbCrLf & vbCrLf H = H & "body {padding-top:6em;}" & vbCrLf H = H & "@media (max-width:725px) { body {padding-top:7em;} }" & vbCrLf H = H & ".sticky {position:fixed; top:0; width:100%; background:white;}" & vbCrLf H = H & ".backlinks {margin-top:0.5em;}" & vbCrLf H = H & ".title {font-size:130%; text-align:center; font-weight:bold; margin-top:0.5em; width:calc(100vw - 32px);}" & vbCrLf & vbCrLf H = H & "span.bigbold {font-size:120%; font-weight:bold;}" & vbCrLf SaveIfChanged PicPath & "catmenus.css", H ' loop for CatNames For i = 0 To UBound(CatNames) ' group title ATitle = GetAI(CatNames(i), 1) Application.StatusBar = "Processing " & Replace(ATitle, "&", "&") & "..." ' initial default sort choice f = UCase(GetCatInfo(CatNames(i), 4, 2)) AlphaSortFlag = f = "A" ' SeasonSortFlag = f = "S" ' category members FileNames = GetCatMembers(CatNames(i)) If IsEmpty(FileNames) Then MsgBox "No members of " & CatNames(i) & " were found.", vbExclamation, "Category Skipped" GoTo EndLoop End If ' get all the titles for the alpha sort ReDim Titles(UBound(FileNames)) For j = 0 To UBound(FileNames) Titles(j) = GetAI(FileNames(j), 1) If Left(Titles(j), 4) = "The " Then Titles(j) = DropStr(Titles(j), 4) End If Next j ' navigation links If i = 0 Then PrevFN = CatNames(UBound(CatNames)) Else PrevFN = CatNames(i - 1) End If If i = UBound(CatNames) Then NextFN = CatNames(0) Else NextFN = CatNames(i + 1) End If NavCode = "
" & vbCrLf & "
" NavCode = NavCode & "← " & GetAI(PrevFN, 1) & "" NavCode = NavCode & "
" & vbCrLf NavCode = NavCode & "
" NavCode = NavCode & "" & GetAI(NextFN, 1) & " →" NavCode = NavCode & "
" & vbCrLf & "
" & vbCrLf & vbCrLf Char2Drop = 0 ' we have two major sorts IndA = GradeUp(Titles) IndD = DateSortAlbums(FileNames) ' ~~ build two or three copies of the index page, with different sorts For j = 0 To 1 I2flg = j = 1 PicCount = 0 ' ~~ we build the body first, as we need it to get count of pictures ' choose sort vector and code/label to the other sort H = "Now in " ' the string in the middle f = ". Change sort to: Sort" & f & CatNames(i) & ".htm"">Alpha" Else Ind = IndA H = H & "Alpha Sort" & f & CatNames(i) & "-2.htm"">Descending Date" End If ' default: descending date as primary, alpha second Else If I2flg Then Ind = IndA H = H & "Alpha Sort" H = H & f & CatNames(i) & ".htm"">Descending Date" Else Ind = IndD H = H & "Descending Date Sort" H = H & f & CatNames(i) & "-2.htm"">Alpha" End If End If H = H & "" & vbCrLf & vbCrLf & "
" & vbCrLf ' get album for each member For k = 0 To UBound(FileNames) H = H & AlbumRecord(FileNames(Ind(k)), Char2Drop) Next k ' save to use later Bod = H ' heading H = "" & vbCrLf H = H & "" H = H & "" & vbCrLf H = H & "" & vbCrLf H = H & "" & ATitle & "" & vbCrLf H = H & "" & vbCrLf H = H & "" & vbCrLf If I2flg Then H = H & "" & vbCrLf End If H = H & "" & vbCrLf H = H & "" & vbCrLf H = H & "" & vbCrLf H = H & "
" & vbCrLf & vbCrLf ' start body H = H & "
Home Page → " & AuthorName & " Picture Albums →
" & vbCrLf & vbCrLf ' add navigation H = H & NavCode ' page heading H = H & "
" & ATitle & "
" & vbCrLf & vbCrLf ' add description string H = H & "
" & vbCrLf & "
" & vbCrLf & vbCrLf H = H & GetAI(CatNames(i), 2) & " There are " & Format(PicCount, "#,##0") & " pictures in this category." H = H & vbCrLf & "

" & vbCrLf ' the body H = H & Bod ' stuff at the bottom, below

H = H & vbCrLf & "
" & vbCrLf & "

" & vbCrLf H = H & "

© " & CopyrightSpan(GetAI(CatNames(i), 4)) & " " & AuthorName & ". All rights reserved." & vbCrLf H = H & vbCrLf & "" & vbCrLf ' save f = PicPath(, GetCatInfo(CatNames(i), 5, 2)) & CatNames(i) If I2flg Then f = f & "-2" SaveIfChanged f & ".htm", H Next j EndLoop: Next i Application.StatusBar = False End Sub _____________________________________________________________________________________ Function DateSortAlbums(ByVal FileNames As Variant, Optional AscFlag As Boolean) As Variant ' returns an index vector with the specified albums in descending date order Dim i As Integer Dim DateVec As Variant ReDim DateVec(UBound(FileNames)) ' loop for files and get dates For i = 0 To UBound(FileNames) DateVec(i) = GetAI(FileNames(i), 4, True) Next i If AscFlag Then DateSortAlbums = GradeUp(DateVec) Else DateSortAlbums = GradeUp(DateVec, , , , True) End If End Function _____________________________________________________________________________________ Function AlbumRecord(ByVal PicD As String, Optional ByVal TitChar2Drop As Integer) As Variant ' returns html code for an album entry in list of albums. used to build Top and Categories menus ' PicD argument can be an album name or Category name ' SameDirFlag for PicD to be at same directory level. default is directory which is below this. ' TitChar2Drop drops from titles that are repetitious Dim bool As Boolean, CatFlg As Boolean Dim Char2Drop As Integer, i As Integer, j As Integer, MaxTitLen As Integer, n As Integer Dim a As String, Cap As String, H As String, Path As String, S As String, Suff As String Dim FileList, Ind, Titles As Variant Suff = "" ' is this a Category? CatFlg = IsMember(GetCatFilenames(False), PicD) If CatFlg Then ' get all album names FileList = GetCatMembers(PicD) ' album name If UBound(FileList) > 0 Then Suff = " in " & UBound(FileList) + 1 & " albums" End If ' path to the folder for this record Path = a & PicD & ".htm" Else Path = a & PicD & "/" End If ' the link and album title n = CountPics(PicD) PicCount = PicCount + n S = GetAI(PicD, 1) S = DropStr(S, TitChar2Drop) H = vbCrLf & "

" & S & " (" & Format(n, "#,##0") & " pictures" & Suff & ")
" & vbCrLf ' caption S = GetAI(PicD, 2) S = Replace(S, """../pictures/", """") S = Replace(S, """../", """") H = H & "

" & S If CatFlg Then ' get all titles ReDim Titles(UBound(FileList)) For i = 0 To UBound(FileList) Titles(i) = GetAI(FileList(i), 1) Next i ' if titles are all the same except for the year (last four characters) and then we skip listing sub albums ' alternatively this could look at first 2 characters, but that would also kick out the foraging walk albums bool = True S = DropStr(Titles(0), -4) For i = 1 To UBound(Titles) If Len(Titles(i)) > 5 Then bool = bool And S = DropStr(Titles(i), -4) End If Next i ' ~~~ add sub-albums If Not (Range("RemDupYears").Value And bool) Then ' get all the titles, and find the length of the longest ReDim SortTitles(UBound(FileList)) MaxTitLen = 0 For i = 0 To UBound(FileList) ' Titles(i) = GetAI(FileList(i), 1) ' we need to calculate width of column S = StripEscChars(Titles(i)) If Len(S) > MaxTitLen Then MaxTitLen = Len(S) Next i ' can we remove all the same from fronts? (the names that would be reduced to just the year aren't in here) If Not bool Then Char2Drop = CountOfRepChars(Titles) End If ' convert characters to em's MaxTitLen = WorksheetFunction.RoundDown((MaxTitLen - Char2Drop) / 2, 0) ' create sort index vector Ind = CatSortVector(FileList) ' loop for sub albums, adding to the string H = H & vbCrLf & vbCrLf & "

" End If End If AlbumRecord = H & vbCrLf End Function _____________________________________________________________________________________ Function CountPics(ByVal PicD As String) As Long ' counts the number of pictures in given album Dim i As Integer Dim CatCode As String, S As String ' if virtual (these aren't real pictures, but needed for here) If Left(GetFromPicMat(PicD, 3), 1) = "v" Then CountPics = UBound(GetPicData(PicD, "list")) + 1 ' when a Cat Code we get count of all members ElseIf GetCatInfo(PicD, 1, 2) <> "" Then CatCode = GetCatInfo(PicD, 1, 2) For i = 0 To Range("PicInputMatrix").Rows.Count If Range("PicInputMatrix").Cells(i, 3).Value = CatCode Then S = Range("PicInputMatrix").Cells(i, 4).Value CountPics = CountPics + UBound(PicsInAlbum(PicPath(S) & S)) + 1 End If Next i ' everybody else - the albums Else CountPics = UBound(PicsInAlbum(PicPath(PicD) & PicD)) + 1 End If End Function _____________________________________________________________________________________ Function GetCatMembers(ByVal CatFilename As String) As Variant ' returns list of albums that are in that category ' input is never a major group Dim i As Integer, n As Integer Dim CatCode As String, R As String, S As String Dim res As Variant n = Range("PicInputMatrix").Rows.Count ReDim res(n) ' convert Cat filename to Cat Code CatCode = GetCatInfo(CatFilename, 1, 2) ' loop for direct member albums For i = 1 To n S = Range("PicInputMatrix").Cells(i, 3).Value If S <> "" Then If Left(S, 1) = "v" Then S = DropStr(S, 1) End If If CatCode = S Then res(i) = Range("PicInputMatrix").Cells(i, 4).Value End If End If Next i res = RemoveEmptiesInVector(res) ' check for quality AllErrors = "" For i = 0 To UBound(res) R = res(i) If Not PicDataExists(R, "ai", True) Then res(i) = Empty End If If Left(GetFromPicMat(R, 3), 1) = "v" Then S = "list" Else S = "pd" End If If Not PicDataExists(R, S, True) Then res(i) = Empty End If Next i If 0 < Len(AllErrors) Then res = RemoveEmptiesInVector(res) Application.StatusBar = False MsgBox "Errors found when processing:" & vbLf & vbLf & DropStr(AllErrors, -2), vbExclamation, "Error Report" End End If GetCatMembers = AppendVectors(CatsInMajor(CatCode), res) End Function _____________________________________________________________________________________ Function CatsInMajor(ByVal MajorCode As String) As Variant ' arg is code as, like a Cat Code ' returns vector Cat files, which can be used to find albums that are members Dim i As Integer Dim res As Variant i = Range("CatMat").Rows.Count ReDim res(i) For i = 1 To i If Range("CatMat").Cells(i, 6).Value = MajorCode Then res(i) = Range("CatMat").Cells(i, 2).Value End If Next i CatsInMajor = RemoveEmptiesInVector(res) End Function _____________________________________________________________________________________ Function GetCatInfo(ByVal Key As String, ByVal Col As Integer, Optional KeyCol As Variant) As Variant ' Key is first column in matrix, unless KeyCol is sent in ' Col is column to be returned, if 0 returns row number ' knows cols 6 is boolean ' for no hit, returns either "" or False, depending on column Dim i As Integer Dim S As String If IsMissing(KeyCol) Then KeyCol = 1 For i = 1 To Range("CatMat").Rows.Count S = Range("CatMat").Cells(i, KeyCol).Value If S = Key And S <> "" Then If Col = 0 Then GetCatInfo = i Else GetCatInfo = Range("CatMat").Cells(i, Col).Value End If Exit Function End If Next i GetCatInfo = "" End Function _____________________________________________________________________________________ Function GetCatFilenames(ByVal MajorFlag As Boolean) As Variant ' now returning in table order ' MajorFlag returns only Majors in user specified order Dim MajRowFlag As Boolean, MemberFlag As Boolean Dim i As Integer, j As Integer, k As Integer, n As Integer, x As Integer Dim Cat As String Dim CatList, res, MajorGrps, ordrs, temp As Variant n = Range("CatMat").Rows.Count ReDim res(n) ReDim ordrs(n) For i = 1 To n ' get Cat Filename Cat = Range("CatMat").Cells(i, 2).Value If Cat <> "" Then ' edit to be sure no spaces in filename If 0 < InStr(Cat, " ") Then Range("CatMat").Cells(i, 2).Select MsgBox "Spaces are not allowed in Filenames.", vbCritical, "Aborted!" End End If MemberFlag = Range("CatMat").Cells(i, 6).Value <> "" MajRowFlag = Range("CatMat").Cells(i, 7).Value <> "" ' we first edit the table, rows must be either Category or Major If MajRowFlag And MemberFlag Then MsgBox "Can't have input in both Member of Major and Major Order columns.", vbCritical, "Aborted!" End ElseIf (Not MajRowFlag) And (Not MemberFlag) Then MsgBox "Must have input in either Member of Major and Major Order columns.", vbCritical, "Aborted!" End ' see which is wanted ElseIf MajorFlag And MajRowFlag Then res(i) = Cat ordrs(i) = Range("CatMat").Cells(i, 7).Value ElseIf (Not MajorFlag) And (Not MajRowFlag) Then res(i) = Cat End If End If Next i res = RemoveEmptiesInVector(res) If IsEmpty(res) Then MsgBox "You have no categories. You cannot produce a Top or Category Menu.", vbCritical, "Aborted" End End If ' we result in order (if orders bad, then result will still be okay) If MajorFlag Then ordrs = RemoveEmptiesInVector(ordrs) GetCatFilenames = IndexIntoVector(res, GradeUp(ordrs)) Else ' ~~ loop for Major Groups ' (we disregard the above. it was mostly useful for the edits) MajorGrps = GetCatFilenames(True) ReDim res(n - 1) k = 0 ' loop for group members For i = 0 To UBound(MajorGrps) ' we need cat code Cat = GetCatInfo(MajorGrps(i), 1, 2) ' find members of this group ReDim temp(n - 1) x = 0 For j = 1 To n If Cat = Range("CatMat").Cells(j, 6).Value Then temp(x) = Range("CatMat").Cells(j, 2).Value x = x + 1 End If Next j If x <> 0 Then ReDim Preserve temp(x - 1) ' put in order by Sort Titles temp = IndexIntoVector(temp, CatSortVector(temp)) ' save For j = 0 To UBound(temp) res(k) = temp(j) k = k + 1 Next j End If Next i ReDim Preserve res(k - 1) GetCatFilenames = res End If End Function _____________________________________________________________________________________ Function CatSortVector(ByVal CatList As Variant) As Variant ' sort albums or categories in a major group by their titles Dim j As Integer Dim SortTitles As Variant ReDim SortTitles(UBound(CatList)) ' get titles, so we can sort by full title For j = 0 To UBound(CatList) SortTitles(j) = GetAI(CatList(j), 1) If Left(SortTitles(j), 4) = "The " Then SortTitles(j) = DropStr(SortTitles(j), 4) End If If Left(SortTitles(j), 2) = "A " Then SortTitles(j) = DropStr(SortTitles(j), 2) End If Next j CatSortVector = GradeUp(SortTitles) End Function _____________________________________________________________________________________ Function PicsInAlbum(ByVal Path As String, Optional ByVal AllFlag As Variant) As Variant ' return list of files in folder (master pictures are all numbers, like 0000.jpg) ' returns Empty if none found Dim S As String PicsInAlbum = GetPicMasterImages(Path) ' maybe they put in a bad path? If IsEmpty(PicsInAlbum) Then S = "No ????.jpg files found to process in:" & vbLf & Path & vbLf & "Check path." If Not IsMissing(AllFlag) Then If AllFlag Then AllErrors = AllErrors & S & vbLf & vbLf Else Application.StatusBar = False MsgBox S, vbCritical, "No Files! Aborted!" End If End If End If End Function _____________________________________________________________________________________ Private Function AlbumLocation(ByRef PicD As String, ByVal PLi As String, WebGetPath As String, ShortFlag As Boolean) As String ' is called when we have a virtual album, and we want the original location ' WebGetPath is used for plants, as they are pointing to other folders for pictures ' ShortFlag is used by plants to reduce foraging album to just park abbrev and month and day ' returns html string with album location and pointer to thumbnail Dim PLstr As String, t As String Dim Months As Variant ' if this is in its own album, we don't display If PicD = Left(PLi, Len(PicD)) Then AlbumLocation = "" Exit Function End If PLstr = Left(PLi, InStr(PLi, "/") - 1) ' convert foraging albums to friendly dates If Left(PLstr, 2) = "F-" Then Months = Split("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec") t = PLi t = Months(CInt(Mid(t, 8, 2)) - 1) & " " & CInt(Mid(t, 11, 2)) t = GetLocation(PLi) & ", " & t & ", " & Mid(PLi, 3, 4) If ShortFlag Then AlbumLocation = " (" & t & ")" Exit Function End If Else t = GetAI(PLstr, 1) End If PLstr = WebGetPath & PLstr & "/#p" & RemLead0s(DropStr(PLi, InStr(PLi, "/"))) AlbumLocation = "
Source: " & t & "" End Function _____________________________________________________________________________________ Private Function GetPrevAlbum(PicD As String) As String ' if the album does not have a previous album, returns "" Dim i As Integer If Pflg Then Else For i = 1 To Range("PicInputMatrix").Rows.Count If Range("PicInputMatrix").Cells(i, 5).Value = PicD Then GetPrevAlbum = Range("PicInputMatrix").Cells(i, 4).Value Exit Function End If Next i End If GetPrevAlbum = "" End Function _____________________________________________________________________________________ Function GetFromPicMat(ByVal PicD As String, Col As Integer) As String ' using Album Name column returns other input in its row ' Col is column to be returned, if 0 returns row number ' returns string. any test must be against string Dim i As Integer For i = 1 To Range("PicInputMatrix").Rows.Count If Range("PicInputMatrix").Cells(i, 4).Value = PicD Then If Col = 0 Then GetFromPicMat = i Else GetFromPicMat = Range("PicInputMatrix").Cells(i, Col).Value End If Exit Function End If Next i GetFromPicMat = "" End Function _____________________________________________________________________________________ Function GetCustIndex(ByVal PicD As String, ByVal n As Integer) As Variant ' N is number of pictures in album ' returns array of two vector, 1-full list, 2-without 0's Dim Ind, IndWO As Variant Ind = GetPicData(PicD, "i") IndWO = Without(Ind, "0") ' test index If UBound(IndWO) <> n Then MsgBox "Index for " & PicD & " has wrong number of non-zero elements. Must be " & n & " numbers. Now has " & UBound(IndWO) + 1, vbCritical, "Aborted!" End End If ' -> if IndWO is empty this will crash If UBound(RemDupSameOrder(IndWO)) <> UBound(IndWO) Then MsgBox "Each number in " & PicD & " index must be listed only once. Duplicates are:" & vbLf & ReturnDups(IndWO, True), vbCritical, "Aborted!" End End If ' return GetCustIndex = Array(Ind, IndWO) End Function _____________________________________________________________________________________ Function PicDataExists(ByVal PicD As String, ByVal Prefix As String, Optional ByVal AllFlag As Variant) As Boolean Dim S As String PicDataExists = FileExists(PicDataPath(PicD) & Prefix & "_" & PicD & ".txt") If Not PicDataExists And Not IsMissing(AllFlag) Then S = "No " & Prefix & "_" & PicD & ".txt file found in:" & vbLf & DropStr(PicDataPath, -1) If Prefix = "sub" Then S = "When you have a Custom Index you must also have a sub_ file with the Sub-Section headings." & vbLf & S End If If Not IsMissing(AllFlag) Then If AllFlag Then AllErrors = AllErrors & S & vbLf & vbLf Else Application.StatusBar = False MsgBox S, vbCritical, "Aborted!" End If End If End If End Function _____________________________________________________________________________________ Function GetPicData(ByVal PicD As String, ByVal Prefix As String, Optional Row As Variant) As Variant ' if Row exists, then will only return that element in a string, Row is base 0 ' if prefix contains a slash then if virtual album name and row Dim i As Integer, j As Integer, k As Integer Dim D As String Dim res, strts As Variant If IsMissing(Row) Then Row = Empty If Pflg And Prefix = "ai" Then GetPicData = PicD Exit Function End If ' when we have virtual albums we do one at a time i = InStr(Prefix, "/") If 0 < i Then PicD = Left(Prefix, i - 1) Row = CInt(Right(Prefix, 4)) - 1 Prefix = "pd" End If D = PicDataPath(PicD) & Prefix & "_" & PicD & ".txt" If FileExists(D) Then D = ReadInFile(D) Else Application.StatusBar = False Sheets("Pics").Select For i = 1 To Range("PicInputMatrix").Rows.Count If PicD = Range("PicInputMatrix").Cells(i, 4).Value Then Application.Goto Cells(1, Range("PicInputMatrix").Column - 1), True Range("PicInputMatrix").Cells(i, 4).Select End If Next i For i = 1 To Range("CatMat").Rows.Count If PicD = Range("CatMat").Cells(i, 2).Value Then Application.Goto Cells(1, Range("CatMat").Column - 1), True Range("CatMat").Cells(i, 2).Select End If Next i MsgBox "File does not exist:" & vbLf & D, vbCritical, "Aborted!" End End If ' ~~ return as nest of vectors (one for each row) If Prefix = "ai" Or _ Prefix = "c" Or _ Prefix = "list" Or _ Prefix = "pd" Or _ Prefix = "pi" Or _ Prefix = "pt" Or _ Prefix = "sub" Or _ Prefix = "tit" Then D = vbCrLf & D strts = AllInStr(D, vbCrLf) ReDim res(UBound(strts) - 1) For i = 0 To UBound(strts) - 1 ' drop after res(i) = Left(D, strts(i + 1) - 1) ' drop before res(i) = DropStr(res(i), strts(i) + 1) Next i If Not IsEmpty(Row) Then res = res(Row) End If GetPicData = res ' ~~ this gives 2-column matrix with first space splitting the columns ' must be integer before delimiting space ElseIf Prefix = "brks" Then D = CleanFileEnd(D) strts = AllInStr(D, vbCrLf) ReDim res(UBound(strts), 1) For i = 0 To UBound(strts) j = InStr(D, " ") k = InStr(D, vbCrLf) If k < j Then res(i, 0) = CInt(Left(D, k - 1)) D = DropStr(D, k + 1) Else res(i, 0) = CInt(Left(D, j - 1)) D = DropStr(D, j) End If j = InStr(D, vbCrLf) res(i, 1) = Left(D, j - 1) D = DropStr(D, j + 1) Next i GetPicData = res ' ~~ convert to numeric (only integers) ElseIf Prefix = "i" Then res = Split(D) For i = 0 To UBound(res) res(i) = CInt(res(i)) Next i GetPicData = res ' ~~ just the plain data, but no prefix gets here Else GetPicData = D End If End Function _____________________________________________________________________________________ Function GetAI(ByVal PicD As String, Row As Integer, Optional FullDate As Boolean, Optional ByVal AllFlag As Variant) As Variant ' reads Pflg, PlantListWO ' row: ' 1- album name ' 2- album long description for top of page (2nd row in ai_ file) ' 3- optional key words ' 4- copyright year yyyy (data is stored in 4th row in either YYYY or CCYYMMDD format) ' 4-1 true date (for sorting purposes). can also be CCYYMMDD when the copyright year is after date ' 5- short description for meta tag. if missing returns n=2 ' Opt. FullDate - flag for row 4, to return full date (default is first 4 characters) ' Opt. AllFlag - collect errors instead of reporting them immediately Dim S As String Dim res As Variant If Pflg Then If Row = 1 Then GetAI = PicD ElseIf Row = 2 Then GetAI = PlantList(Iota2(PlantListWO, PicD), 1) ElseIf Row = 4 Then ' we want the earliest year in the batch If FullDate Then GetAI = Left(S, 4) End If End If Else res = GetPicData(PicD, "ai") If Row - 1 > UBound(res) Then res = "" If Not IsMissing(AllFlag) Then S = "No ai_" & PicD & ".txt file found in:" & vbLf & DropStr(PicDataPath, -1) If AllFlag Then AllErrors = AllErrors & S & vbLf & vbLf Else Application.StatusBar = False MsgBox S, vbCritical, "Aborted!" End If End If Else res = res(Row - 1) If Row = 4 Then If FullDate Then If Len(res) = 4 Then res = DateSerial(res, 1, 1) ElseIf Len(res) = 8 Then res = DateSerial(Mid(res, 1, 4), Mid(res, 5, 2), Mid(res, 7, 2)) Else MsgBox "Invalid year/date in ai_" & PicD & ".txt file.", vbCritical, "Aborted!" End End If Else res = Left(res, 4) End If End If End If GetAI = res End If End Function _____________________________________________________________________________________ Function GetAlbumName() As String ' -> needs optional flag to return row instead Dim Row As Integer Dim Name As String Row = Range("PicRow").Value ' we check quality of row number and album name existence If Row < 1 Or Row > Range("PicInputMatrix").Rows.Count Then Sheets("Pics").Select Range("PicRow").Select MsgBox "Must enter row number within range of input matrix: 1 to " & Range("PicInputMatrix").Rows.Count & ".", vbCritical, "Aborted!" End ElseIf 0 < InStr(Range("PicRow").Value, ".") Then Sheets("Pics").Select Range("PicRow").Select MsgBox "Row Number must be Integer.", vbCritical, "Aborted!" End End If Name = Range("PicInputMatrix").Cells(Row, 4).Value If Len(Name) = 0 Then Sheets("Pics").Select Range("PicInputMatrix").Cells(Row, 4).Select MsgBox "Album Name for selected row is empty.", vbCritical, "Aborted!" End End If ' if test GetAlbumName = Name End Function _____________________________________________________________________________________ Sub IsAlbumName(ByVal PicD As String) Dim Path As String Path = PicPath(PicD) & PicD If Not FileExists(Path) Then PointToAlbumName Path MsgBox "Folder does not exist:" & vbLf & Path, vbCritical, "Aborted!" End End If End Sub _____________________________________________________________________________________ Sub PointToAlbumName(ByVal Path As String) ' this gets fancy, as they could be scrolled out of view of the target cell Dim i As Integer Path = ExtractFilename(Path) Sheets("Pics").Select For i = 1 To Range("PicInputMatrix").Rows.Count If Path = Range("PicInputMatrix").Cells(i, 4).Value Then Application.Goto Cells(Range("PicInputMatrix").Row + i - 1, 1), True Range("PicInputMatrix").Cells(i, 4).Select End If Next i Application.StatusBar = False End Sub _____________________________________________________________________________________ Function PicPath(Optional PicD As Variant, Optional ByVal Suffix As Variant) As String ' gets from sheet, edits, and returns path to the folder where the albums folders (and data) are ' can only have one or the other argument ' return includes trailing backslash Dim S As String ' this is the extent of what I implemented for multiple portfolios If Pflg Then Suffix = "1" ElseIf IsMissing(Suffix) Then If IsMissing(PicD) Then Suffix = "" Else Suffix = GetFromPicMat(PicD, 1) End If End If S = "PicPathAlbums" & Suffix If Not IsRangeName(S) Then Range("PicInputMatrix").Cells(GetFromPicMat(PicD, 0), 1).Select MsgBox "Invalid portfolio: " & Suffix & " for " & PicD & ".", vbCritical, "Aborted!" End End If PicPath = Range(S).Value If PicPath = "" Then Sheets("Pics").Select Range("PicPathAlbums" & Suffix).Select MsgBox "Must enter path for where the pictures are, and to where the htm files are to be written.", vbCritical, "Aborted!" End ElseIf Not FileExists(PicPath) Then Sheets("Pics").Select Range("PicPathAlbums" & Suffix).Select MsgBox "Invalid path to where the htm files are to be written.", vbCritical, "Aborted!" End End If PicPath = PicPath & "\" End Function _____________________________________________________________________________________ Function PicDataPath(Optional PicD As Variant) As String ' gets from sheet, edits, and returns path to folder where the text data on the albums is kept PicDataPath = PicPath(PicD) & "data\" End Function _____________________________________________________________________________________ Private Sub EditAI() ' is button on Pics sheet EditPicDataSub "ai" End Sub _____________________________________________________________________________________ Private Sub EditPD() ' is button on Pics sheet EditPicDataSub "pd" End Sub _____________________________________________________________________________________ Private Sub EditPDPFE() ' is button on Pics sheet EditPicDataSub "pd", True End Sub _____________________________________________________________________________________ Private Sub EditPI() ' is button on Pics sheet EditPicDataSub "pi" End Sub _____________________________________________________________________________________ Private Sub EditPT() ' is button on Pics sheet EditPicDataSub "pt" End Sub _____________________________________________________________________________________ Private Sub EditPicDataSub(Prefix As String, Optional PFEFlag As Boolean) ' subroutine for a bunch of edit buttons on the Pics sheet Dim FileName As String ' -> needs test for PicRow input, or? FileName = GetAlbumName ' if this is a virtual album, we get a list_ file instead of a pd_ file If Prefix = "pd" And Left(Range("PicInputMatrix").Cells(Range("PicRow").Value, 3).Value, 1) = "v" Then Prefix = "list" ' but it may also have a pd_ file (a mix album) and we have to give user a choice If FileExists(PicDataPath(FileName) & "pd_" & FileName & ".txt") Then fmFileToEdit.Show If CancelFlag Then End Prefix = Range("FileToEditSelection").Value End If End If ' check if file exists FileName = PicDataPath(FileName) & Prefix & "_" & FileName & ".txt" ' if file does not exist, Notepad asks you if you want to create CallNotepad FileName, PFEFlag End Sub _____________________________________________________________________________________ Private Sub EditCatAI() ' is button on Pics sheet EditCatAISub False End Sub _____________________________________________________________________________________ Private Sub ViewCat() ' is button on Pics sheet EditCatAISub True End Sub _____________________________________________________________________________________ Private Sub EditCatAISub(Viewflag As Boolean) Dim MajorFlag As Boolean Dim Row As Integer Dim FileName As String, Path As String ' is cursor location good? If Application.Intersect(ActiveCell, Range("CatMat")) Is Nothing Then MsgBox "Cursor is not within the Category Matrix.", vbCritical, "Need to Move Cursor!" End ' then get Filename Else FileName = Cells(ActiveCell.Row, Range("CatMat").Column + 1).Value If Len(FileName) = 0 Then MsgBox "No File Name on cursor row.", vbCritical, "Aborted!" End End If If Cells(ActiveCell.Row, Range("CatMat").Column + 5).Value = "" Then If Viewflag Then MajorFlag = True Else MsgBox "There is no ai_ Album Info file for Major Groups.", vbCritical, "Aborted!" End End If End If ' edit text file or view web page Path = PicPath(, Cells(ActiveCell.Row, Range("CatMat").Column + 4).Value) If Viewflag Then If Not MajorFlag Then Path = Path & FileName & ".htm" End If If FileExists(Path) Then ' -> I tried including the anchor, but Excel was stripping it off If MajorFlag Then Path = Path & "index.htm" ActiveWorkbook.FollowHyperlink Path Else GoTo BadName End If Else FileName = Path & "data\ai_" & FileName & ".txt" If FileExists(FileName) Then CallNotepad FileName Else GoTo BadName End If End If End If Exit Sub BadName: Cells(ActiveCell.Row, Range("CatMat").Column + 1).Select MsgBox "Bad Filename.", vbCritical, "Aborted!" End Sub _____________________________________________________________________________________ Private Sub DoAllFour() ' is button on Pics sheet ' does the same as pushing four buttons in order Range("PicIndFlag").Value = True Range("PicHtmFlag").Value = True BuildAllAlbums BuildCategoryMenus BuildTopMenu BuildPicturesSitemap End Sub _____________________________________________________________________________________ Private Sub ViewPicAlbum() ' is button on Pics sheet Dim Name As String Name = GetAlbumName IsAlbumName Name ActiveWorkbook.FollowHyperlink PicPath(Name) & Name & "\index.htm" End Sub _____________________________________________________________________________________ Private Sub ViewTopAlbum() ' is button on Pics sheet ActiveWorkbook.FollowHyperlink Range("PicPathAlbums").Value & "\index.htm" End Sub _____________________________________________________________________________________ Private Sub SortPicIndexType() ' is button on Pics sheet Dim Name As String If Range("PicRow").Value <> "" Then Name = GetAlbumName End If Range("PicInputMatrix").Sort Key1:=Range("C10"), Key2:=Range("E10") If Range("PicRow").Value <> "" Then Range("PicRow").Value = GetFromPicMat(Name, 0) End If End Sub _____________________________________________________________________________________ Private Sub SortPicAlbumsCat() ' is button on Pics sheet ' needs form and VBA sort. ' last 2 will require reading in entire matrix, sorting, and then writing it back ' the by date will require reading all ai_ files ' choices are: ' - plain sort (can see all virtual together) ' - sort ignoring v ' - ignore v and also sort by descending date within category (how it would appear on web) Dim Name As String If Range("PicRow").Value <> "" Then Name = GetAlbumName End If Range("PicInputMatrix").Sort Key1:=Range("D10"), Key2:=Range("E10") If Range("PicRow").Value <> "" Then Range("PicRow").Value = GetFromPicMat(Name, 0) End If ' --> I should then do a special sort on the foraging walks to put them in season order End Sub _____________________________________________________________________________________ Private Sub SortPicAlbumsName() ' is button on Pics sheet Dim Name As String Name = GetAlbumName If Range("PicRow").Value <> "" Then Name = GetAlbumName End If Range("PicInputMatrix").Sort Key1:=Range("E10") If Range("PicRow").Value <> "" Then Range("PicRow").Value = GetFromPicMat(Name, 0) End If End Sub _____________________________________________________________________________________ Private Sub SortCatMat() ' is button on Pics sheet Range("CatMat").Sort Key1:=Range("K15") End Sub _____________________________________________________________________________________ Private Sub BuildPicturesSitemap() ' is button on Pics sheet. processes Default Portfolio (hence no argument to PicPath) CreateSiteMapFromOtherSheet PicPath End Sub _____________________________________________________________________________________ Private Sub AnalyzeAI() ' is button on Pics sheet Sheets("SiteAnalysis").Select CheckAIRows End Sub _____________________________________________________________________________________ Private Sub ListI() ' is button on Pics sheet ListPicDataSub "i" End Sub _____________________________________________________________________________________ Private Sub ListSUB() ' is button on Pics sheet ListPicDataSub "sub" End Sub _____________________________________________________________________________________ Private Sub ListPT() ' is button on Pics sheet ListPicDataSub "pt" End Sub _____________________________________________________________________________________ Private Sub ListBRKS() ' is button on Pics sheet ListPicDataSub "brks" End Sub _____________________________________________________________________________________ Private Sub ListC() ' is button on Pics sheet ListPicDataSub "c" End Sub _____________________________________________________________________________________ Private Sub ListPicDataSub(Prefix As String) Dim i As Integer, n As Integer, Row As Integer Dim S As String Dim Files As Variant Row = Range("OutputUL").Row ' get list of files that we have to edit Files = ListFiles(PicDataPath, "txt", , True) ClearSiteAnalysis ' reduce to Prefix n = Len(Prefix) + 1 For i = 0 To UBound(Files) If Left(ExtractFilename(Files(i)), n) <> Prefix & "_" Then Files(i) = Empty End If Next i Files = RemoveEmptiesInVector(Files) With Sheets("SiteAnalysis") .Cells(Row, 4).Value = "Name" Row = Row + 1 ' set a freeze frame Cells(Row, 1).Select ActiveWindow.FreezePanes = True For i = 0 To UBound(Files) .Cells(Row, 4).Value = ExtractFilename(Files(i)) Row = Row + 1 Next i End With Application.Goto Range("A1"), True Range("OutputUL").Offset(1, 3).Select End Sub _____________________________________________________________________________________ Private Sub InitializeAI() ' is button on Pics sheet ' all processing code is behind the user form ' load user form fmInitAI.Show End Sub _____________________________________________________________________________________ Private Sub InitializePD() ' is button on Pics sheet ' all processing code is behind the user form ' load user form fmInitPD.Show End Sub _____________________________________________________________________________________ Private Sub CopyAI() ' is button on Pics sheet Dim Name As String, SourceName As String, t As String SourceName = InputBox("Source album to copy ai_ from:", "Source:") If SourceName = "" Then Exit Sub Name = GetAlbumName ' test for valid source name t = PicDataPath(Name) & "ai_" & SourceName & ".txt" If FileExists(t) Then FileCopy t, PicDataPath(Name) & "ai_" & Name & ".txt" Else MsgBox "Source album name doesn't exist.", vbCritical, "Invalid Name" End If End Sub _____________________________________________________________________________________ Private Sub RenumberPictures() ' is button on Pics sheet ' will renumber all jpgs in album. if renumbering after adding image, you must delete all other size jpgs ' as sorting punctuation and letters is ambiguous, if adding to middle, add a letter to all of that number Dim i As Integer Dim Name As String, Path As String Dim FileNames As Variant Name = GetAlbumName IsAlbumName Name Path = PicPath(Name) & Name & "\" FileNames = ListFiles(Path, "jpg") ' test if we have a mix of file sizes in folder If FileExists(Path & "tn0001.jpg") Or FileExists(Path & "w0001.jpg") Then MsgBox "You have a mix of files of different sizes. This facility renames the Master files, and only Master files can be in the folder.", vbCritical, "Aborted!" End End If ' first we rename all with an a, so no name clashes For i = 0 To UBound(FileNames) Name Path & FileNames(i) As Path & "a" & FileNames(i) Next i ' loop to rename For i = 0 To UBound(FileNames) Name Path & "a" & FileNames(i) As Path & Format(i + 1, "0000") & ".jpg" Next i End Sub _____________________________________________________________________________________ Sub ListWithLongLines() ' lists pd_ files that have lines longer than 1000 characters, which PFE is a better editor for Dim i As Integer Dim Name As String Dim PD As Variant For i = 1 To Range("PicInputMatrix").Rows.Count Name = Range("PicInputMatrix").Cells(i, 4).Value If Name <> "" Then ' flawed, as some have lists and not pds. see EditPD for code PD = GetPicData(Name, "pd") Stop End If Next i End Sub _____________________________________________________________________________________ Private Function CopyrightSpan(ByVal SYear As String) As String ' arg is year in string in first 4 digits Dim y As String y = Year(Date) If SYear = y Then CopyrightSpan = y Else CopyrightSpan = Left(SYear, 4) & "-" & y End If End Function _____________________________________________________________________________________ Sub TimeFixHour() ' needs menu. ' note that running CleanJpgs undoes this change! Dim H As Integer, i As Integer, j As Integer Dim D As String, f As String, newTime As String, oldTime As String, t As String Dim FileList As Variant ' f = "C:\Pictures\Foraging\PP-1231202" ' f = "C:\Internet\WEBPAGES\ForagingPictures.com\tours\F-2023-12-02" H = -1 ' get files in folder FileList = ListFiles(f, "jpg", , True) ' loop for files For i = 0 To UBound(FileList) oldTime = FileDateTime(FileList(i)) j = InStr(oldTime, " ") D = Left(oldTime, j - 1) t = DropStr(oldTime, j) newTime = D & " " & DateAdd("h", H, t) ' set File_Set_DateModified CStr(FileList(i)), CDate(newTime) Next i End Sub _____________________________________________________________________________________ Private Sub InitPIFile() ' for foraging albums only ' pd_ file must exist first Dim i As Integer, Rows As Integer Dim f As String, Name As String Dim res As Variant Name = GetAlbumName f = PicDataPath(Name) & "pi_" & Name & ".txt" If FileExists(f) Then If Not vbYes = MsgBox(ExtractFilename(f) & " File exists. Do you want to overwrite?", vbYesNo, "") Then Exit Sub End If End If ' get pd_ file to get number of rows. Rows = UBound(ReturnFileAsArrayOfRows(PicDataPath(Name) & "pd_" & Name & ".txt")) ReDim res(Rows) For i = 0 To Rows res(i) = Format(i + 1, "000") & "_" Next i SaveFile f, Ravel(res, vbCrLf) End Sub _____________________________________________________________________________________ Private Sub ChangePDFilesToNumbers() ' for foraging albums only ' after the pd_ files have been fleshed out, this changes the temp prefix to sequential numbers, also temporary ' if prefixes have been completely removed, this will add Dim i As Integer, j As Integer Dim f As String, Name As String Dim FileList As Variant Name = GetAlbumName f = PicDataPath(Name) & "pd_" & Name & ".txt" FileList = ReturnFileAsArrayOfRows(f) For i = 0 To UBound(FileList) j = InStr(FileList(i), ": ") If j = 0 Then j = 1 End If FileList(i) = Format(i + 1, "000") & DropStr(FileList(i), j - 1) Next i SaveIfChanged f, Ravel(FileList, vbCrLf) End Sub _____________________________________________________________________________________ Private Sub RemoveTempPDPrefixes() ' for foraging albums only ' removes any temp prefixes in pd_ files Dim i As Integer, j As Integer Dim f As String, Name As String Dim FileList As Variant Name = GetAlbumName f = PicDataPath(Name) & "pd_" & Name & ".txt" FileList = ReturnFileAsArrayOfRows(f) For i = 0 To UBound(FileList) j = InStr(FileList(i), ": ") If j = 0 Then MsgBox "The temp prefix has already been removed.", vbCritical, "Aborted" Exit Sub End If FileList(i) = LTrim(DropStr(FileList(i), j)) Next i SaveIfChanged f, Ravel(FileList, vbCrLf) End Sub _____________________________________________________________________________________