Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

70102 / 76738

←次へ　｜　前へ→


	【11147】Re:text boxについて

Ｊカーター - 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について ＮＨ 04/2/28(土) 10:03