[公式は教えてくれない][一訂]Access VBA リッチテキスト形式のMemo型(長いテキスト型)を持つテーブルを作る

意外とこういう書き方しかダメだった

IDとメモ型の単純なテーブルを作る
Schema.iniの保存でこの必要が生じた。
それではこれをVBAで書くにはどうすればいいのか。
複数の書き方が考えられるが、
まずテーブルをCreateTableで作るとダメ。
次にAdoxはダメ。
最終的に行き着いたのが、この形式になった

Sub MakeSchemaTable()
'For Access VBA
'accdb OK
Dim cDB As Dao.Database: Set cDB = CurrentDb
Dim Tdf As Dao.TableDef, fld As Field, _
prps As Dao.Properties, prp As Dao.Property
'Dim daoIDx As Dao.Index, daoIDXs As Dao.Indexes
Dim i As Long, buf As String
Const TName = "T_Test"
Const sfld1 = "F001Memo_Rich"
If ifTableExists(TName) = True Then DoCmd.DeleteObject acTable, TName
cDB.Execute "Create Table " & TName & "(ID Counter Primary Key, [" & sfld1 & "] MEMO);"
cDB.TableDefs.Refresh
Application.RefreshDatabaseWindow
Set Tdf = cDB.TableDefs(TName)
Set fld = Tdf.Fields(sfld1)
Set prp = fld.CreateProperty("TextFormat", dbByte, CByte(acTextFormatHTMLRichText)) ' This is point dbByte Property and Value Use CByte
fld.Properties.Append prp
End Sub
Public Function ifTableExists(tblName As String) As Boolean
'https://stackoverflow.com/questions/3350645/how-to-check-if-a-table-exists-in-ms-access-for-vb-macros
If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then
ifTableExists = True
End If
End Function

ポイント

1. SQLで作成するのはIDとMemo型を使用するが、この時点ではプレーンテキストしか入らない。
2. SQLをCurrent.Db.Executeで実行した後は、まずCurrentDb.Tabledefs.Refreshをする。そうしないと次のSet tdf = CurrentDb.TableDefs(Tname)がエラーになる。
3. 次にset tdf以下Dimステートメントで型を指定した変数に代入する。なおここではDAOを使用する。
4. fld.CreataPropertyの中、定数をなんとCByte関数で代入しないとエラーになる。またこのプロパティはdbByte型である。
5. fld.Properties.Append prpプロパティに定番のフレーズ。しかし、他ではなかなかない。ここで、フィールドのプロパティのコレクションに追加する、という形で設定する。
6. そしてこのことはMSの公式には全くないらしい。さらに日本語でAccessのテーブルのメモ型のフィールドのリッチテキスト形式を設定するとき、CByte関数を用いることを日本語で説明するのはたぶん自分が初めてらしい。※CByte(acTextFormatHTMLRichText)で検索

こうした意味不明さにいつも苦しめられているが...

https://social.msdn.microsoft.com/Forums/de-DE/5e53dc13-1149-4601-83bd-6dcad9d1c8a4/type-dbmemo-und-wie-kann-format-richtext-eingestellt-werden?forum=accessde
しかしこれが記載されているのは例によってドイツ語のMS。
ここでは既存のテーブルに追加しているが、この方法はうまくいかなかった。ミスがあったのかはわからない。
https://www.pcreview.co.uk/threads/alter-table-column-to-rtf.3591653/
PCPreviewは自分の書き方に近いが、CreateTableであとからエラーを起こしてダメだった。またIDを設定するとうまくいかないので、IDが設定する場合はSQLを使用するほうが有効に作用した。

たしかに既存のテーブルがあれば削除するようにはしていたのが、他と違う。

リッチテキストメモ型フィールドをテキストに出力する

このテーブルはSchema.iniを保存しておき、ない場合には自動的に作るという命令を作成しようとしたものだ。
しかしリッチテキストはHTML互換のタグが付く。また改行も入って1行おきに表示される。
そこで

