| |
▼つん さん：
>注目したいところは私が一番理解できてなかった所でしたorz
>
>SendKeys "{DOWN 6}{ENTER}"
>
>で、正しい動作をしてくれるようになりました＼(^o^)／
いまこちらで検証してみましたが、
不具合は起こらず、どういう連鎖反応が起きているのか調べきれませんでした。
スミマセン。
（SendKeys というのは ステップ実行して確かめれないからやっかいですね）
ところで
話は代わりますが、
OnActionの実行先プロシージャでちがうところはフォントが「明朝」か
「ゴチック」かのちがいだけですか？
そうであれば、1つのプロシージャをパラメータを変えて呼び出すことで
コードがもっと簡単になりメンテナンスしやすくなると思います。
Sub Auto_Open()
Dim cBar As Office.CommandBar
Call Reset_ShapesMenu
Set cBar = Application.CommandBars("Shapes")
'テキスト追加オリジナル（明朝）
With cBar.Controls.Add(Type:=msoControlButton _
, Before:=6)
.Caption = "テキストの追加 (明朝）"
.OnAction = "AddTextToShape"
.Parameter = 1 '◆追加
.Visible = True
End With
'テキスト追加オリジナル（ゴシック）
With cBar.Controls.Add(Type:=msoControlButton _
, Before:=7)
.Caption = "テキストの追加 (ゴシック)"
.OnAction = "AddTextToShape" '◆上と同じプロシージャ名
.Parameter = 2 '◆追加
.Visible = True
End With
End Sub
'Sub Auto_Close() 省略
Private Sub AddTextToShape() '----（１）
Dim FontName As String '-------- ◆ここから
Dim i As Long
i = CommandBars.ActionControl.Parameter
Select Case i
Case 1: FontName = "ＭＳ 明朝"
Case 2: FontName = "ＭＳ ゴシック"
Case Else
Exit Sub
End Select '-------------------------------- ◆ここまで挿入
Dim shpA As Shape
Dim charsA As Characters
On Error Resume Next
Set shpA = ActiveSheet.Shapes(Selection.Name)
Set charsA = shpA.TextFrame.Characters
On Error GoTo 0
If charsA Is Nothing Then
MsgBox "この操作は行えません。", vbInformation
Exit Sub
End If
' シェイプのフォント・書式を設定できるように空文字を入れる
charsA.Text = ""
' シェイプのフォントを設定する
charsA.Font.Name = FontName '◆ 変更
charsA.Font.Size = 11
' シェイプの書式を設定する
shpA.TextFrame.HorizontalAlignment = xlHAlignCenter
shpA.TextFrame.VerticalAlignment = xlVAlignCenter
Application.ScreenUpdating = False
' シェイプ内で文字が打てる状態にする
SendKeys "{DOWN 5}{ENTER}" '◆要 変更？ （分かりません）
'Application.CommandBars("Shapes").ShowPopup
Application.ScreenUpdating = True
End Sub
|
|
kanabun
- 09/6/9(火) 13:57 -
