none
Excelのセル内の色付きテキストをテキストボックスに表示する RRS feed

  • 質問

  • いつもお世話になっております。

    ExcelVBAでこのようなことが実現できるか教えていただけるとありがたいです。

    セル"A"列 タイトル

    セル"B"列 説明文

    フォーム

    タイトルをコンボボックスへ読み込んで表示

    選択したタイトルに一致した説明文をフォームのテキストボックスに表示

    その際、説明文に太字下線付きで強調したい部分に編集をした場合に、表示させるテキストボックスにも同じように

    表示させたい。

    A列    B列

    AST    アスパラギン酸アミノトランスフェラーゼ 主に肝機能の検査です。

    アスパラギン酸アミノトランスフェラーゼ  

    ┃ 主に肝機能の検査です。         

    ━┛

    こんな感じです。

    よろしくお願いします。

    2019年8月27日 3:24

回答

  • こんな感じでどうでしょう。

    'Module1
    Option Explicit
    
    Public Sub Main()
        CreateSampleSheet
    End Sub
    
    Private Sub CreateSampleSheet()
        Dim ws1 As Excel.Worksheet
        Dim ws2 As Excel.Worksheet
        Set ws1 = ThisWorkbook.Worksheets("Sheet1")
        Set ws2 = ThisWorkbook.Worksheets("Sheet2")
        
        Dim col As Collection
        Set col = New Collection
        
        'ドロップダウンの内容、テキストボックスの内容、強調開始位置、強調文字数
        col.Add Array("AST", "アスパラギン酸アミノトランスフェラーゼ" & vbLf & "主に肝機能の検査です。", 23, 3)
        col.Add Array("AFP", "α-フェトプロテイン" & vbLf & "主に肝臓癌の検査です。", 14, 3)
       
        ' === Worksheet1 ===
        ' A 列にドロップダウンの内容、
        Dim r As Long, cf As Excel.Font
        ws1.Columns(2).ColumnWidth = 60#
        For r = 1 To col.Count
            ws1.Range(ws1.Cells(r, 1), ws1.Cells(r, 4)).Value = col(r)
            On Error Resume Next
            Set cf = ws1.Cells(r, 2).Characters(col(r)(2), col(r)(3)).Font
            cf.Bold = True
            cf.Underline = True
            On Error GoTo 0
        Next
        
        
        ' === Worksheet2 ===
        'B 列にドロップダウンとテキストボックスを配置
        Dim y1!, y2!, x As Single
        y1 = ws2.[B2].Top
        y2 = ws2.[B4].Top
        x! = ws2.[B2].Left
        Dim dd As Excel.DropDown, tb As Excel.Shape
        Set dd = ws2.DropDowns.Add(x, y1, 250, 22)
        dd.Name = "DropDown1"
        Set tb = ws2.Shapes.AddTextbox(msoTextOrientationHorizontal, x, y2, 250, 80)
        tb.Name = "TextBox1"
        ws2.DrawingObjects(Array("DropDown1", "TextBox1")).Placement = xlMoveAndSize
        dd.ListFillRange = ws1.Range(ws1.[A1], ws1.[A1].End(xlDown)).Address(True, True, xlA1, True)
        dd.OnAction = "DropDown1_Changed"
        
        ws2.Select
        ws2.[A1].Activate
    End Sub
    
    Private Sub DropDown1_Changed()
        Dim ws1 As Excel.Worksheet
        Dim ws2 As Excel.Worksheet
        Set ws1 = ThisWorkbook.Worksheets("Sheet1")
        Set ws2 = ThisWorkbook.Worksheets("Sheet2")
        Dim dd As Excel.DropDown, tf As Office.TextFrame2
        Set dd = ws2.DropDowns("DropDown1")
        Set tf = ws2.Shapes("TextBox1").TextFrame2
        
        Dim message As String, selStart As Long, selCount As Long
        message = ws1.Cells(dd.Value, 2).Value
        selStart = ws1.Cells(dd.Value, 3).Value
        selCount = ws1.Cells(dd.Value, 4).Value
        
        On Error Resume Next
        Dim cf As Office.Font2
        tf.TextRange.Characters(-1, -1).Text = message
        Set cf = tf.TextRange.Characters(selStart, selCount).Font
        cf.Bold = True
        cf.UnderlineStyle = msoUnderlineWavyDoubleLine
        On Error GoTo 0
    End Sub
    • 回答としてマーク qoo_man 2020年5月18日 1:30
    2019年8月27日 5:59