vbcrlfというパターンを削除して出力するマクロが以下のようになる。
~~しかし最後のが削れないので、最後はReplaceした。このためが二重にあるように見えるが、これはエラーで~~~~はなく仕様である。~~また元の記事にも書くが、やはりSchema.iniを作る場合はShit_Jisがバグにならない。
ここはテキストでもよい。このため、このフィールドはヘルプを記載する。VBScriptを保存するなど、いろいろな使い方が考えられる。

Sub MakeSchemainifromTable()
'SchemaFileの内容を隠しテーブルに保存しているので、ない場合には作成できる。
'ある場合には既存のファイルの名前をschema.oldとして書く。ある場合は作成しない。
Dim db As dao.Database: Set db = CurrentDb
Dim sPath As String: sPath = Access.CurrentProject.Path
Dim ARS As ADODB.Recordset: Set ARS = New ADODB.Recordset
Dim sr As ADODB.Stream: Set sr = New ADODB.Stream
Dim CN As ADODB.Connection: Set CN = New ADODB.Connection
Dim FSO As New FileSystemObject
Dim buf As String
Const SName = "Schema.ini"
Dim sFolder As String: sFolder = CurrentProject.Path
If FSO.FileExists(sFolder & "\" & SName) Then Exit Sub
Set CN = CurrentProject.Connection
ARS.Open "Select * From T_Schema", CN, adOpenForwardOnly, adLockReadOnly
sr.Charset = "UTF-8"
sr.LineSeparator = adCRLF
sr.Mode = adModeReadWrite
sr.Open
'リッチテキストの余分なタグと改行を削除して保存
'buf = Replace(Replace(Replace(ARS.Fields(1).Value, "</div>" & vbCrLf, "", 1, -1, vbBinaryCompare), "<div>", "", 1, -1, vbTextCompare), "</div>", "", 1, -1, vbTextCompare)
' Application.PlainTextをつかうと、タグがきれいに消える
buf = Application.PlainText(ARS.Fields(1).Value)
sr.WriteText buf, adWriteChar
sr.SaveToFile sFolder & "\" & SName
sr.Close
ARS.Close
CN.Close
End Sub

RTF仕様

Rich Text Format(RTF)の構造（の覚え書き） - Part 1
https://wiz-code.net/blog/2009/09/rich-text-formatrtf---part-1.html
リッチテキストをHTMLにコンバートするというのは戸惑ったが、この定数がacTextFormatHTMLRichTextで一応Memo型をRichテキストにするとHTMLも入るらしい。

　リッチ テキスト形式のテキストは、Windows SharePoint Services のリッチ テキスト データ型と互換性のある HTML 形式で
　メモ型フィールドに保存されます。
　この新しい "TextFormat/文字書式" プロパティを RichText または PlainText のどちらかに設定すると
　その情報はテキスト ボックス コントロールおよびデータシート ビューで適切に書式設定されます。

　手動で入力する場合、改行はEnter
プレーンテキストでHTMLタグを入れてリッチテキストにするとHTMLのように表示される。またHTMLを取り込んでプレーンにするとタグが表示される。とある。テキストで出力したとき、タグが入ったのはこれが原因のようである。

HTMLに出せるか

https://stackoverflow.com/questions/16350527/copy-rtf-text-from-access-to-word-table-using-vba
2009年ごろはrtf形式をHTML形式に変えるソフトが結構流行っていたようだ。
今回知ったけど、結局タグが付いているのが共通しているので変換できそうなきがしますね。
そこで今できるのかを調べるとStackoverflowに一つあった。
DLOOKUPで1発で抜いて(Recordsetを開かない）というのはすごい。
原文はtempフォルダを使うけど、データに意味があるので、あえてC:\hogeに出します。
しかしHTML化が<html></html>でつつめばOKというのがすごい。
実際やると完全には再現されませんが、確かにhtm化します。
しかしもう一つ渋いのが、WordにしてHTMLにできるのにしないこと。
たしかにWordの出すHTMLファイルって必ずWordの設計を書くので700行くらい最初からあります。
またrtfファイルを入れるときのRange.Inserftilもすごい。
https://docs.microsoft.com/ja-jp/office/vba/api/word.range.insertfile

Sub FormattedTextToWord()
Const wdFormatRTF = 6 ' Word.WdSaveFormat のメンバー
'https://stackoverflow.com/questions/16350527/copy-rtf-text-from-access-to-word-table-using-vba
Dim objWord As Object ' Word.Application
Dim fso As Object ' FileSystemObject
Dim f As Object ' TextStream
Dim myHtml As String, tempFileSpec As String

' grab some formatted text from a Memo field
myHtml = DLookup("F01MEMO", "T_Test", "ID=1")

Set fso = CreateObject("Scripting.FileSystemObject") ' New FileSystemObject
tempFileSpec = fso.GetFolder("C:\hoge").Path & "\" & fso.GetTempName & ".htm"

' write to temporary .htm file
Set f = fso.CreateTextFile(tempFileSpec, True)
f.Write "<html>" & myHtml & "</html>"
f.Close
Set f = Nothing

Set objWord = CreateObject("Word.Application") ' New Word.Application
objWord.Documents.Add
objWord.Selection.InsertFile tempFileSpec
'fso.DeleteFile tempFileSpec
' the Word document now contains formatted text

objWord.ActiveDocument.SaveAs2 "E:\zzzTest.rtf", wdFormatRTF ' 6 = wdFormatRTF
objWord.Quit
Set objWord = Nothing
Set fso = Nothing
End Sub

もう一つここは質問した人もすごくて、Memo型フィールドにrtfファイルを挿入する方法をやっている。
Formで指定されたSalseというテーブルのIDと合致するものを出す。

' Query the database and get the sales for the specified customer
Set rs = CurrentDb.OpenRecordset("SELECT * FROM Sales WHERE Sales.[ID] ='" & Forms![customers]![id] & "'")

'Check to see if the recordset actually contains rows
    If Not (rs.EOF And rs.BOF) Then
    rs.MoveFirst
    Do Until rs.EOF = True

    ' Create file and add rtf text
    Set ts = fso.CreateTextFile("c:\temp\temp.rtf", True)
    ts.Write rs(3)
    ts.Close

    ' Add a row
    doc.Tables(1).Rows.Add

    ' Get the number of the added row to add data
     i = doc.Tables(1).Rows.Last.Index

    ' Add sale to word table
    doc.Tables(1).Cell(i, 2).Range.InsertFile "C:\temp\temp.rtf", , False


    'Move to the next record. Don't ever forget to do this.
    rs.MoveNext
   Loop
Else
    MsgBox "There are not records in the recordset."
End If

MsgBox "Finished." & i

rs.Close
Set rs = Nothing
Dim rs As dao.RecordSet
Dim fso : Set fso = CreateObject("Scriptiong.FileSystemObject")
Dim ts 'As TextStream
Dim i As Long

' Query the database and get the sales for the specified customer
Set rs = CurrentDb.OpenRecordset("SELECT * FROM Sales WHERE Sales.[ID] ='" & Forms![customers]![id] & "'")

'Check to see if the recordset actually contains rows
    If Not (rs.EOF And rs.BOF) Then
    rs.MoveFirst
    Do Until rs.EOF = True

    ' Create file and add rtf text
    Set ts = fso.CreateTextFile("c:\temp\temp.rtf", True)
    ts.Write rs(3)
    ts.Close

    ' Add a row
    doc.Tables(1).Rows.Add

    ' Get the number of the added row to add data
     i = doc.Tables(1).Rows.Last.Index

    ' Add sale to word table
    doc.Tables(1).Cell(i, 2).Range.InsertFile "C:\temp\temp.rtf", , False


    'Move to the next record. Don't ever forget to do this.
    rs.MoveNext
   Loop
Else
    MsgBox "There are not records in the recordset."
End If

MsgBox "Finished." & i

rs.Close
Set rs = Nothing