Excel VBA質問箱 IV

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

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


70098 / 76734 ←次へ | 前へ→

【11147】Re:text boxについて
回答  Jカーター  - 04/3/1(月) 13:10 -

引用なし
パスワード
   こんにちは。
全てのTextBoxに対応すべくクラスモジュールを使ってみました。
なお、メニューのボタンはイベントを使ってます。(2000以降限定かも?)

ユーザーフォームモジュール
--------------------------------------------------------------------------
Option Explicit
Private WithEvents CopyBtn As Office.CommandBarButton
Private WithEvents CutBtn As Office.CommandBarButton
Public WithEvents PasteBtn As Office.CommandBarButton
Public BarTmp       As Office.CommandBar
Public TxtTmp       As MSForms.TextBox
Private TxtBoxes()     As TxtBoxCLs
Const BARNAME       As String = "TXTMENU"

'コピーボタン
Private Sub CopyBtn_Click( _
  ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  TxtTmp.Copy
  PasteBtn.Enabled = TxtTmp.CanPaste
End Sub

'カットボタン
Private Sub CutBtn_Click( _
  ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  TxtTmp.Cut
End Sub

'貼り付けボタン
Private Sub PasteBtn_Click( _
  ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  TxtTmp.Paste
End Sub

Private Sub UserForm_Initialize()
  Dim ContItem As MSForms.Control
  Dim LngX   As Long
  
  For Each ContItem In Me.Controls
    If TypeOf ContItem Is MSForms.TextBox Then
      ReDim Preserve TxtBoxes(LngX)
      Set TxtBoxes(LngX) = New TxtBoxCLs
      Set TxtBoxes(LngX).Txt = ContItem
      LngX = LngX + 1
    End If
  Next ContItem
  
  Call BarDLt
  Call BarAdd
End Sub

Private Sub UserForm_Terminate()
  Erase TxtBoxes
  Call BarDLt
  Set TxtTmp = Nothing
  Set BarTmp = Nothing
  Set CutBtn = Nothing
  Set CopyBtn = Nothing
  Set PasteBtn = Nothing
End Sub

'メニュー削除
Private Sub BarDLt()
  On Error Resume Next
  Application.CommandBars(BARNAME).Delete
End Sub

'メニュー作成
Private Sub BarAdd()
  Set BarTmp = Application.CommandBars.Add(BARNAME, msoBarPopup, , True)
  With BarTmp
    Set CutBtn = .Controls.Add(msoControlButton)
    Set CopyBtn = .Controls.Add(msoControlButton)
    Set PasteBtn = .Controls.Add(msoControlButton)
  End With
  CutBtn.Caption = "Cut(&T)"
  CutBtn.FaceId = 21
  CopyBtn.Caption = "Copy(&C)"
  CopyBtn.FaceId = 19
  PasteBtn.Caption = "Paste(&P)"
  PasteBtn.FaceId = 22
End Sub

クラスモジュール(オブジェクト名TxtBoxCLs)
--------------------------------------------------------------------------
Option Explicit
Private WithEvents xTxt As MSForms.TextBox

Property Set Txt(ByVal TTmp As MSForms.TextBox)
  Set xTxt = TTmp
End Property

'マウスアップイベント
Private Sub xTxt_MouseUp(ByVal Button As Integer, _
  ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then
    With UserForms(0)
      Set .TxtTmp = xTxt
      .PasteBtn.Enabled = xTxt.CanPaste
      .BarTmp.ShowPopup
    End With
  End If
End Sub

的はずれでしたらすいません。

0 hits

【11101】text boxについて NH 04/2/28(土) 10:03 質問
【11102】Re:text boxについて ichinose 04/2/28(土) 10:10 回答
【11126】Re:text boxについて NH 04/2/28(土) 21:10 質問
【11132】Re:text boxについて IROC 04/2/29(日) 1:11 回答
【11138】Re:text boxについて クウガ 04/2/29(日) 11:55 発言
【11140】Re:text boxについて ichinose 04/2/29(日) 12:07 発言
【11147】Re:text boxについて Jカーター 04/3/1(月) 13:10 回答
【11149】Re:text boxについて Jカーター 04/3/1(月) 13:15 回答
【11165】Re:text boxについて NH 04/3/1(月) 20:32 質問
【11169】Re:text boxについて Jカーター 04/3/2(火) 9:29 回答
【11178】Re:text boxについて IROC 04/3/2(火) 11:43 回答
【11214】Re:text boxについて NH 04/3/2(火) 18:23 お礼

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