VBAでテキストボックスに斜線を入れるには？

こんにちは。 ものすごくややこしいです。 意味は分かるけれども、根本的な問題がひとつ思い当たります。 それは、大きなテキストボックス(アウターテキストボックス）の数の問題です。ひとつとか、ふたつとか、書かれていませんから、それを探すことをしなければなりません。 アウターテキストボックスをマクロで探すということをマクロでするということは、比較をしなくてはなりません。中にあるのもテキストボックスであるという条件ですから、それぞれの比較をしていかなくてはならないわけです。 一つの大きなテキストボックスを見つけたら、その領域にある小さなテキストボックスを探すということになります。 >自動で斜線が消える様にしたいのです。 というのは、このようなスタイルの場合は、クラス・インスタンスになるのですが、それは、ちょっと、欲張りすぎですね。既存に対するものは、オートシェイプのプロパティで　OnActionに入れられるのですが、作ったり消したりというようなものには、OnAction は使えません。 それから、アウターテキストボックスの、ある程度の推定の大きさを決めておくことにします。 以下の場合は、SizeCnt というもので、30以下（セルの数）を小さなテキストボックスとしています。左上の端がはみ出たりしたものは、チェックの対象としていません。 それに、これは、最初に見つけたアウターテキストボックスに1個に対してのみです。最後に、本来は、グループ化したほうが良いのですが、今度は、消すほうが出来なくなってしまいますし、コードがさらに面倒になります。下に画像を入れるとか一切考慮されておりません。 標準モジュール設定を条件としています。サンプルとして参考にしてみてください。なお、マクロの練習としては良い材料ですが、実務的には、この種のものは、マクロにするのは考えないほうがよいと思います。ややこしい上に、不具合が続きます。 Excelでは、こういうオブジェクトを操作するのは、あまり得意ではありません。理由は、オブジェクトの数は、思った以上に上限の数が決められてしまっているからです。（私が、昔、Excel2000でやったときには、だいたい、1,000回以上で、オートシェイプのマクロの出具合が悪くなりました。） なお、別にこの程度を作るのに、さほど時間は掛からないけれども、仕事では、私はこのようなものは作らないですね。完成度も実務度も低いからです。一度、作ってしまうと、もう二度と修正が利きませんしね。（^^; '------------------------------------------- Dim SizeCnt As Integer Sub TestLineDraw1() 　　Dim OutTxtBox As TextBox 　　Dim shp As Shape 　　Dim flg As Boolean 　　Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double 　　 　　SizeCnt = 30 '大きなテキストボックスの大きさの下限 　　 　　flg = False 　　'On Error Resume Next 　　For Each shp In ActiveSheet.Shapes 　　　　If StrComp(TypeName(shp.DrawingObject), "TextBox") = 0 Then 　　　　　　If Range(shp.TopLeftCell, shp.BottomRightCell).Count > SizeCnt Then 　　　　　　　　Set OutTxtBox = shp.DrawingObject 　　　　　　　　Call InnerTextBoxChecker(Range(OutTxtBox.TopLeftCell, OutTxtBox.BottomRightCell), flg) 　　　　　　　　If flg = False Then 　　　　　　　　　　With OutTxtBox 　　　　　　　　　　　　'.AddLine(BeginX, Beginy, EndX, EndY) 　　　　　　　　　　　　x1 = .Left + .Width: y1 = .Top 　　　　　　　　　　　　x2 = .Left: y2 = .Top + .Height 　　　　　　　　　　End With 　　　　　　　　　　ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select 　　　　　　　　　　Set OutTxtBox = Nothing 　　　　　　　　　　Exit For 　　　　　　　　Else 　　　　　　　　　　Call LineDelete(Range(OutTxtBox.TopLeftCell, OutTxtBox.BottomRightCell)) 　　　　　　　　　　Set OutTxtBox = Nothing 　　　　　　　　　　Exit For 　　　　　　　　End If 　　　　　　 　　　　　　End If 　　　　End If 　　Next End Sub Sub InnerTextBoxChecker(ByVal rng As Range, ByRef flg As Boolean) Dim shp As Shape Dim cnt As Integer For Each shp In ActiveSheet.Shapes If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then If Range(shp.TopLeftCell, shp.BottomRightCell).Count < SizeCnt Then 　If StrComp(TypeName(shp.DrawingObject), "TextBox") = 0 Then 　　　cnt = cnt + 1 　　　If shp.DrawingObject.Text <> "" Then 　　　　flg = True 'false =文字あり 　　　End If 　End If End If End If Next shp If cnt = 0 Then 　MsgBox "外部テキストボックスの中には、テキストボックスがありません。終了します。", 48 　End End If End Sub Sub LineDelete(ByVal rng As Range) 　　Dim shp As Shape 　　For Each shp In ActiveSheet.Shapes 　　　　If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then 　　　　　　If StrComp(TypeName(shp.DrawingObject), "Line") = 0 Then 　　　　　　　　shp.Delete 　　　　　　End If 　　　　End If 　　Next shp End Sub

>ＶＢＡで可能でしょうか？ といわれれば、可能ですと答えますが、このシートに他の画像やグラフがあるかどうかとか、テキストボックスの大きさはある程度決まっているのかとか、グループ化しているかとかわかればいいし、このテキストボックスの配置する範囲や数などもわかればいい。数が多いと質問の趣旨は実現できても動作が遅くて実用的でなくなることもあるから。 あと、このくらいの問題だと仕事でならやるが、暇がないとすぐにはやらない。

斜線を入れる機能は、ワークシートのセルにはありますが、 テキストボックスには（そのためのプロパティが）無いように 思われます。 で、大きい外枠を、セル（連結セル）で表現するならできます。 Private Sub TextBox1_Change() 　　If (TextBox1.Value = "") Then 　　　　Range("B2:F22").Select 　　　　With Selection.Borders(xlDiagonalUp) 　　　　　　.LineStyle = xlContinuous 　　　　　　.Weight = xlHairline 　　　　　　.ColorIndex = xlAutomatic 　　　　End With 　　　　Range("A1").Select 　　　Else 　　　　Range("B2:F22").Select 　　　　With Selection.Borders(xlDiagonalUp) 　　　　　.LineStyle = xlNone 　　　　End With 　　　　Range("A1").Select 　　End If End Sub エラーチェックとかは書いていませんが・・・