Index

'HTMLファイルのインデックスページを作成するマクロ '（再帰呼び出しを使っています。） Option Explicit 'サンプル Sub MakeMyIndex() 'フォルダ名: D:\WWW\ 'インデックスファイル名: MyIndex.htm MakeIndexPage "D:\WWW\", "MyIndex.htm" End Sub Sub MakeIndexPage(dirname As String, filename As String) Dim sht1 As Worksheet Dim r As Range Dim s As String Dim i As Integer Dim fno As Integer On Error GoTo err_1 Set sht1 = Workbooks.Add(xlWorksheet).Worksheets(1) Set r = sht1.Cells(1, 1) DirAllFiles dirname, r Set r = sht1.Cells(1, 1).CurrentRegion.Columns(1).Find( _ What:=dirname & filename, After:=sht1.Cells(1, 1), _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False, MatchByte:=False) If Not (r Is Nothing) Then r.EntireRow.Delete sht1.Cells(1, 1).CurrentRegion.SortSpecial _ SortMethod:=xlSyllabary, Key1:=sht1.Cells(1, 1), _ Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _ MatchCase:=False, Orientation:=xlTopToBottom fno = FreeFile() Open dirname & filename For Output As #fno Print #fno, "" Print #fno, "Index" Print #fno, "" i = Len(dirname) + 1 For Each r In sht1.Cells(1, 1).CurrentRegion.Columns(1).Cells s = "" & GetHTMLTitle(r.Value) & "

" Print #fno, s Next Print #fno, "" Print #fno, "" Close #fno ActiveWorkbook.Close False Exit Sub err_1: Close #fno MsgBox Error(Err) End Sub Sub DirAllFiles(dirname As String, ByRef r As Range) Dim fname As String Dim dirs() As String Dim cnt As Integer, i As Integer cnt = 0 fname = Dir$(dirname & "*", vbDirectory) Do While fname <> "" If fname <> "." And fname <> ".." Then If (GetAttr(dirname & fname) And vbDirectory) = 0 Then If (StrComp(Right$(fname, 4), ".HTM", 1) = 0) Or _ (StrComp(Right$(fname, 5), ".HTML", 1) = 0) Then r.Value = "'" & dirname & fname Set r = r.Offset(1) End If Else cnt = cnt + 1 ReDim Preserve dirs(1 To cnt) dirs(cnt) = fname End If End If fname = Dir$() Loop For i = 1 To cnt DirAllFiles dirname & dirs(i) & Application.PathSeparator, r Next End Sub Function GetHTMLTitle(i_fname As String) As String Dim ch As String * 1 Dim s1 As String, s2 As String Dim i As Integer Dim fno As Integer Dim ifOpen As Boolean On Error GoTo err_1 fno = FreeFile() Open i_fname For Binary Access Read As #fno ifOpen = False Get #fno, , ch Do While Not EOF(fno) If Not ifOpen Then Select Case ch Case "<" s2 = "" For i = 1 To 5 Get #fno, , ch If EOF(fno) Then Exit For s2 = s2 & ch Next If StrComp(s2, "TITLE", 1) = 0 Then ifOpen = True Do While True Get #fno, , ch If EOF(fno) Then Exit Do If ch = ">" Then Exit Do Loop End If End Select Else If ch = "<" Then GetHTMLTitle = Trim$(s1) Exit Do Else s1 = s1 & ch End If End If If EOF(fno) Then Exit Do Get #fno, , ch Loop Close #fno Exit Function err_1: Close #fno End Function