GDIplusCODE


	
Sub convCode2Html()
  Dim doc As Object
  Dim myheader As Object, mybody As Object
  Dim cssElement As Object, pElement As Object, emElement As Object
  Dim objFSO As Object, fileRead As Object, fileWrite As Object
  Dim lineData As String, buf As String
  Dim outputFilePath As String
  Const moduleName As String = "Module1"
  
  Set doc = CreateObject("HTMLFile")
  'WebPageの基本形を与える
  doc.Write "<html><head></head><body></body></html>"
  Set myheader = doc.getElementsByTagName("head")(0)
  Set mybody = doc.getElementsByTagName("body")(0)
  'CSSの設定
  Set cssElement = doc.createElement("style")
  cssElement.Type = "text/css"
  'emはデフォルトで斜体になる様です。他にstrongも使えそう。
  
  'IE8対応のコード
  cssElement.styleSheet.cssText = "em.comment{color:green;}"
  
  'IE9では動くコードだが、IE9環境におけるCreateObject("HTMLFile")でもエラーとなった
  'IE9のパーツを使い回している訳ではなく、古いものらしい。
'  cssElement.innerText = "em.comment{color:green;}"
  myheader.appendchild cssElement
  
  'htmlエスケープが必要と思ったが、createTextNodeの中途半端な仕様の所為で思わぬ苦労をした
  'createTextNodeは「&<>」のみescape
  'これはTextNodeのオブジェクトを操作しても同様
  'なお、s/w-quotationはIEのDOMで内部的に自動で変換している様に思える
  Set pElement = doc.createElement("p")
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  
  'なぜかobjFSO.OpenTextFileだと2行位読み込んで打ち切ってしまう
  Set fileRead = objFSO.GetFile(GetDesktopPath & "\" & moduleName & ".bas").OpenAsTextStream
  Do Until fileRead.AtEndOfStream
    lineData = fileRead.ReadLine
    buf = Replace(lineData, vbTab, "    ")
    '字下げの再現にこだわってみた。IEからクリップボードにコピーするとその段階で&nbsp;はスペースに置換され
    'メモ帳等に貼り付けても悪さはしない様だ
    buf = Replace(buf, " ", "&nbsp;")
    If Left(Trim(lineData), 1) <> "'" Then
      pElement.appendchild (doc.createTextnode(buf))
    'コメントの時
    Else
      Set emElement = doc.createElement("em")
      emElement.className = "comment"
      emElement.appendchild (doc.createTextnode(buf))
      pElement.appendchild emElement
      '<br />にはなってくれないが機能している
    End If
    pElement.appendchild (doc.createElement("br"))
  Loop
  fileRead.Close
  '&nbsp;が、&amp;nbsp;にエスケープされてしまうため、元に戻す
  pElement.innerHTML = Replace(pElement.innerHTML, "&amp;nbsp;", "&nbsp;")
  'bodyにpタグとして書き出す
  mybody.appendchild pElement
  
  outputFilePath = GetDesktopPath & "\" & moduleName & ".html"
     
  Set fileWrite = objFSO.CreateTextFile( _
      Filename:=outputFilePath, Overwrite:=True)
  fileWrite.Write doc.getElementsByTagName("html")(0).outerHTML
  fileWrite.Close

  Set objFSO = Nothing
End Sub

Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function
テキストファイルをｈｔｍｌに変換する
