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

excelで、大きなオートシェイプのテキストボックスの中に、いくつかの小さな
やはりオートシェイプのテキストボックスを貼り付けます。

通常は小さなテキストボックスに文字を入力して使うのですが、全ての小さな
テキストボックスに何の文字も入力されていない場合は、大きなテキストボックスに
自動で斜線（シェイプの直線？）が入り、またどれか一つでも小さなテキストボックスに
文字が入力された場合は自動で斜線が消える様にしたいのです。

　　　　　＿＿＿＿＿＿＿＿＿＿＿＿＿
　　　　｜　　　 ＿＿＿＿　　　　　　　 　／｜
　　　　｜　　｜＿＿＿＿｜ 　　　　 ／　　｜
　　　　｜　　　 ＿＿＿＿　　 　　／　　　　｜
　　　　｜　　｜＿＿＿＿｜　／　　　　　　｜
　　　　｜　　　　　　　　　　／　　　　　　　　｜
　　　　｜　　　　　　　　／　 ＿＿＿＿　　 ｜
　　　　｜　　　　　　／　　｜＿＿＿＿｜　｜
　　　　｜　　　　／　　　　　　　　　　　　　　｜
　　　　｜　　／　　　　　　　　　　　　　　　　｜
　　　　｜／　　　　　　　　　　　　　　　　　　｜
　　　　 　￣￣￣￣￣￣￣￣￣￣￣￣￣

こんな感じなのですが、ＶＢＡで可能でしょうか？

以前もこんな感じの質問をしたばかりで恐縮ではありますが、よろしくお願いいたします。

No.1 回答者： x1yobigun 回答日時： 2008/03/27 18:13

斜線を入れる機能は、ワークシートのセルにはありますが、

テキストボックスには（そのためのプロパティが）無いように
思われます。
で、大きい外枠を、セル（連結セル）で表現するならできます。

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

エラーチェックとかは書いていませんが・・・

この回答へのお礼

早速のご回答ありがとうございます。
書いていただいたものは、間違いなく動作いたしました。

説明不足でしたがexcelシートにまず画像を貼り付け、その画像の上に
(コントロールツールボックスからではなく)オートシェイプのテキスト
ボックスを色なし、線なしの設定で貼り付けて文字を入力し、下の画像
を隠すことなく文字だけを表示させたいのです。
画像があるため、さらにその下のセルを選択することは出来ない状態です。

お礼日時：2008/03/27 20:40

No.2 回答者： okormazd 回答日時： 2008/03/28 09:58

>ＶＢＡで可能でしょうか？

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

この回答へのお礼

ご回答ありがとうございます。
ＶＢＡをよく知らないとは言え、ずいぶん面倒な質問をしていたようでお恥ずかしい限りです。
もっと実用的な方法で考えてみたいと思います。ありがとうございました。

お礼日時：2008/03/29 19:31

No.3 回答者： Wendy02 回答日時： 2008/03/28 14:37

こんにちは。

