エクセルＶＢＡでテキストボックスをマウスでさわるとコメントで全文表記したい

お世話になっておりますエクセル2010を使用しています
セルの値からテキストBOXを作成するコードは以下のようになっていて
エクセルシートにテキストBOXを貼り付けるところまで出来ています

作業人数によって、BOXの大きさが変わり、少ない人数だとBOXは小さくなります

問題はテキストBOXをクリックすると全文表示されるのですが、大変見づらいので
BOXをさわると、テキストBOXの全文がコメント表示（吹き出し等）されるようにしたいです

mousemoveやRangeオブジェクトのAddCommentメソッド等で
以下構文の中に組み込むことは可能でしょうか

SUB テキストボックス作成
*
*
省略
*
*

MSG =WORK + Chr(10) + CStr(MAN_COUNT) & "X" & CStr(DURATION) + " " + REV

        ActiveSheet.Shapes.AddShape(msoShapeRectangle, S_TIME, HR, MAN).Select
        Selection.Characters.Text = MSG
            
                With Selection.Characters(Start:=1, Length:=100).Font
                    .Name = "ＭＳ Ｐゴシック"
                    .FontStyle = "標準"
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                    .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
            
                    'クリックするとBOX内全文が出てくる
                    .HorizontalOverflow = xlOartHorizontalOverflowOverflow
                    .VerticalOverflow = xlOartHorizontalOverflowOverflow
                 End With
                
                'FONT SIZEの指定
                If MAN_COUNT >= 5 Then
       '作業人数が5人以上なら20サイズ
                Selection.Characters(Start:=1, Length:=100).Font.Size = 20
                    
                ElseIf 2 < MAN_COUNT And MAN_COUNT < 5 Then
         '作業人数が3-4人は16サイズ
                 Selection.Characters(Start:=1, Length:=100).Font.Size = 16
                
                ElseIf MAN_COUNT <= 2 Then
       '2人以下は12サイズ
                Selection.Characters(Start:=1, Length:=100).Font.Size = 12
                End If
                                                                            
                '------------------------------------------------------------
                
                Selection.ShapeRange.Fill.Visible = msoTrue
                Selection.ShapeRange.Fill.Solid
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = TEXTBOX_COLOR
                Selection.ShapeRange.Fill.Transparency = 0#
                
                Selection.ShapeRange.Line.Weight = 1
                Selection.ShapeRange.Line.DashStyle = msoLineSolid
                Selection.ShapeRange.Line.Style = msoLineSingle
                Selection.ShapeRange.Line.Transparency = 0#
                Selection.ShapeRange.Line.Visible = msoTrue
                
                Selection.ShapeRange.Line.ForeColor.SchemeColor = LINE_COLOR
                
                Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
                
                With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter

' .ReadingOrder = xlContext
.Orientation = xlHorizontal
.AutoSize = False
.AddIndent = False
'テキストボックスの中をクリックすると全文表示
.HorizontalOverflow = xlOartHorizontalOverflowOverflow
.VerticalOverflow = xlOartHorizontalOverflowOverflow
End With

*********以下、省略

End Sub

行動規範の内容に同意します

回答1件

ベストアンサー

少し調べてみました。
・Shapeにはコメントが存在しない。
・Shapeのイベントはクリックイベントのみ。
という制約がありそうです。

この前提で何とかしようとすると、
・クリックのタイミングでコメントに見立てたShapeを作る
・数秒後に自動でコメントShapeを削除する
くらいしか思いつきませんでした。
少し作ってみたのですが、結構作り込まないとダメそうだったので断念しました。
でもまあ、せっかくなので作りかけのを置いておきますので参考にしてください。

VBA
1' API定義
2Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
3
4Sub test()
5    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, 100, 10)
6        .TextFrame.Characters.Text = "123"
7        ' クリック時に呼び出す関数を登録
8        .OnAction = "text_OnClick"
9    End With
10End Sub
11
12Sub text_OnClick()
13    Dim p As Long
14    With ActiveSheet
15        ' 吹き出しを作成
16        ' 実際には選択されているShapeの座標から位置を決めれば良い
17        .Shapes.AddShape(msoShapeBalloon, 210, 90, 100, 10).Select
18        
19        ' 時間経過後に削除するShapeの位置を保持
20        p = .Shapes.Count
21        
22        ' 5秒ウェイト
23        For i = 1 To 50
24            Sleep 100
25            DoEvents
26        Next
27        
28        ' 吹き出しを削除
29        .Shapes(p).Delete
30    End With
31End Sub
32

改良版です。
２パターン作ってみました。
1つ目は前回の改良版です。
クリックしたテキストボックスの横に吹き出し図形を作成します。
2つ目は、テキストボックスの位置のセルにコメントを追加して、それを表示させています。
どちらも5秒後に自動的に消えます。
また再クリックで即削除します。
test関数を実行すると、B2セルの値でC2セルの位置にパターン1のテキストボックスを、
B4セルの値でC4セルの位置にパターン2のテキストボックスを作成します。
いずれも無理やり感は否めません…。

