Excelで作成した表をTextile形式のテーブルにするVBAをJUSTCalc4で使用したい

Question

前提・実現したいこと

webを参考にしてExcelの表をTextile形式のテーブルにするVBAを使用していますが、
JUSTCalc4で使用できるようにしたいと考えております。

また、Excel通りの「背景色、文字の色・太さ、セル結合」を行いたいと考えておりますが、
webで調べたところiniファイルを作成して使用する形となっておりExcel単体だけで作れないものかなと思っています。

▼実現したいこと
JUSTCalc4でExcelの表をTextile形式のテーブルにしクリップボードに出力する
マクロを使用したい。
できたらセル背景色、文字の色・太さ、セル結合に対応させたい

発生している問題・エラーメッセージ

▼Excelの表をTextile形式のテーブルにするVBAをJUSTCalc4で使用

マクロの実行中にエラーが発生しました。
[詳細情報]
原因：オブジェクトのメソッド、プロパティ呼び出しにおいてエラーが発生しました。(-2147467261)
式　:IMdcText.MultiLine
位置:Module1:23

該当のソースコード

Option Explicit

'Textileをクリップボードに書き出す
Sub Copy_Textile()
    Dim cl As Range
    Set cl = Selection
    If cl.Count = 1 Then
        MsgBox "出力領域が選択されていません。"
        Exit Sub
    End If

    Dim textile As String
    textile = ConvTextile(cl)

    Call SetCB(textile)

    MsgBox "クリップボードにコピーしました。" & vbCrLf & vbCrLf & textile
End Sub

Sub SetCB(ByVal str As String)
    'クリップボードに文字列を格納
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = str
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
End Sub

'指定されたセル範囲をTextileに変換
Function ConvTextile(rng As Range) As String

    Dim i As Long

    Dim rtmp As Range
    Dim mTop As Range

    Dim rSpan, cSpan As Long
    Dim aStr As String
    Dim sStr As String
    Dim strREC As String
    Dim dStr As String  ' to cleanup text
    Dim hl As String    ' for Hyperlink

    Dim stmp As String
    stmp = ""

    ' 左端列を記憶
    Dim rLast As Long
    rLast = 0

    Dim pc As Long
    Dim pr As Long
    Dim cl As Range
    For Each cl In rng

        ' 表示されているセルのみ対象とする
        ' SelectionにSpecialCells(xlCellTypeVisible)を付けると
        ' 取得されるセルの順番が縦優先になってしまうので使えない
        If cl.Rows.Hidden = False And cl.Columns.Hidden = False Then

            ' 上端の列を取得
            If rLast = 0 Then rLast = cl.Row
            If cl.Row <> rLast Then
                'If strREC <> "" Then
                    'テーブルを閉じる
                    strREC = strREC & "|"
                    stmp = stmp & strREC & vbCrLf

                    strREC = ""
                'End If
                rLast = cl.Row
            End If

            ' セルが結合されている場合
            If cl.MergeCells Then
                ' 基点が非表示の場合の考慮が必要なので
                ' 結合セルの表示されている一番左上のセルとの一致を判定
                ' 表示されている一番左上のセルを取得
                For i = 1 To cl.MergeArea.Count
                    Set mTop = cl.MergeArea.Item(i)
                    If mTop.Rows.Hidden = False And mTop.Columns.Hidden = False Then
                        Exit For
                    End If
                Next i

                ' 処理対象のセルと一致していなければループに戻る
                If cl.Address <> mTop.Address Then
                    GoTo Continue
                End If

            End If

            aStr = ""
            sStr = ""

            With cl.MergeArea

                ' 結合範囲の取得
                rSpan = .Rows.Count
                cSpan = .Columns.Count

                ' セルが結合されている場合
                If cl.MergeCells Then

                    pc = .Item(1).Column
                    pr = .Item(1).Row

                    ' 結合範囲内の非表示分を減算
                    For i = 1 To .Rows.Count - 1
                        If Cells(pr + i, pc).Rows.Hidden = True Then
                            rSpan = rSpan - 1
                        End If
                    Next i
                    For i = 1 To .Columns.Count - 1
                        If Cells(pr, pc + i).Columns.Hidden = True Then
                            cSpan = cSpan - 1
                        End If
                    Next i

                    ' 結合セル数をTextile形式に
                    If rSpan > 1 Then sStr = "/" & rSpan
                    If cSpan > 1 Then sStr = sStr & "\" & cSpan

                End If

                ' 配置情報を取得
                If .HorizontalAlignment = xlLeft Then aStr = "<"
                If .HorizontalAlignment = xlRight Then aStr = ">"
                If .HorizontalAlignment = xlCenter Then aStr = "="

                If .VerticalAlignment = xlVAlignTop Then aStr = aStr & "^"
                If .VerticalAlignment = xlVAlignBottom And rSpan > 1 Then aStr = aStr & "~"

                ' ハイパーリンクの取得
                hl = linkAddress(.Item(1))

                If .Item(1).Text = "" Then aStr = ""

                strREC = strREC & "|" & sStr & aStr
                If sStr <> "" Or aStr <> "" Then strREC = strREC & ". "

                ' 前後の改行を削除
                ' 空行も削除
                ' 前後の空白も削除
                dStr = Trim(TrimLF(Replace(.Item(1).Text, vbLf & vbLf, vbLf)))

                ' ハイパーリンクがある場合
                If hl <> "" Then
                    strREC = strREC & """" & Replace(dStr, vbLf, vbCrLf) & """:" & hl
                Else
                    ' セル修飾対応
                    If dStr <> "" Then
                        ' 斜体
                        If .Item(1).Font.Italic Then
                            dStr = "_" & dStr & "_"
                        End If
                        ' 下線
                        If .Item(1).Font.Underline <> xlUnderlineStyleNone Then
                            dStr = "+" & dStr & "+"
                        End If
                        ' 打ち消し線
                        If .Item(1).Font.Strikethrough Then
                            dStr = "-" & dStr & "-"
                        End If
                        ' 太字
                        If .Item(1).Font.Bold Then
                            dStr = "*" & dStr & "*"
                        End If
                    End If

                    strREC = strREC & Replace(dStr, vbLf, vbCrLf)
                End If

            End With

        End If ' Not Hidden

