Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


27372 / 76732 ←次へ | 前へ→

【54682】Re:オブジェクトを選択状態でmsgbox表示 再送
発言  ichinose  - 08/3/26(水) 7:07 -

引用なし
パスワード
   おはようございます。
ちょっと、投稿したものを検証していたらいくつか問題があったので再送です。

▼ひげくま さん:
こんばんは。
私も考えてみました。

ユーザーフォームで独自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時のエラーで、入力規則のリストやオートフィルタの↓図形は、ここでカットされるので、問題なしと判断しました。

尚、コード等で非表示にしてある図形も表示して選択する仕様にしました。

試してみてください
0 hits

【54635】オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 10:31 質問
【54638】Re:オブジェクトを選択状態でmsgbox表示 Jaka 08/3/25(火) 11:00 発言
【54639】Re:オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 11:04 発言
【54643】Re:オブジェクトを選択状態でmsgbox表示 Jaka 08/3/25(火) 11:33 発言
【54646】Re:オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 11:51 発言
【54655】Re:オブジェクトを選択状態でmsgbox表示 Jaka 08/3/25(火) 14:51 発言
【54657】Re:オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 14:57 お礼
【54660】Re:オブジェクトを選択状態でmsgbox表示 Jaka 08/3/25(火) 15:47 発言
【54683】Re:オブジェクトを選択状態でmsgbox表示 VBWASURETA 08/3/26(水) 9:14 発言
【54686】Re:オブジェクトを選択状態でmsgbox表示 ichinose 08/3/26(水) 10:30 発言
【54688】Re:オブジェクトを選択状態でmsgbox表示 VBWASURETA 08/3/26(水) 12:02 発言
【54689】Re:オブジェクトを選択状態でmsgbox表示 ichinose 08/3/26(水) 12:38 発言
【54690】Re:オブジェクトを選択状態でmsgbox表示 VBWASURETA 08/3/26(水) 12:56 発言
【54701】Re:オブジェクトを選択状態でmsgbox表示 ichinose 08/3/26(水) 17:32 発言
【54640】Re:オブジェクトを選択状態でmsgbox表示 VBWASURETA 08/3/25(火) 11:06 発言
【54644】Re:オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 11:34 発言
【54645】Re:オブジェクトを選択状態でmsgbox表示 VBWASURETA 08/3/25(火) 11:47 発言
【54647】Re:オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 11:53 発言
【54648】Re:オブジェクトを選択状態でmsgbox表示 VBWASURETA 08/3/25(火) 11:57 発言
【54649】Re:オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 12:01 発言
【54650】Re:オブジェクトを選択状態でmsgbox表示 ひげくま 08/3/25(火) 12:01 お礼
【54651】Re:オブジェクトを選択状態でmsgbox表示 VBWASURETA 08/3/25(火) 12:42 発言
【54682】Re:オブジェクトを選択状態でmsgbox表示 再... ichinose 08/3/26(水) 7:07 発言

27372 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free