GDIplusCODE


Dim fileList As Collection
Dim FSO As Object
Dim folderName As String

Const homeUrl As String = "http://gdipluscode.sakura.ne.jp/"

'ホームページの移行支援
'検索エンジンの評価継続対策
Sub setNewAddressOnHtml()
  Dim I As Long
  Dim counter As Long
  
    folderName = myGetFolder
    If folderName = "" Then Exit Sub
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fileList = New Collection
    '再帰的に指定フォルダー内のパス群をCollectionに取得
    Call searchSubFolder(FSO.GetFolder(folderName))
    
    For I = 1 To fileList.Count
    With fileList(I)
      If Not Left(fileList(I).parentFolder.Name, 1) = "_" Then
        If LCase(FSO.GetExtensionName(.Path)) = "html" Or LCase(FSO.GetExtensionName(.Path)) = "htm" Then
          treatUTF8 .Path
        End If
      End If
    End With
    Next
    Set FSO = Nothing
End Sub

'各ファイルの書き換え処理
Private Sub treatUTF8(filePath As String)
  Dim bytData() As Byte
  Dim buf As String
  Dim strLink As String
  Dim strMeta As String
  Dim newdata As String
  Dim url As String
  
  Const adTypeText = 2
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2 ' adSaveCreateNotExist = 1
  Const adreadall = -1
  Const adreadline = -2
  
  'ローカルの保管場所のファイルパスから新サーバーのUrlに変換
  If LCase(FSO.getfilename(filePath)) <> "index.html" And LCase(FSO.getfilename(filePath)) <> "index.htm" Then
    url = homeUrl & Replace(Replace(filePath, folderName & "\", ""), "\", "/")
  Else
    url = homeUrl
  End If
    
  '追加データの生成
  newdata = "<title>GDIplusCODE</title>"
  strLink = "<link rel=""canonical"" href=""" & url & """ />"
  strMeta = "<meta http-equiv=""refresh"" content=""5; url=" & url & """ />"
  newdata = newdata & vbCrLf & strLink & vbCrLf & strMeta
  
  'ファイルを開いて処理
  With CreateObject("ADODB.Stream")
      'Streamのオープン
      .Open
      ' UTF-8に変換
      .Type = adTypeText
      .Charset = "UTF-8"
      'ファイル読み込み
      .LoadFromFile (filePath)
      buf = .readText(adreadall) 'すべて読み込み
      'タイトルタグ部に情報を追加する
      buf = Replace(buf, "<title>GDIplusCODE</title>", newdata)
      '上書き保存
      .Position = 0
      .WriteText buf
      .SaveToFile filePath, adSaveCreateOverWrite
      .Close
  End With
End Sub

'指定フォルダー以下のファイルを再帰検索
Private Sub searchSubFolder(parentFolder As Object)
    Dim subFolder As Object
    Dim myFile As Object
    
    For Each subFolder In parentFolder.SubFolders
    Call searchSubFolder(subFolder)
    Next subFolder
    
    For Each myFile In parentFolder.Files
    fileList.Add Item:=myFile
    Next myFile
    Set parentFolder = Nothing
End Sub

'ダイアログを開いてフォルダを取得
Private Function myGetFolder() As String
  Dim objShell  As Object 'Shell
  Dim objFolder As Object 'Shell32.Folder
  Const strTitle = "フォルダを選択してください。"

  'シェルのオブジェクトを作成する
  Set objShell = CreateObject("Shell.Application")
  'フォルダー参照に設定
  Const lngRef = &H1
  'ルートフォルダーをMy Documentsに設定
  Const fldRoot = &H5
  Set objFolder = _
    objShell.BrowseForFolder(0, _
    strTitle, lngRef, fldRoot)
  Set objShell = Nothing
  
  'フォルダー名を取出す
  Dim strMSG
  If objFolder Is Nothing Then 'キャンセルチェック
    myGetFolder = ""
  Else
    If objFolder.parentFolder Is Nothing Then
      'ルートが選択された時
      myGetFolder = ""
    Else
      myGetFolder = objFolder.Items.Item.Path
    End If
  End If
    
End Function
WebServerのお引っ越し援用