Continue:
    Next ' Selection

    ' 残処理
    If strREC <> "" Then
        strREC = strREC & "|"
        stmp = stmp & strREC & vbCrLf
    End If

    ConvTextile = stmp
End Function

'ハイパーリンクを取得
Public Function linkAddress(r As Range) As String
    If r.Hyperlinks.Count > 0 Then '指定したセルにハイパーリンクオブジェクトがある
        linkAddress = r.Hyperlinks(r.Hyperlinks.Count).Address
        If r.Hyperlinks(r.Hyperlinks.Count).SubAddress <> "" Then
            linkAddress = linkAddress & "#" & r.Hyperlinks(r.Hyperlinks.Count).SubAddress
        End If
    Else
        If InStr(r.Formula, "=HYPERLINK") Then 'HYPERLINK関数を使っている
            linkAddress = Mid(r.Formula, 13, InStr(13, r.Formula, """") - 13)
        Else
            linkAddress = ""
        End If
    End If
End Function

' 文字列前後の改行を削除
Function TrimLF(str As String) As String
    Dim strTmp As String
    strTmp = str
    Do Until Left(strTmp, 1) <> vbLf
        strTmp = Mid(strTmp, 2)
    Loop
    Do Until Right(strTmp, 1) <> vbLf
        strTmp = Left(strTmp, Len(strTmp) - 1)
    Loop
    TrimLF = strTmp
End Function

Comments

[K_3578]

teratailでは「複数のユーザーIDを1人で保有する行為」は禁止されています。
https://teratail.com/legal 第7条

[jinoji]

・コードが見づらいので、「コードの挿入」を使ってください。
・どの行で発生したエラーなのか示してください。

[betuaka2001]

コードの挿入を使用しました。
JUST Calc 4 ではマクロ編集機能がないため、実行時どの行でエラーが起きているのか不明です

[jinoji]

あ、このコード自体が、JUST Calc 4 のマクロなんですね。
Excelマクロと勘違いしていました。
つまり、JUST Calc 4ではCreateObject("Forms.TextBox.1")が使えないということでしょうか。
だとしたら、ちょっと割り切って、
Call SetCB(textile) のかわりに
Range("A1").Value=textile
Range("A1").Copy
とかでは駄目でしょうか。

[betuaka2001]

ありがとうございます。
無事動作を確認いたしました。
このコードに追記して「背景色、文字の色・太さ」を反映させることはできるのでしょうか。

[betuaka2001]

上記動作を確認しましたが「””」がコピーされてしまうため下記記載に変更しました。

Range("A1").Value = textile

Dim buf As String, buf2 As String, CB As New DataObject
buf = Range("A1")
With CB
.SetText buf
.PutInClipboard
.GetFromClipboard
buf2 = .GetText
End With

Answer 1

これだと動くということでしょうか。

Sub SetCB(ByVal str As String)
    'クリップボードに文字列を格納
    With New DataObject
        .SetText str
        .PutInClipboard
    End With
End Sub