ものすごくややこしいです。
意味は分かるけれども、根本的な問題がひとつ思い当たります。
それは、大きなテキストボックス(アウターテキストボックス）の数の問題です。ひとつとか、ふたつとか、書かれていませんから、それを探すことをしなければなりません。

アウターテキストボックスをマクロで探すということをマクロでするということは、比較をしなくてはなりません。中にあるのもテキストボックスであるという条件ですから、それぞれの比較をしていかなくてはならないわけです。

一つの大きなテキストボックスを見つけたら、その領域にある小さなテキストボックスを探すということになります。

>自動で斜線が消える様にしたいのです。
というのは、このようなスタイルの場合は、クラス・インスタンスになるのですが、それは、ちょっと、欲張りすぎですね。既存に対するものは、オートシェイプのプロパティで　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

この回答への補足

実用的な方法で考えたいと思います。

以前、lark_0925様にテキストボックスをクリックするたびに楕円を表示したり、消したりする方法として

標準モジュールに
Option Explicit
'===================================================================
Sub テキスト1_Click()
　　Dim shpnm As Variant
　　Dim shp As Shape
　　Dim ovl As Object
　　On Error Resume Next
　　shpnm = Application.Caller
　　If TypeName(shpnm) = "String" Then
　　　With ActiveSheet
　　　　　On Error Resume Next
　　　　　Set ovl = .Ovals("ovl_" & shpnm)
　　　　　If Err.Number <> 0 Then
　　　　　　Set shp = .Shapes(shpnm)
　　　　　　With .Ovals.Add(shp.Left, shp.Top, shp.Width, shp.Height)
　　　　　　　　.Name = "ovl_" & shpnm
　　　　　　　　.ShapeRange.Fill.Transparency = 1#
　　　　　　　　.OnAction = "ovl_del"
　　　　　　　　End With
　　　　　Else
　　　　　　ovl.Visible = True
　　　　　　End If
　　　　　End With
　　　End If
End Sub
'===================================================================
Sub ovl_del()
　　Dim shpnm As Variant
　　On Error Resume Next
　　shpnm = Application.Caller
　　If TypeName(shpnm) = "String" Then
　　　With ActiveSheet
　　　　　On Error Resume Next
　　　　　.Shapes(shpnm).Visible = False
　　　　　On Error GoTo 0
　　　　　End With
　　　End If
End Sub

上記のテキスト1_Clickというマクロを登録してください。
対象テキストボックスのクリックで楕円作成または、既存楕円の表示。
作成された楕円クリックで楕円を非表示にします。
（図形を作成・削除を繰り返すことは避けています）

と言うのを教えていただきました。（lark_0925様、無断転載すみません。）
こんな感じで、テキストボックスをクリックするたびにシェイプの直線で、右上から左下に斜線を入れるという事だけをしたいと思います。
自分なりに「ovl」を「AddLine」に変えてみたり、サイズや位置などを指定してみたのですが、うまくいきません。

よろしくお願いいたします。

補足日時：2008/03/29 21:24

この回答へのお礼

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

「ややこしい」「欲張りすぎ」と言われて気付きました、ＶＢＡを何でも出来る夢の様なツールか何かと勘違いしていた事を・・・。
何も知らない素人が、あれもこれもと無理を言うのを笑って見ていましたが、私がそうなっていましたね。お恥ずかしい限りです。
完全に教えて君で行こうと思ったのが間違いでした。

さほど時間もかけずに、これほどの物が作れる事に驚きと尊敬の念を覚えます。

もう少し実用的な方法で考えたいとおもいます。ありがとうございました。

お礼日時：2008/03/29 20:58

No.4 ベストアンサー 回答者： Wendy02 回答日時： 2008/03/30 21:27

こんばんは。

基本的に、他人のコードはいじらないようにしていますが、こういう方式はどうか、ということをおっしゃるわけですね。

参考にはなりましたが、このコードは、今回のものとは、クリックする対照物が違っていますから、同じようには行かないはずです。今回の場合は、円にマクロを登録することは出来ませんし、線をクリックするわけではないからです。

ただ、そのコードをみて、このコードを書いた人は、オートシェイプの問題を知っていたのでしょうか

>　　　　　.Shapes(shpnm).Visible = False
私も、こうすることで、オートシェイプを書いたり消しているうちに、言うことが利かなくなる問題を対処することが出来るのですが、私は、このことをすっかり忘れていました。

これは、私の書いた前回のコードを移植しました。
なお、斜め線は、テキストボックスの中にあれば、どこにあっても「線を一本」は消します。正確には、トグルになっていて、線が表示していれば、消し、消されていたら、表示します。何もない状態なら、斜め線が引かれます。

マクロの線の出がおかしいときは、.Select 下の行に、細かい、プロパティ（例えば、ColorIndex, Weight, LineStyle) を入れてあげると、問題が解決することが多いです。

「標準モジュール」に登録し、テキストボックスのマクロの登録に入れてください。


Sub DiagonalLine_Click()
　　Dim OutTxtBox As TextBox
　　Dim shp As Shape
　　Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
　　On Error Resume Next
　　With ActiveSheet.Shapes(Application.Caller)
　　　　If StrComp(TypeName(.DrawingObject), "TextBox", 1) = 0 Then
　　　　　　Set OutTxtBox = .DrawingObject
　　　　Else
　　　　　　Exit Sub
　　　　End If
　　End With
　 If Err.Number > 0 Then Exit Sub
　 On Error GoTo 0
　If LineChecker(OutTxtBox) = False Then
　With OutTxtBox
　　　　'.AddLine(BeginX, Beginy, EndX, EndY)
　　　　x1 = .Left + .Width: y1 = .Top
　　　　x2 = .Left: y2 = .Top + .Height
　　　With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
　　　　 .Select
　　　End With
　 End With
　End If
　Set OutTxtBox = Nothing
End Sub
Private Function LineChecker(OutTextBox As TextBox)
Dim rng As Range
Dim shp As Shape
Dim flg As Boolean
　　flg = False
　　Set rng = Range(OutTextBox.TopLeftCell, OutTextBox.BottomRightCell)
　　For Each shp In ActiveSheet.Shapes
　　　　If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then
　　　　　　If StrComp(TypeName(shp.DrawingObject), "Line", 1) = 0 Then
　　　　　　　 shp.Visible = Not shp.Visible
　　　　　　　 flg = True
　　　　　　　 Exit For '一つ消したら終わり
　　　　　　End If
　　　　End If
Next shp
　LineChecker = flg
　Set rng = Nothing
End Function

この回答へのお礼

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

人並みに年度始めにつき忙しく、お礼が遅くなりました。もうしわけありません。
せっかく書いて頂きましたが、私の理解をはるかに超えており、うまく動いてくれません。
登録すらうまく出来ていないような気がします。
しかし、もう十分教えて頂きました。後は自分で勉強して解決したいと思います。

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

お礼日時：2008/04/04 22:57