すべての返信

  • TextBox だとできないと思います。

    RichTextBoxコントロールか、WebBrowserコントロールで代用されてはどうでしょうか。

    いずれにしても、大変に面倒だと思いますが・・・

    2019年8月27日 3:59
  • minmin312様

    早速のアドバイスありがとうござます。

    テキストボックスでは出来ないのですね。

    RichTextBoxは見当たらなかったです。WebBrowserで出来ないかもう少しやってみます。

    2019年8月27日 4:47
  • RichTextBox を利用するには、
    [ツール] メニューから、[その他のコントロール] を開き、[Microsoft Rich Textbox Contorol.x.x (***)]
    にチェックを入れます。

    WebBrowserコントロ-ルを使う場合は、思い通りの表示になるように、HTML構文を自前で書く必要があると思います。
    2019年8月27日 5:36
  • こんな感じでどうでしょう。

    'Module1
    Option Explicit
    
    Public Sub Main()
        CreateSampleSheet
    End Sub
    
    Private Sub CreateSampleSheet()
        Dim ws1 As Excel.Worksheet
        Dim ws2 As Excel.Worksheet
        Set ws1 = ThisWorkbook.Worksheets("Sheet1")
        Set ws2 = ThisWorkbook.Worksheets("Sheet2")
        
        Dim col As Collection
        Set col = New Collection
        
        'ドロップダウンの内容、テキストボックスの内容、強調開始位置、強調文字数
        col.Add Array("AST", "アスパラギン酸アミノトランスフェラーゼ" & vbLf & "主に肝機能の検査です。", 23, 3)
        col.Add Array("AFP", "α-フェトプロテイン" & vbLf & "主に肝臓癌の検査です。", 14, 3)
       
        ' === Worksheet1 ===
        ' A 列にドロップダウンの内容、
        Dim r As Long, cf As Excel.Font
        ws1.Columns(2).ColumnWidth = 60#
        For r = 1 To col.Count
            ws1.Range(ws1.Cells(r, 1), ws1.Cells(r, 4)).Value = col(r)
            On Error Resume Next
            Set cf = ws1.Cells(r, 2).Characters(col(r)(2), col(r)(3)).Font
            cf.Bold = True
            cf.Underline = True
            On Error GoTo 0
        Next
        
        
        ' === Worksheet2 ===
        'B 列にドロップダウンとテキストボックスを配置
        Dim y1!, y2!, x As Single
        y1 = ws2.[B2].Top
        y2 = ws2.[B4].Top
        x! = ws2.[B2].Left
        Dim dd As Excel.DropDown, tb As Excel.Shape
        Set dd = ws2.DropDowns.Add(x, y1, 250, 22)
        dd.Name = "DropDown1"
        Set tb = ws2.Shapes.AddTextbox(msoTextOrientationHorizontal, x, y2, 250, 80)
        tb.Name = "TextBox1"
        ws2.DrawingObjects(Array("DropDown1", "TextBox1")).Placement = xlMoveAndSize
        dd.ListFillRange = ws1.Range(ws1.[A1], ws1.[A1].End(xlDown)).Address(True, True, xlA1, True)
        dd.OnAction = "DropDown1_Changed"
        
        ws2.Select
        ws2.[A1].Activate
    End Sub
    
    Private Sub DropDown1_Changed()
        Dim ws1 As Excel.Worksheet
        Dim ws2 As Excel.Worksheet
        Set ws1 = ThisWorkbook.Worksheets("Sheet1")
        Set ws2 = ThisWorkbook.Worksheets("Sheet2")
        Dim dd As Excel.DropDown, tf As Office.TextFrame2
        Set dd = ws2.DropDowns("DropDown1")
        Set tf = ws2.Shapes("TextBox1").TextFrame2
        
        Dim message As String, selStart As Long, selCount As Long
        message = ws1.Cells(dd.Value, 2).Value
        selStart = ws1.Cells(dd.Value, 3).Value
        selCount = ws1.Cells(dd.Value, 4).Value
        
        On Error Resume Next
        Dim cf As Office.Font2
        tf.TextRange.Characters(-1, -1).Text = message
        Set cf = tf.TextRange.Characters(selStart, selCount).Font
        cf.Bold = True
        cf.UnderlineStyle = msoUnderlineWavyDoubleLine
        On Error GoTo 0
    End Sub
    • 回答としてマーク qoo_man 2020年5月18日 1:30
    2019年8月27日 5:59
  • minmin312様

    ご回答ありがとうございます。

    その他のコントロールには入っていませんでした。

    2019年9月3日 9:18
  • リッチテキストボックスは、もしかしてVB6ランタイムだったかも。。。

    ところで、魔界の仮面弁士さんの提示したコードを利用してシート上に配置したテキストボックスに一旦表示した後、クリップボード経由で画像化(API)して、フォームに配置したイメージコントロールに表示するのもありかと思います。

    いずれにしても、面倒だとは思いますが。



    2019年9月4日 0:13
  • 失礼しました。肝心の「フォームのテキストボックス」という点を見落としていました…!

    UserForm 上で、書式付きテキストを表示する場合、ActiveX コントロールを用いるか、テキストを描画するかの二択になるはずです。(MSForms が持つ標準コントロールでは、テキストの一部の書式を変更することが出来ないため)

    ActiveX コントロールの候補としては、既に minmin312 さんが書かれているように、「RichTextBox」と「WebBrowser」の二種類が有力ですが、インストールしている Office が 64bit 版なのか 32bit 版なのかが問題となってきます。

    RichTextBox コントロールは RICHTX32.OCX というファイルとして提供されているものですが、これは現状、32bit 版しか提供されておらず、64bit 版は恐らくまだ存在していないからです。

    ひとまず 32bit 版の Office をお使いの場合は、RichTextBox コントロールを利用できそうです。

    With RichTextBox1
        .Text = "アスパラギン酸アミノトランスフェラーゼ" & vbCrLf & "主に肝機能の検査です。"
        .SelStart = 23
        .SelLength = 3
        .SelBold = True
        .SelUnderline = True
    End With

    ただし richtx32.ocx は、ランタイムライセンスは無償であるものの、現行の Office には同梱されていないと思いますし、ファイル単体での再頒布も許可されていないという問題があるため、実行環境が制限されるのが難点です。また、Excel VBA から使うには、ランタイムに加えて デザインタイム ライセンスも必要です。(デザインタイムライセンスは、Office 2000 Developer や VB6 や VB.NET 2003 などといった開発系製品に含まれています)

    一方 64bit 版の Office をお使いの場合、RichTextBox は使えないのですが、一応、"MSREdit Class" コントロール (MSRTEDIT.DLL) という物があるようで、上記画像のように、一応手持ちの Excel 2013 (64bit) でも実装できました。

    しかしながら、当方環境では特定の操作を行うと、Excel を巻き込んでクラッシュしてしまうという不安定さがありましたし、書式指定のために、TextRTF プロパティを直接操作する必要があるようで、あまり実用には向いていないと思います。

    あるいは、ActiveX コントロールとしてではなく、Declare ステートメントで RichEd20.DLL / RichEd32.DLL を呼び出して、ユーザーフォーム上に RichEdit コントロールを生成する手もありますが、これは手間がかかりすぎてしまいますね。

    残る選択肢としては、WebBrowser コントロールを使うぐらいしか思い当たりませんでした。

    実験的に、先の方法(オートシェイプの TextBox)の内容を CopyPicture メソッドで画像化し、それを OleCreatePictureIndirect API を通じて StdPicture オブジェクトに変換して Image コントロールの Picture プロパティに Set しなおす方法でも実現できましたが…これだと二度手間ですし、テキストではなく画像なので、文字列選択できないなどの問題がありますね。

    2019年9月4日 1:59
  • 残る選択肢としては、WebBrowser コントロールを使うぐらいしか思い当たりませんでした。

    WebBrowser だと、こんな見た目になりました。

    ここではコンテンツを直接ハードコーディングしているだけなので、実際にはワークシートからデータを読み取る形にする必要があると思います。

    Private Sub ComboBox1_Change()
        'WebBrowser1.Document.clear
        WebBrowser1.Document.body.innerText = ""
        WebBrowser1.Document.body.contentEditable = True
        WebBrowser1.Document.body.Style.margin = "3 0 0 8"
        WebBrowser1.Document.body.Style.Font = "12pt 'MS ゴシック'"
        WebBrowser1.Document.body.Style.overflowX = "scroll"
        WebBrowser1.Document.body.Style.overflowY = "scroll"
        Select Case ComboBox1.Value
        Case "AST"
            WebBrowser1.Document.body.innerHTML = "アスパラギン酸アミノトランスフェラーゼ<BR>主に<STRONG style='margin:0 3px'><U>肝機能</U></STRONG>の検査です。 "
        End Select
    End Sub
    
    Private Sub UserForm_Initialize()
        ComboBox1.AddItem "AST"
        WebBrowser1.Navigate2 "about:blank"
    End Sub
    2019年9月4日 3:48
  • 魔界の仮面弁士様

    すっかりあきらめていたので、フォーラムを見ていませんでした。

    素晴らしい回答をしていただいていたのに、非常にもったいない思いです。

    早速Excelのシステムをこれを参照して変えようと思います。

    強調できるので見やすくなります。

    ありがとうございました!!

    2020年5月18日 1:33