VBA
1' API定義
2Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
3
4Sub test()
5    Dim fc As Range
6    Dim tc As Range
7    
8    ' 吹き出しを作成するパターン
9    With ActiveSheet
10        Set fc = .Range("B2")
11        Set tc = .Range("C2")
12        With .Shapes.AddShape(msoShapeRectangle, tc.Left, tc.Top, tc.Width, tc.Height)
13            .TextFrame.Characters.Text = fc.Value
14            ' クリック時に呼び出す関数を登録
15            .OnAction = "'text_OnClick""" & .Name & """'"
16        End With
17    End With
18    
19    ' テキストボックスの裏のセルにコメントを作成するパターン
20    With ActiveSheet
21        Set fc = .Range("B4")
22        Set tc = .Range("C4")
23        With .Shapes.AddShape(msoShapeRectangle, tc.Left, tc.Top, tc.Width, tc.Height)
24            .TextFrame.Characters.Text = fc.Value
25            ' クリック時に呼び出す関数を登録
26            .OnAction = "'text_OnClick2""" & .Name & "," & "C4" & """'"
27        End With
28    End With
29    
30End Sub
31
32Sub text_OnClick(nm As String)
33    
34    Static fnm As String ' 吹き出しNAME
35    Static nms As String
36    Dim s As Shape
37    
38    If nm = nms Then
39        GoTo ENDPROC
40    End If
41    nms = nm
42    
43    With ActiveSheet
44        x = .Shapes(nm).Left
45        y = .Shapes(nm).Top
46        w = .Shapes(nm).Width
47        h = .Shapes(nm).Height
48    End With
49        
50    ' 吹き出しを作成
51    With ActiveSheet.Shapes.AddShape(msoShapeBalloon, x + w + 10, y - h, 100, 100)
52        .TextFrame.Characters.Text = ActiveSheet.Shapes(nm).TextFrame.Characters.Text
53        fnm = .Name
54    End With
55
56    ' 5秒ウェイト
57    For i = 1 To 50
58        Sleep 100
59        DoEvents
60    Next
61
62ENDPROC:
63    ' 吹き出しを削除
64    For Each s In ActiveSheet.Shapes
65        If s.Name = fnm Then
66            s.Delete
67        End If
68    Next
69    nms = ""
70
71End Sub
72
73Sub text_OnClick2(param As String)
74    
75    Dim pa() As String
76    Dim nm As String
77    Static nms As String
78    Static xy As String
79
80    pa = Split(param, ",")
81    nm = pa(0)
82    xy = pa(1)
83
84    If pa(0) = nms Then
85        GoTo ENDPROC
86    End If
87    nms = nm
88
89
90    With ActiveSheet
91        .Range(xy).AddComment (.Shapes(nms).TextFrame.Characters.Text)
92        .Range(xy).Comment.Visible = True
93    End With
94
95    ' 5秒ウェイト
96    For i = 1 To 50
97        Sleep 100
98        DoEvents
99    Next
100
101ENDPROC:
102    ' コメントを削除
103    With ActiveSheet
104        If Not .Range(xy).Comment Is Nothing Then
105            .Range(xy).Comment.Delete
106        End If
107    End With
108    nms = ""
109
110End Sub
111
112

投稿2016/10/19 06:49

編集2016/10/20 02:30

ttyp03

総合スコア17000

rainbow_trip

2016/10/20 00:41

ttyp03さん早速ありがとうございますやはり、シェイプにはコメント機能がないのですねイメージはボタンをさわるとボタン名が出てくるような感じで TEXT BOXをさわると四角い窓がでて、全文が読める感じがよいですずいぶん昔のエクセルにそのような機能があったと思うのですが消えてしまったのかもしれませんねおっしゃったようにシェイプをクリックイベントで何かできないものかと思いました作成して頂いた構文で組んでみましたが、シェイプ対象が定まらず… もう少し、お力お貸し頂けたらと思いますシェイプは複数あって（１０個前後）１　目的のシェイプをクリックしたら、そこをアクティブにして、座標取得２　シェイプの中身（もしくは変数 MSG）をコメントにみたてて表示　　（サンプルでは100四方サイズ）３　ダブルクリックしたら、コメントシェイプの削除　　（ダブルクリックイベント）みたいな感じは可能でしょうかまだ初心者で勉強中の身ですが・・・よろしくお願いします

ttyp03

2016/10/20 02:32

最初に回答したようにイベントはクリックイベントしかないようなのでダブルクリックは無理です。クリックしたテキストボックスを対象にした改良版を貼っておきました。また吹き出しではなくセルにコメントを追加するのも作ってみました。参考にしてください。

rainbow_trip

2016/10/20 05:01

ttyp03さん早速ありがとうございます！しかも２パターン作成して頂き、感激です！テキストボックスの位置にコメント追加の機能がよかったです（text_OnClick2）しかし、やってみたところ、コマンドボタンクリックができなくなってしまいましたこのボタンもシェイプ対象となってしまうようですね 10行目から83行目のみ、有効になるような指定はできますでしょうかこれはシートモジュールに入れるコードと認識して大丈夫ですよね？引き続きよろしくお願いいたします

ttyp03

2016/10/20 05:16

コマンドボタンは別問題かと思いますが…。今回のサンプルはあくまでもテキストボックスを作成するところにしか影響がないはずです。

rainbow_trip

2016/10/20 08:01

ありがとうございますこのコードにて研究してみますね

行動規範の内容に同意します