FC2ホームページ用変換ツール

山の会のホームページをFC2にも作成した。(http://sksanko.web.fc2.com/
FC2は1GBの容量が無料で借りられるので、山の会のホームページをもう一つ作ってみた。
山の会は会費を取ってないので「さくらのレンタルサーバー」の年間1500円のレンタル料もなかなか厳しい状況なので、できれば無料のFC2に移籍したいところでもある。そのためFC2をちょっと使ってみることにした。

それには現在はさくらのレンタルサーバーに会員が投稿してくれた記事をダウンロードして、HP担当の私が書き換えてFC2にアップすることになる。全く同じものをアップしても良いのだが、容量が1GBしかないので、できるだけ容量を節約するために、画像を1サイズ省略した。
その結果、自動チェンジのスライドショーも800×600のサイズの画像を使わざるを得なくなったので、ページの幅の関係で左側のバナースペースを省くことになった。
このレイアウト変更はフルCSSで構成してあるので、CSSをちょっと変更すれば90%は可能だが、メニューの項目変更や追加削除、バナー項目の削除、一覧メニューの列追加などは、どうしてもHTMLファイルを書き換える必要がある。index.html、slide.html、map.html、トップページindex.html、一覧ページindex1.html の5ページを手で書き換えるのはかなり面倒だ。
そこで、自動書き換えツールを作成した。結果は約1秒で書き換え作業は終了。ダウンロードとアップロードの手間だけである。
ツールは、再帰処理で深い階層まで全ファイルを検索して処理するようにした。

具体的には、会員がアップした新しいファイルなどを[TMP]フォルダにダウンロードする
ダウンロードするファイルは、トップページの[index.html]、その下の階層の[report]フォルダ内の[index1.html]と新しい日付フォルダ[000000]とその中のすべてのファイル。(ここで000000は実際は日付の文字列)

ダウンロードが終わったら[TMP]フォルダを下記の[sk2fc.vbs]にドロップすれば、約1秒で変換は終了。
新しく作成される[TMP-2]フォルダ内に、変換されたファイルが、[TMP]フォルダの階層構造と同じ階層構造で作成されている。これはFC2ホームページの階層とも同一だからFTPでアップする場合、階層を気にすることなく1回の操作で全ファイルを一気にアップすることができる。

' [sk2fc.vbs]
Dim DropFolder, OldFolderPath, NewFolderPath
Dim fs, f
Dim temp, temp2, temp3
Dim n, Flag

'ドロップされたフォルダーネーム取得
DropFolder = WScript.Arguments(0)	'・・・・・・・・・・\HomePage\TMP

OldFolderPath = DropFolder		'変換元フォルダ
NewFolderPath = DropFolder & "-2"	'変換結果フォルダ

'準備 ファイルシステムオブジェクトのセット
Set fs = CreateObject("Scripting.FileSystemObject")
Set f  = fs.GetFolder(OldFolderPath)
NewFol = f.Name & "-2" 			'[TMP-2]

OyaFolderPath  = f.ParentFolder		'・・・・・・・・・・・\HomePage
Set objOyaFol  = fs.GetFolder (OyaFolderPath)
Set colOyaFols = objOyaFol.SubFolders	'親フォルダ内フォルダコレクション
Set objSubFol  = objOyaFol.SubFolders	'親フォルダ内サブフォルダ([TMP]など・・)

For Each objOyaSubFol in colOyaFols	'親フォルダ内サブフォルダ検索
    If objOyaSubFol.Name = NewFol Then	'新フォルダ[TMP-2]などが有ったら削除
        fs.DeleteFolder (OyaFolderPath & "\" & NewFol)
    End If
Next
objSubFol.Add (NewFol)			'新フォルダ[TMP-2]作成(空)

'フォルダの検索処理の呼び出し
Call prcFolder(f)

Set f = fs.GetFolder(NewFolderPath)
Call delFolder(f)

Set f  = Nothing
Set fs = Nothing
MsgBox("完了!")


'================再帰処理で全ファイル検索処理==================
Sub prcFolder(f)
    'ファイルを検索
    For Each temp In f.Files
        'ファイルが見つかったら変換処理
        motoFileName = temp.Path                                                '元ファイルPath
        shinFileName = Replace(temp.Path, OldFolderPath, NewFolderPath)

        If f.Name="TMP" Then                                                    'トップフォルダ
            If InStr(temp.Name, ".html") > 0 Then                               'トップページ
	        subUTF8FileConv1  motoFileName, shinFileName
            End If
        ElseIf f.Name="report" Then                                   'リポートフォルダ
            If InStr(temp.Name, ".html") > 0 Then                  '山行記録一覧
                subUTF8LineConv  motoFileName, shinFileName
            End If
        Else                                                                    'その他のフォルダ
            If InStr(temp.Name, ".html") > 0 Then		'その他のHTML
                subUTF8FileConv2  motoFileName, shinFileName
            Else						'その他のファイル全部
                fs.CopyFile  motoFileName, shinFileName
            End If
        End If
    Next

    For Each temp2 In f.SubFolders
        'サブフォルダが見つかったら再帰処理
        If fs.FolderExists(temp2) Then
            motoFol = temp2.Path
            shinFol = Replace(temp2.Path, OldFolderPath, NewFolderPath)
            newFol  = temp2.Name				'検索フォルダ名

            oyaFolPath = fs.GetParentFolderName(shinFol)
            Set objOyaFol = fs.GetFolder(oyaFolPath)
            Set objSubFol = objOyaFol.SubFolders

            Flag = False
            For Each temp3 In objOyaFol.SubFolders	'[TMP-2]フォルダの構成を検索
                If temp3 = newFol Then
                    Flag = True		'[TMP-2]に検索フォルダがあればループを抜ける
                    Exit For
                End If
            Next
            If Flag=False Then
                objSubFol.Add (NewFol)	'[TMP-2]内に検索フォルダがない場合は作成
            End If
            call prcFolder(temp2)	'再帰処理
        End If
    Next
End Sub


'================[album]フォルダ削除==================
Sub delFolder(f)
    For Each temp In f.SubFolders
        'サブフォルダが見つかったら再帰処理
        If fs.FolderExists(temp) Then
            motoFol = temp.Path		'検索フォルダPath
            Folname = temp.Name
            If Folname = "album" Then	'[album]が見つかったら削除
                call fs.DeleteFolder (motoFol, true)
                Exit For
            End If
            call delFolder(temp)	'再帰処理
        End If
    Next
End Sub


'================変換処理(一括読込)==================
Sub subUTF8FileConv1(motoFile, shinFile)
    Dim tmpFile : tmpFile = shinFile & ".tmp"	'一時ファイル宣言
    Dim reg
    Set reg = New RegExp		'正規表現クラスを「reg」にセット

    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile(motoFile)
        txOut = .ReadText
        .Close
    End With

    reg.Global = True
    reg.Pattern = "<script.+CheckPassword80.+?</script>\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "\t+.+<a href=""sksbbs.+\r\n(\t+.+\r\n){2}"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "<!-- aside -->"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "\t+<!-- aside end -->\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "link</span></a></li>"
    txOut = reg.Replace(txOut, "link</span></a></li>" & vbCrLf & _
			String(4, vbTab) & "<li id=""nav-mail""><a href=""some/mail.html""><span class=""ja"">メールアドレス</span><span class=""en"">address</span></a></li>" & vbCrLf & _
			String(4, vbTab) & "<li id=""nav-faq""><a href=""some/faq.html""><span class=""ja"">FAQ</span><span class=""en"">faq</span></a></li>")

    reg.Pattern = "\t+<li id=""nav-access"">.+\r\n\t.+\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "<div id=""associationinfo"">"
    txOut = reg.Replace(txOut, "<div id=""clubinfo"">")

    reg.Pattern = "小川 会長宅</p>\r\n"
    txOut = reg.Replace(txOut, "小川 会長宅</p>" & vbCrLf & _
		String(3,vbTab) & "</div>" & vbCrLf & _
		String(3,vbTab) & "<div id=""banner"">" & vbCrLf & _
		String(4,vbTab) & "<script language=""javascript"" type=""text/javascript"" _
		src=""http://counter1.fc2.com/counter.php?id=20987252&main=1""> _
		</script><noscript><img src=""http://counter1.fc2.com/counter_img.php? _
		id=20987252&main=1"" /></noscript>" & vbCrLf)

    Call WriteUTF8(txOut, shinFile)
End Sub


Sub subUTF8FileConv2(motoFile, shinFile)
    Dim tmpFile : tmpFile = shinFile & ".tmp"	'一時ファイル宣言
    Dim reg
    Set reg = New RegExp		'正規表現クラスを「reg」にセット

    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile(motoFile)
        txOut = .ReadText
        .Close
    End With

    reg.Global = True
    reg.Pattern = "<script.+CheckPassword80.+?</script>\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "\t+<div id=""aside"">\r\n(\t+.+\r\n){3}\t+(<li> _
			<a href=""index1.html"".+\r\n)(\t+.+\r\n){9}\t+</div>\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "\t+<div id=""aside"">\r\n(\t+.+\r\n){3}\t+(<li> _
			<a href=""../index1.html"".+\r\n)(\t+.+\r\n){9}\t+</div>\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "<!-- aside -->"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "\t+<!-- aside end -->\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "width=""80"" height=""28"""
    txOut = reg.Replace(txOut, "width=""90"" height=""30""")

    reg.Pattern = "width=""162"" height=""28"""
    txOut = reg.Replace(txOut, "width=""240"" height=""30""")

    reg.Pattern = "link</span></a></li>"
    txOut = reg.Replace(txOut, "link</span></a></li>" & vbCrLf & _
			String(4, vbTab) & "<li id=""nav-mail""> _
			<a href=""../../some/mail.html""> _
			<span class=""ja"">メールアドレス</span> _
			<span class=""en"">address</span></a> _
			</li>" & vbCrLf & String(4, vbTab) & "<li id=""nav-faq""> _
			<a href=""../../some/faq.html""><span class=""ja"">FAQ _
			</span><span class=""en"">faq</span></a></li>")

    reg.Pattern = "\t+<li id=""nav-access"">.+\r\n\t.+\r\n"
    txOut = reg.Replace(txOut, "")

    reg.Pattern = "<div id=""associationinfo"">"
    txOut = reg.Replace(txOut, "<div id=""clubinfo"">")

    If InStr(motoFile, "index.html") > 0 Then
        reg.Pattern = "<a href=""album/"
        txOut = reg.Replace(txOut, "<a href=""slide/")

        reg.Pattern = "<img src=""album/"
        txOut = reg.Replace(txOut, "<img src=""slide/")

        reg.Pattern = "width=""160"" height=""120"""
        txOut = reg.Replace(txOut, "width=""224"" height=""168""")
    ElseIf InStr(motoFile, "slide.html") > 0 Then
        reg.Pattern = "'main': 'album/"
        txOut = reg.Replace(txOut, "'main': 'slide/")
    ElseIf InStr(motoFile, "map.html") > 0 Then
        reg.Pattern = "width=""644"" height=""620"""
        txOut = reg.Replace(txOut, "width=""896"" height=""620""")
    End If
    Call WriteUTF8(txOut, shinFile)
End Sub


'================変換処理(一行ずつ読込)==================
Sub subUTF8LineConv(motoFile, shinFile)
    Dim reg
    Set reg = New RegExp		'正規表現クラスを「reg」にセット
    n = 0
    Flag = False
    txOut = ""  
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile(motoFile)

        Do While Not .EOS		'最終行(EOS)になるまでループを続ける
            txLine = .ReadText(-2)	'1行ずつ読み込む。1=全部読み込む 2=1行読み込む

            reg.Pattern = "width=""24%"
            txLine = reg.Replace(txLine, "width=""18%")
            reg.Pattern = "山名(標高)</th>"
            txLine = reg.Replace(txLine, "山名(標高)</th><th width=""8%"" _
			style=""text-align : center;"" align=""center"">スライド</th>")
            reg.Pattern = "width=""10%"
            txLine = reg.Replace(txLine, "width=""8%")
            reg.Pattern = "所要<br />時間"
            txLine = reg.Replace(txLine, "所要時間")
            reg.Pattern = "参加<br />人数</th><th width=""7%"
            txLine = reg.Replace(txLine, "参加人数</th><th width=""8%")
            reg.Pattern = "\t+.+id=""nav-access"".+?</li>"
            txLine = reg.Replace(txLine, "")
            reg.Pattern = "\t+.+id=""nav-tool"".+?</li>"
            txLine = reg.Replace(txLine, String(4, vbTab) & "<li id=""nav-mail""> _
			<a href=""../some/mail.html""> _
			<span class=""ja"">メールアドレス</span> _
			<span class=""en"">address</span></a> _
			</li>" & vbCrLf & String(4, vbTab) & "<li id=""nav-faq""> _
			<a href=""../some/faq.html""><span class=""ja"">FAQ _
			</span><span class=""en"">faq</span></a></li>")

            reg.Pattern = "all rights reserved.</p>"
            txLine = reg.Replace(txLine, "all rights reserved.</p>" & vbCrLf & _
			String(2,vbTab) & "</div>" & vbCrLf & _
			String(2,vbTab) & "<div id=""footerExtra2"">" & vbCrLf & _
			String(3,vbTab) & "<script language=""javascript"" _
			type=""text/javascript"" src=""http://counter1.fc2.com/counter.php? _
			id=89313143""></script><noscript><img src=""http://counter1.fc2.com/ _
			counter_img.php?id=89313143"" /></noscript>")

            'スライド列追加(表の1行ずつ読み込んで列を追加する)
            reg.Pattern = "<tr><td>.+\)</td><td><a href=""(\d{6}-?\d?/).+(</a></td> _
			<td style=""text-align : center;"" align=""center"">).+</td></tr>"
            reg.Global = True
            Set mc = reg.Execute(txLine)
            mval0 = ""
            mval1 = ""
            For i=0 To mc.Count-1
                Set m = mc(i)
                mval0 = m.SubMatches(0)
                mval1 = m.SubMatches(1)
            Next
            txLine = Replace(Replace(txLine, mval1, "</a></td><td style=""text-align : center;"" align=""center""><a href=""" & mval0 & "slide.html"">あり</a></td><td style=""text-align : center;"" align=""center""><a href=""" & mval0 & "slide.html"">"), ">Map</a>", ">あり</a>")
            'バナー領域(aside以下14行)削除
            If InStr(txLine, "<div id=""aside"">") > 0 Then  Flag = True
            If Flag = True Then
                n = n+1
                txLine = ""		'行削除
                If n > 14 Then Flag = False
            End If
            '出力。txOutに1行ずつ追加して行く。
            If txLine <> "" Then    txOut = txOut & txLine & vbCrLf
        Loop
        .Close
    End With

    Call WriteUTF8(txOut, shinFile)
End Sub


'--------------------------------------------
'UTF8で書込む
'--------------------------------------------
Sub WriteUTF8(text, fileName)
    tmpFile = fileName & ".tmp"
    ' UTF-8で書きこむと自動的にBOM(Byte Order Mark)が、先頭に3バイト付加されてしまう。
    ' それを回避するため、一旦一時ファイルにUTF-8形式で書き込む
    With CreateObject("ADODB.Stream")
        .Type = 2			'1=テキストデータ、2=バイナリデータ
        .charset = "UTF-8"		'UTF-8文字コード指定
        .Open
        .WriteText text
        .SaveToFile tmpFile, 2		'一時ファイルに書き込む。2:ファイルがある場合は上書き
        .Close
    End With
    ' 一時ファイルをバイナリで読み取る
    With CreateObject("ADODB.Stream")
        .Type = 1			'1=テキストデータ、2=バイナリデータ
        .Open
        .LoadFromFile(tmpFile)		'一時ファイルをバイナリで読み取る
        .Position = 3			'BOMの3バイトを読み飛ばす
                    
        '4バイト目から出力ファイルにバイナリで書き込む
        Dim ws : Set ws = CreateObject("ADODB.Stream")
        ws.Type = 1
        ws.Open
        ws.Write(.Read(-1))		'1=全部読み込む、2=1行読み込む
        ws.SaveToFile fileName, 2	'新ファイルに書き込む。2:ファイルがある場合は上書き
        ws.Close
        .Close
    End With
    ' 一時ファイルの削除
    Call CreateObject("Scripting.FileSystemObject").DeleteFile(tmpFile)
End Sub
データ
  • 2013.09.02(月)
アーカイブ

現在位置: ホームなんでも日記メニュー > このページ