【ExcelVBA】EverNoteのテキストだけノートをテキストファイルにする。

3月ごろから、テキスト作成環境が、携帯からポメラに移行した。
エバーノートに入っているテキストをポメラに移動させたくなった。


vba上で、ACSⅱで保存できないものかと思ったのだが、StrConv掛けてももともとSfit-JISだぜとばかりに文字化けするのに、テキストストリームで書きだそうとすると、Unicodeを指定しないとエラーを吐く始末。

仕方ないので最後の仕上げは手作業になってしまったところが無念である。

↓は空白が飛んでるので、スタイル指定の部分の除去で、StrPtnにセットしている部分は該当行の内容を 貼りなおしてください。
----------------------------
' エバーノートからエクスポートしたフォルダを
' CELL_TARGET_DIR
' に書き込んでから実行
' Write By m_o_co
'要）Microsoft ActiveX Data Objects
Public Sub Go_HtmlToTextCov()

'========================
' 宣　　言
'========================
' 定数
Const strTgExe As String = ".html"
Const cnvExe As String = ".txt"

' 変数
Dim strTgDir As String ' ディレクトリ
Dim strBufDir As String
Dim FSO As Object
Dim FLS As Object ' FileSystemObject.Folder.Files
Dim bufFIL As Object

Dim aTS As Object ' UTF8読み込み用インスタンス

Dim TS As Object ' TextStream
Dim RE As Object ' RegExp
Dim strBuf As String ' テキスト加工用
Dim strPtn As String ' 検索文字列

' 対象ディレクトリ
strTgDir = Range("CELL_TARGET_DIR").Value

' 正規表現準備
'□ 除去 <.*>
strPtn = "<.*>" ' 今回、正規表現は1個なので、先にセットしちゃう
Set RE = CreateObject("VBscript.RegExp")
With RE
.Pattern = strPtn ' 正規表現パターンのセット
.IgnoreCase = True '大/小文字無区別
.Global = True '全体検索
End With


' FSO準備
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FLS = FSO.GetFolder(strTgDir).Files
Set aTS = CreateObject("ADODB.Stream")

' ストリームオプション
With aTS
.Type = adTypeText ' テキスト形式
.Charset = "UTF-8" ' キャラセットを指定
.Open ' インスタンス
End With


'========================
' 開　　始
'========================
For Each bufFIL In FLS

If bufFIL.Type = "Chrome HTML Document" Then

' 対象テキストをゲット
aTS.LoadFromFile bufFIL.Path
strBuf = aTS.ReadText(adReadAll)

'■ 置換（改行） </div> → vbcrlf
strPtn = "</div>"
strBuf = Replace(strBuf, strPtn, vbCrLf)


'■ 除去 <.*>
' strPtn = "<.*>" ' セット済み
With RE
' .Pattern = strPtn ' 正規表現パターンのセット
strBuf = .Replace(strBuf, "") ' 置換
End With


'■ 除去
' body, td {
' font-family: メイリオ;
' font-size: 10pt;
' }
strPtn = " body, td {" & vbCrLf & _
" font-family: メイリオ;" & vbCrLf & _
" font-size: 10pt;" & vbCrLf & _
" }"

strBuf = Replace(strBuf, strPtn, "")

' 書き込み
Set TS = FSO.OpenTextFile(Replace(bufFIL.Path, strTgExe, cnvExe), 2, True, -1) ' 書き込み/新規作成する/Unicode
With TS
.Write strBuf
.Close
End With

Set TS = Nothing

End If

Next

aTS.Close: Set aTS = Nothing
Set bufFIL = Nothing
Set FLS = Nothing
Set RE = Nothing

End Sub
----------------------------