回答編集履歴

改良版

2016/10/20 02:30

投稿

ttyp03

スコア16998

test CHANGED Viewed

@@ -89,3 +89,253 @@
 ```
+---
+改良版です。
+２パターン作ってみました。
+1つ目は前回の改良版です。
+クリックしたテキストボックスの横に吹き出し図形を作成します。
+2つ目は、テキストボックスの位置のセルにコメントを追加して、それを表示させています。
+どちらも5秒後に自動的に消えます。
+また再クリックで即削除します。
+test関数を実行すると、B2セルの値でC2セルの位置にパターン1のテキストボックスを、
+B4セルの値でC4セルの位置にパターン2のテキストボックスを作成します。
+いずれも無理やり感は否めません…。
+```VBA
+' API定義
+Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
+Sub test()
+    Dim fc As Range
+    Dim tc As Range
+    ' 吹き出しを作成するパターン
+    With ActiveSheet
+        Set fc = .Range("B2")
+        Set tc = .Range("C2")
+        With .Shapes.AddShape(msoShapeRectangle, tc.Left, tc.Top, tc.Width, tc.Height)
+            .TextFrame.Characters.Text = fc.Value
+            ' クリック時に呼び出す関数を登録
+            .OnAction = "'text_OnClick""" & .Name & """'"
+        End With
+    End With
+    ' テキストボックスの裏のセルにコメントを作成するパターン
+    With ActiveSheet
+        Set fc = .Range("B4")
+        Set tc = .Range("C4")
+        With .Shapes.AddShape(msoShapeRectangle, tc.Left, tc.Top, tc.Width, tc.Height)
+            .TextFrame.Characters.Text = fc.Value
+            ' クリック時に呼び出す関数を登録
+            .OnAction = "'text_OnClick2""" & .Name & "," & "C4" & """'"
+        End With
+    End With
+End Sub
+Sub text_OnClick(nm As String)
+    Static fnm As String ' 吹き出しNAME
+    Static nms As String
+    Dim s As Shape
+    If nm = nms Then
+        GoTo ENDPROC
+    End If
+    nms = nm
+    With ActiveSheet
+        x = .Shapes(nm).Left
+        y = .Shapes(nm).Top
+        w = .Shapes(nm).Width
+        h = .Shapes(nm).Height
+    End With
+    ' 吹き出しを作成
+    With ActiveSheet.Shapes.AddShape(msoShapeBalloon, x + w + 10, y - h, 100, 100)
+        .TextFrame.Characters.Text = ActiveSheet.Shapes(nm).TextFrame.Characters.Text
+        fnm = .Name
+    End With
+    ' 5秒ウェイト
+    For i = 1 To 50
+        Sleep 100
+        DoEvents
+    Next
+ENDPROC:
+    ' 吹き出しを削除
+    For Each s In ActiveSheet.Shapes
+        If s.Name = fnm Then
+            s.Delete
+        End If
+    Next
+    nms = ""
+End Sub
+Sub text_OnClick2(param As String)
+    Dim pa() As String
+    Dim nm As String
+    Static nms As String
+    Static xy As String
+    pa = Split(param, ",")
+    nm = pa(0)
+    xy = pa(1)
+    If pa(0) = nms Then
+        GoTo ENDPROC
+    End If
+    nms = nm
+    With ActiveSheet
+        .Range(xy).AddComment (.Shapes(nms).TextFrame.Characters.Text)
+        .Range(xy).Comment.Visible = True
+    End With
+    ' 5秒ウェイト
+    For i = 1 To 50
+        Sleep 100
+        DoEvents
+    Next
+ENDPROC:
+    ' コメントを削除
+    With ActiveSheet
+        If Not .Range(xy).Comment Is Nothing Then
+            .Range(xy).Comment.Delete
+        End If
+    End With
+    nms = ""
+End Sub
+```