| |
おはようございます。
ちょっと、投稿したものを検証していたらいくつか問題があったので再送です。
▼ひげくま さん：
こんばんは。
私も考えてみました。
ユーザーフォームで独自Msgboxをモーダレスで作成する方法です。
新規ブックにユーザーフォーム（UserForm1）のみを作成してください。
コントロールはコードで作成しますから、配置しないで下さい。
上記の何もコントロールが配置されていないUserForm1のモジュールに
'==================================================================
Option Explicit
Private sidx As Long
Private sobj() As Object
Private t_obj As Object
Private WithEvents 削除 As MSForms.CommandButton
Private WithEvents 次の図形 As MSForms.CommandButton
'==================================================================
Private Sub UserForm_Initialize()
With Me
.Width = 189
.Height = 75
Set 削除 = .Controls.Add("Forms.CommandButton.1", , True)
With 削除
.Caption = "削除"
.Left = 24
.Top = 18
.Width = 60
.Height = 18
End With
Set 次の図形 = .Controls.Add("Forms.CommandButton.1", , True)
With 次の図形
.Caption = "次の図形"
.Left = 96
.Top = 18
.Width = 60
.Height = 18
End With
End With
Call open_sobj(ActiveSheet)
Call set_obj
End Sub
'==================================================================
Sub open_sobj(ByVal sht As Worksheet)
Dim obj As Object
If sht.Shapes.Count > 0 Then
ReDim sobj(1 To sht.Shapes.Count)
sidx = 1
For Each obj In sht.Shapes
Set sobj(sidx) = obj
sidx = sidx + 1
Next
sidx = 1
End If
End Sub
'==================================================================
Function get_sobj() As Object
Set get_sobj = Nothing
If sidx <= UBound(sobj()) Then
Set get_sobj = sobj(sidx)
sidx = sidx + 1
End If
End Function
'==================================================================
Sub close_sobj()
Erase sobj()
sidx = 0
End Sub
'==================================================================
Function set_obj() As Long
On Error Resume Next
set_obj = 0
Do
Set t_obj = get_sobj()
If Not t_obj Is Nothing Then
Err.Clear
t_obj.Select
If Err.Number = 0 Then Exit Do
Err.Clear
t_obj.Visible = True '非表示図形を表示
t_obj.Select
If Err.Number = 0 Then Exit Do
Else
MsgBox "end"
set_obj = 1
Exit Do
End If
Loop
End Function
'==================================================================
Private Sub UserForm_Terminate()
Call close_sobj
Set t_obj = Nothing
End Sub
'==================================================================
Private Sub 削除_Click()
On Error Resume Next
t_obj.Delete
Call set_obj
End Sub
'==================================================================
Private Sub 次の図形_Click()
set_obj
End Sub
標準モジュールに
'====================================================================
Sub main()
UserForm1.Show vbModeless
End Sub
アクティブシートに適当に図形を配置した後、mainを実行して試してみてください。
excel2002では、それらしく作動しています。
前回投稿との変更点
当初、Drawingobjectsコレクションで処理することしか頭にはありませんでした。
（入力規則のリストやオートフィルタの↓図形まで削除対象になることを考慮した
つもりだったのですが・・・）
Drawingobjectだとコネクタが選択できない
グループ化された図形の扱いが面倒 の問題が発生し、再考。
結局 Shapesコレクションで処理することで再送しました。
Select時のエラーで、入力規則のリストやオートフィルタの↓図形は、ここでカットされるので、問題なしと判断しました。
尚、コード等で非表示にしてある図形も表示して選択する仕様にしました。
試してみてください
|
|
ichinose
- 08/3/26(水) 7:07 -
