[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『図のテキストによって文字色等操作』（koko）
ご教示願います
Sub 図操作()
Dim myz As Shape
For Each myz In ActiveSheet.Shapes
Select Case myz.Text
Case 1,2,3
Font.Color = 3
Font.Size = 12
Font.Bold = True
Case 4,5,6
Font.Color = 5
Font.Size = 10
Font.Bold = false
End Select
Next myz
End Sub
ActiveSheetに角丸四角形やコネクタ、Picture等が複数あります。
これらには「1..9」の数字または「次へ」「終了」等が入力（入力無も有）されています。
上のコードはイメージのコードです（全然動きません）
図のテキストによって図のテキスト色やテキストサイズを分岐したいです。
ｴｸｾﾙ2007を使用しています。マクロの記録では何も記録されませんでした。
宜しくお願い致します。
う〜ん・・・仕上げるまでには、苦労しそうだねぇ。
まず、「全然動きません」だけど、動かしても結果が出ないで空振りするとか、動かしたら実行時エラーになるといった そんなレベル以前のコンパイルエラーではないの？ たとえば Font.Color とだけ記述して参照できる変数（プロパティ）はエクセルＶＢＡには存在しない。 必ず ○○○.Font. あるいは ○○○.□□□.Font. といったように指定することが必要。
で、次に、Shapeとして取得したものの属性を調べようとすれば、myz.△△△.Text といったように指定する必要があるものがほとんど。 で、この△△△は、Shapeの種類によっても異なるし、おなじ種類のShapeであっても、参照すべき属性によっては様々、ことなる場合がある。 たとえば四角形なんかのテキストであれば myz.DrawingObject.Text 。 さらにやっかいなのは、テキストが未入力で、これを参照しようとすれば、実行時エラーになる。
さらに、さらに。 シート上には様々なShapeがある。これらのタイプによっては Textをもっているものもあればないものもある。 ものによっては Textではなく Caption として参照しなければいけないものもある。
ちゃんと処理しようとすれば、シェープのタイプを判定し、かつテキストが入っているかどうかを判定し、 かつ、事前判定ができないものもあるので、好きじゃないけどエラーバイパスをして・・・
といったテーマだねぇ。
シート上には、四角形とか、楕円とか、いわゆるオートシェープだけしかないという条件なら、少しは シンプルなロジックにできるけどね。
(ぶらっと)
大変ですが、Helpを良く探ることですよ！！ Shapeオブジェクトは、直接にはTextというプロパティを持っていません。
又、Shapeコレクションには、コネクタ、Picture等も含まれますよね！！ これらにテキストは、直接付加できません。
１ 図のテキストボックスだけを見るのであれば、図のテキストボックスか そうでないか の区別が必要です。 又は、Shapesではなく、テキストボックスコレクションを調べる方法もありますが、 今回は、省略。
２ テキストデータを持てるShapeか、持てないShapeかで区別しなければならない 仕様でしょうか？
１の場合は、Shapeオブジェクトの Typeプロパティ調べて区別します。
Sub test1()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
MsgBox shp.Name & ":" & shp.Type
Next
End Sub
こんなコードで調べると 図形とTypeの関係が見えてきます。
２の場合は、TextframeオブジェクトのCharactersオブジェクトの存在を チェックします。
Sub test1()
Dim shp As Shape
Dim txt As String
For Each shp In ActiveSheet.Shapes
If exist_txt(shp, txt) = 0 Then
MsgBox shp.Name & " ：テキスト設定可能: " & txt
Else
MsgBox shp.Name & " ：テキスト設定不可能"
End If
Next
End Sub
'=============================================================
Function exist_txt(ByVal shp As Shape, txt As String) As Long
'exist_txt 0:存在可能 1:存在不可
'txt exist_txtが0のとき、テキストの内容
Dim cha As Characters
On Error Resume Next
Set cha = shp.TextFrame.Characters
exist_txt = Err.Number
If Err.Number = 0 Then
txt = ""
txt = shp.TextFrame.Characters.Text
End If
On Error GoTo 0
End Function
後は、検討してみてください。
ichinose
この場合は、旧分類のTextBoxesコレクションが便利です。
Sub Sample()
Dim i As Long
For i = 1 To ActiveSheet.TextBoxes.Count
With ActiveSheet.TextBoxes(i)
Select Case .Text
Case 1, 2, 3
.Font.ColorIndex = 3
.Font.Size = 12
.Font.Bold = True
Case 4, 5, 6
.Font.ColorIndex = 5
.Font.Size = 10
.Font.Bold = False
End Select
End With
Next
End Sub
（あすなろ）
>この場合は、旧分類のTextBoxesコレクションが便利です。 本当ですね！！Textboxesコレクションは、テキストがあると、コレクションに含ますね！！
じゃあ、 >又は、Shapesではなく、テキストボックスコレクションを調べる方法もありますが、 今回は、省略。
これは、２の対策法に近いかなあ・・・。
バージョンが進んでいくと旧オブジェクトが動かない現象が確認されているみたいなので(2007は持っていないので確認はできませんが）、 今回は、Shapeで探りました。
ichinose
横から失礼
質問文だけではわからないけど、もし「文字が入力されていないもの」に対しても何かの処理をしたいという要件があるなら TextBoxesでは、文字が入力されているもののみの取得になるという留意点があるかな？
(ぶらっと)
皆様 有難うございます。 急な仕事でお礼が遅くなりました。申し訳ありません 図形操作はハードルが高いのですね。 ＞Font.Color とだけ記述して参照できる変数（プロパティ）はエクセルＶＢＡには存在しない。 Font.Colorとだけ記載で駄目な事は解っていましたが、 ＞おなじ種類のShapeであっても、参照すべき属性によっては様々 というのが解っていませんでした。 1種類のmyz.△△△.Text だけでいけるものと勝手に思っていました。
＞Helpは見れるのですよね？ 物理的にはもちろん見れます。で、とりあえず見るだけは見たのですが、 ？？でしたのであきらめてしまいました。 理解できる種類のHelpも時々はあるのですが、今回は完全にアウトでした。 ＞１の場合は、Shapeオブジェクトの Typeプロパティ調べて区別します。 ＞２テキストデータを持てるShapeか、持てないShapeかで区別しなければならない 仕様でしょうか 持てるShapeと持てないShapeの存在を今日知りました。
＞この場合は、旧分類のTextBoxesコレクションが便利です すみません。理解できませんでした。
自分のスキルでは相当難題みたいですね。 自宅と職場のｴｸｾﾙは2007ですが、まだ2003を使っている部署があったはずなので パソコンが空いている時に、お願いしてマクロの記録で挑戦してみます。 myz.△△△.Textとmyz.△△△.Font.Colorなどを shp.Type単位で調べればいいと言う事ですよね。 textがない図に関してはスルー処理なので on error resume next を考えています。 有難うございました。 (KOKO)
＞この場合は、旧分類のTextBoxesコレクションが便利です あっ ちょっとだけ理解できました。 このファイルの図のうち 1 2 3・・・等が入力されている図を テキストボックスに統一する方向で考えてみます 有難うございました。 (koko)
2010 だとマクロの記録でとれるんですけどね。
一応こちらで記録した結果を基にした結果です。
Sub 図操作()
Dim myz As Shape
For Each myz In ActiveSheet.Shapes
With myz.TextFrame2.TextRange
Select Case .Text
Case "1", "2", "3"
.Characters.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Characters.Font.Size = 12
.Characters.Font.Bold = True
Case "4", "5", "6"
.Characters.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
.Characters.Font.Size = 10
.Characters.Font.Bold = False
End Select
End With
Next myz
End Sub
直接の記録結果はこんな感じでした。
ActiveSheet.Shapes.Range(Array("Oval 1")).Select
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
ご参考までに。 (Mook)
>この場合は、旧分類のTextBoxesコレクションが便利です >あっ ちょっとだけ理解できました。 >このファイルの図のうち 1 2 3・・・等が入力されている図を >テキストボックスに統一する方向で考えてみます
えーと、そう言う事ではなく、オートシェープの四角や楕円等テキストを 挿入した図形は、旧TextBoxesコレクションを使うとすべてテキストボックス として扱ってくれるので、皆さんがおっしゃってるように、ShapeのTypeや テキストの有無等を調べなくても、テキストのある図形だけ（フォームの ボタン等は除外）を対象に出来ますと言う事です。
Shapeは非常に複雑なので皆さんの意見を参考に勉強されたらいいと思います。 参考までに、旧分類コレクションは以下の６種類の図形です。 Rectangles 四角形 Ovals 楕円 Lines 直線 TextBoxes テキストボックス Drawings フリーフォーム Pictures 図（画像）
（あすなろ）
Mookさん
有難うございます。
MookさんのSub 図操作()を実行させますと
「指定された値は境界を超えています」とメッセージが出て
With myz.TextFrame2.TextRangeが黄色くなります。
なので
Sub 図操作()
Dim myz As Shape
For Each myz In ActiveSheet.Shapes
' On Error Resume Next’←追加しました。
With myz.TextFrame2.TextRange
Select Case .Text
Case "1", "2", "3"
.Characters.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
.Characters.Font.Size = 12
.Characters.Font.Bold = True
Case "4", "5", "6"
.Characters.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
.Characters.Font.Size = 10
.Characters.Font.Bold = False
End Select
End With
Next myz
End Sub
このようにしました。実行させるとアクティブシートに変化はないのですが
図をクリックすると色等が変化しました。
これはいったい？
あすなろさんへ
有難うございます
Sub Sample2()
Dim i As Long
For i = 1 To ActiveSheet.Rectangles.Count
With ActiveSheet.Rectangles(i)
Select Case .Text
Case 1, 2, 3
.Font.ColorIndex = 3
.Font.Size = 12
.Font.Bold = True
Case 4, 5, 6
.Font.ColorIndex = 5
.Font.Size = 10
.Font.Bold = False
End Select
End With
Next
End Sub
のようにしました。
Mookさんのコードと同じように実行しても変化は見えないのですが
図をクリックすると図が変化しました。
この現象の原因についてご想像がおつきでしたら、ご教示願います。 宜しくお願い致します。 （koko)
エラーの内容はわかりませんが、 On Error Resume Next はエラーを表示しないだけで、エラーが出なくなったわけではありません。 ですから、エラーが出ないようにコードの修正をする必要があります。 (Mook)
On Error ステートメントは、Goto文と同じように使い方が難しいステートメントです。 ただ、Goto文は、使わなくてもコードは記述できるのに対し、On Error ステートメント は、全く使わないというわけにはいきません。 だったら、使い方や動作を良く学んでうまく使うことです。 うまく使うというのは、On Error ステートメントを使っても、 わかりやすいプログラムになるようにすることです。
まっ、これは、VBAを（いえ、プログラミングを）本気で学ぶ気があれば、 考えてみてください。
新規ブックにて、以下を試してみてください。
標準モジュールに
'===================================================
Sub 準備1()
Dim shp As Shape
With ActiveSheet
For Each shp In .Shapes
shp.Delete
Next
With .Rectangles.Add(10, 10, 100, 100)
.Text = "1"
End With
End With
End Sub
'==================================================================
Sub test1()
Dim i As Long
For i = 1 To ActiveSheet.Rectangles.Count
With ActiveSheet.Rectangles(i)
Select Case .Text
Case 1, 2, 3
.Font.ColorIndex = 3
.Font.Size = 12
.Font.Bold = True
Case 4, 5, 6
.Font.ColorIndex = 5
.Font.Size = 10
.Font.Bold = False
End Select
End With
Next
End Sub
まず、準備1を実行してください。アクティブシートに四角形が作成されます。
続いて、test1を実行してください。
四角形の文字 1 は、変化（1が赤色になり、文字サイズ12と太字設定）しましたか？
再度、新規ブックにて
標準モジュールに
'===================================================
Sub 準備2()
Dim shp As Shape
With ActiveSheet
For Each shp In .Shapes
shp.Delete
Next
With .Rectangles.Add(10, 10, 100, 100)
.Text = "1"
End With
With .Rectangles.Add(10, 310, 100, 100)
.Text = "4"
End With
End With
End Sub
'==============================================================
Sub test2()
Dim i As Long
For i = 1 To ActiveSheet.Rectangles.Count
With ActiveSheet.Rectangles(i)
Select Case .Text
Case 1, 2, 3
.Font.ColorIndex = 3
.Font.Size = 12
.Font.Bold = True
Case 4, 5, 6
.Font.ColorIndex = 5
.Font.Size = 10
.Font.Bold = False
End Select
End With
Next
End Sub
まず、準備2を実行してください。アクティブシートに今度は、二つ四角形が作成されます。
続いて、test2を実行してください。
二つの四角形の文字は、変化しましたか？
結果はどうでしょうか？
ichinose
Mookさんへ ＞ですから、エラーが出ないようにコードの修正をする必要があります。 はい。頑張ります。
ichinoseさんへ 有難うございます。 ＞VBAを（いえ、プログラミングを）本気で学ぶ気があれば、 学ぶ気持ちはあるのですが いくら頑張ってもプロにはなれそうにないですし 現在の仕事を効率よくさせるコードをスラスラ書けるレベルを 目指している程度ですので、本気で学ぶ...と言われるとちょっと弱いです。
書いていただいたコード実行しました。 準備１で四角形は作成されました test１を実行しても変化はありませんが、 図形を選択してテキストを触ると色が変化します。 テキストの編集をする時と同じ動作をすると色が変化します 実際には編集はしません。 編集する時の前段階で四角形のなかの「１」を選択する動作のタイミングで色が変化します。 準備2とtest2も全く同じです。 自宅でのテストだけですので、明日職場のパソコンでテストしてみます。 (koko)
では、もうひとつだけ・・・。
新規ブックにて
標準モジュールに
'====================================================================
Sub 準備1()
Dim shp As Shape
With ActiveSheet
For Each shp In .Shapes
shp.Delete
Next
With .Rectangles.Add(10, 10, 100, 100)
.Text = "1"
End With
End With
End Sub
'====================================================================
Sub test1()
Dim i As Long
For i = 1 To ActiveSheet.Rectangles.Count
With ActiveSheet.Rectangles(i)
Select Case .Text
Case 1, 2, 3
.Font.ColorIndex = 3
.Font.Size = 12
.Font.Bold = True
Case 4, 5, 6
.Font.ColorIndex = 5
.Font.Size = 10
.Font.Bold = False
End Select
Doevents
.Text = .Text
End With
Next
End Sub
準備1を実行してください。アクティブシートに四角形が作成されます。
続いて、test1を実行してください。
四角形の文字 1 は、変化（1が赤色になり、文字サイズ12と太字設定）しましたか？
これで駄目なら、同一バージョンを持っていないので何ともいえませんが・・・。
>現在の仕事を効率よくさせるコードをスラスラ書けるレベルを 目指している程度です でしたら、On Errorステートメントの使い方は、覚えた方が良いと思いますよ！！
ichinose
お邪魔します。
前回提示したTextBoxesコレクションは2010では
うまく認識しない様です。検証不足でした。
2007については環境がないので良くわからないのですが、
スレの中で何度もおっしゃってる、以下の現象が
> 実行しても変化は見えないのですが
> 図をクリックすると図が変化しました
2010では再現出来ません。
で、以下のサンプルを2007で新規ブックにコピーして頂いて Test_01を実施後、Test_02を実施してみてください。 両サンプルとも、2003,2010で動作確認済みです。
Sub Test_01()
Dim i As Long
Dim r As Long
Dim c As Long
Dim shp As Shape
ActiveSheet.DrawingObjects.Delete
For i = 1 To 16
r = ((i - 1) Mod 8) * 4 + 2
c = Int((i - 1) / 8) * 3 + 2
With ActiveSheet.Cells(r, c).Resize(3, 2)
Set shp = .Parent.Shapes.AddShape(i, .Left, .Top, .Width, .Height)
End With
With shp
.Fill.ForeColor.SchemeColor = 1
.Line.ForeColor.SchemeColor = 8
.Line.Weight = 1
With .TextFrame.Characters
Select Case i
Case 1 To 8
.Text = i
.Font.ColorIndex = 1
Case 9
.Text = "次へ"
.Font.ColorIndex = 1
Case 10
.Text = "終了"
.Font.ColorIndex = 1
Case 11 To 12
.Text = ""
.Font.ColorIndex = 1
End Select
End With
End With
Next
Set shp = Nothing
End Sub
Sub Test_02()
Dim i As Long
Dim myText As String
For i = 1 To ActiveSheet.DrawingObjects.Count
With ActiveSheet.DrawingObjects(i)
On Error Resume Next
myText = .Text
On Error GoTo 0
If myText <> "" Then
Select Case myText
Case 1, 2, 3
.Font.ColorIndex = 3
.Font.Size = 12
.Font.Bold = True
Case 4, 5, 6
.Font.ColorIndex = 5
.Font.Size = 10
.Font.Bold = False
End Select
End If
End With
Next
End Sub
（あすなろ）
参考に２００７での動作検証です。
ichinoseさん 準備１（初回）：正常動作 準備２ ：正常動作 準備１（２回）：正常動作
あすなろさん TextBoxies ：Collectionに該当しない Test01、02 ：正常動作
以上です。 （ｍｏｍｏ）
ｍｏｍｏさん、検証報告有難うございます。
> 実行しても変化は見えないのですが > 図をクリックすると図が変化しました
これは、何らかの理由で描画更新がされていなかったと 言う事でしょうか？スレ主さんの環境または当該ブック のみの現象かどうか気になるところです。
（あすなろ）
昨夜ichinoseさんの準備１（初回）、準備２を試した時（Vista,2007) kokoさんと同じ結果（と思われる）に成りました。
ちなみに、「DoEvents」を入れてみましたがやはり変わらず 図形を選択して移動した時（或いはテキストを選ぼうとした時）に 変化が有りました。 （選択しただけだとどうだったかな？この部分の記憶は定かでは有りませんが。 変わったら、移動させようと思わないだろうから、タブン変わっていなかったのかと。）
ｍｏｍｏさんの2007では正常動作なんですね。。。 「正常動作」って、マクロの実行で書式が変わる って事ですよね？
ご参考まで。
(HANA)
>ｍｏｍｏさんの2007では正常動作なんですね。。。 > 「正常動作」って、マクロの実行で書式が変わる って事ですよね？
ですねぇ あれから３００回くらい試行しましたが全て実行のみで書式が変わっています。 OSとかビデオアクセラレータとかの問題ですかね？ 本当は変わっているのに絵画が追いついてないだけとか
ちなみに CPU:Intel i5 3.2GHz Mem:2GByte Win:XP SP3 GPU:onbord 256MByte くらいな環境です。 （ｍｏｍｏ）
確認していただきありがとうございます。 ビデオカード周りの原因だとすると、 VBAで処理後、表示に変化がなくても そのまま保存して閉じて、再度開いたときなどは、正常に表示されると思いますけどねえ
ichinose
何でしょうねぇ。。。
kokoさんは、、、XP,2007 って書いてある時と VISTA,2007 の時が有りますね。 両方の環境があるなら、XPでもやってみてもらうとはっきりするかもですね。
挙動がかなり不審なのでいまいちすっきりしませんが 『テキストに関してのみ変更が有った場合でも再描画が必要』 と言う事を意識してくれていない様です。 実際はそんなにすっきりした感じではないですが。 それが余計に「挙動不審」に感じる。 背景色等と一緒に変更した場合は、再描画される。
エクセル君が「ハッ！！」としてくれるなら何でも良い様ですが
ActiveSheet.DrawingObjects.Visible = False
ActiveSheet.DrawingObjects.Visible = True
とかどうでしょうねぇ。
今回の案件。 「変更後は上書き保存すれば良い」 って事なら、上書き保存だけでも再描画される様です。 （一旦閉じなくても大丈夫な様でした。）
(HANA)
皆様 有難うございます。 職場のパソコンでテストしましたが やはり図形を選択してから書式が変化しました。 Sub Test_01() とSub Test_02()も同様でした
自宅のパソコンのシステムのプロパティには Intel(R) core(TM)2 Dou cpu E8500 @3.16GHZ 3.17 GHZ 2.00GB RAN とあります
自宅のパソコンはXP SP3 ｴｸｾﾙ2007 職場はvista SP2 ｴｸｾﾙ2007です。
＞ビデオカード周りの原因だとすると、 ＞VBAで処理後、表示に変化がなくても ＞そのまま保存して閉じて、再度開いたときなどは、正常に表示されると思いますけどねえ はい 正常に表示されました。 閉じずに上書き保存だけでは再描画されませんでした。 （自宅のXPでの結果です）
＞ActiveSheet.DrawingObjects.Visible = False ＞ActiveSheet.DrawingObjects.Visible = True を付け加えましたら、図を選択しなくても描画されるようになりました。 皆様有難うございます。 理解不完全ながらも、大変勉強になりました。 （koko)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.