[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『テキストボックスでショートカットメニューを表示させたい』（キョロ）
こちらでってどこですか？ sendkeyをつかっちゃたけど、その辺は適当に変えてください。 http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=52;id=FAQ (Jaka)
>オリジナルのショートカットメニューを表示させる方法 [[20100921183617]] ↑これですか？ だとしたら・・・、 シートに貼り付けたActiveXControlには、適用できていませんね！！ というか、私は、殆どシートをユーザーに触らせるようなコードは書かないので ↑これまで考慮してませんでした。
で、ご質問の件は、変数の型の違いやら、同じメソッドがユーザーフォームと シートに貼り付けたのとは、動作が違ったりで作動しません。
で、両方で使えるように考えてみました。
この場合、リンク先でも触れましたが、 メニュー表示やコピー&切取り＆貼付動作を別のブックにてアドイン化してしまう方法を選択しました。
まず、新規ブックにて
＊VBEにて、「Microsoft Forms2.0 Object Library」を参照設定してください。
クラスモジュールを二つ作成してください。 クラス名は、Class1、Class2という既定名です。
Class1のモジュールに
'=============================================================
Option Explicit
Private WithEvents btnCopy As Office.CommandBarButton
Private WithEvents btnCut As Office.CommandBarButton
Private WithEvents btnPaste As Office.CommandBarButton
Private barM As Office.CommandBar
Private conttmp As Object
Const Ctxt As String = "TextBox"
Const Clbl As String = "Label"
Private cpt() As class2
'==============================================================
Sub init(cmdb As Office.CommandBar, ct As Office.CommandBarButton, cpy As Office.CommandBarButton, pst As Office.CommandBarButton)
'コピーペーストクラスの初期化 インスタンス作成後、
'必ず最初に実行する メニューを登録する
On Error Resume Next
Set barM = cmdb
Set btnCopy = cpy
Set btnCut = ct
Set btnPaste = pst
On Error GoTo 0
End Sub
'==========================================================
Sub term()
'コピーペーストクラスの終了処理 ファイルのCloseみたいなもの
On Error Resume Next
Dim g0 As Long
For g0 = LBound(cpt()) To UBound(cpt())
Set cpt(g0) = Nothing
Next
On Error GoTo 0
End Sub
'====================================================
Sub add(ByVal Cobj As Object)
'コピーペーストメニューを表示するコントロールを登録する
'いまところ、TextboxとLabelだけ
Dim g0 As Long
On Error Resume Next
g0 = UBound(cpt()) + 1
If Err.Number <> 0 Then g0 = 1
ReDim Preserve cpt(1 To g0)
Set cpt(g0) = New class2
If TypeName(Cobj) = Ctxt Then
Set cpt(g0).Txtev = Cobj
ElseIf TypeName(Cobj) = Clbl Then
Set cpt(g0).Lblev = Cobj
End If
Set cpt(g0).parent = Me
cpt(g0).id = g0
On Error GoTo 0
End Sub
'===========================================================
Sub callback(ByVal contP As Variant)
'右クリックでのメニュー表示
Set conttmp = contP
If TypeName(conttmp) = Ctxt Then
btnCut.Enabled = True
btnPaste.Enabled = conttmp.CanPaste
ElseIf TypeName(conttmp) = Clbl Then
btnCut.Enabled = False
btnPaste.Enabled = False
End If
barM.ShowPopup
End Sub
'====================================================================
Private Sub btnCopy_Click( _
ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
'コピーが選択されたときの処理
Dim dobj As DataObject
If TypeName(conttmp) = Ctxt Then
Set dobj = New DataObject
If conttmp.Value <> "" Then
Set dobj = New DataObject
dobj.SetText conttmp.SelText
dobj.PutInClipboard
Set dobj = Nothing
End If
ElseIf TypeName(conttmp) = Clbl Then
Set dobj = New DataObject
If conttmp.Caption <> "" Then
Set dobj = New DataObject
dobj.SetText conttmp.Caption
dobj.PutInClipboard
Set dobj = Nothing
End If
End If
End Sub
'==============================================================
Private Sub btnCut_Click( _
ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
'切り取りが選択されたときの処理
Dim dobj As DataObject
If TypeName(conttmp) = Ctxt Then
Set dobj = New DataObject
If conttmp.Value <> "" Then
Set dobj = New DataObject
dobj.SetText conttmp.SelText
dobj.PutInClipboard
Set dobj = Nothing
With conttmp
.Text = WorksheetFunction.Replace(.Text, .SelStart + 1, .SelLength, "")
End With
End If
End If
End Sub
'===============================================================
Private Sub btnPaste_Click( _
ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
'貼付が選択されたときの処理
Dim dobj As DataObject
If TypeName(conttmp) = Ctxt Then
conttmp.Paste
End If
End Sub
Class2のモジュールに
'===============================================================
Option Explicit
Public WithEvents Txtev As MSForms.TextBox
Public WithEvents Lblev As MSForms.Label
Public id As Long
Private cpo As Object
'===============================================================
Property Set parent(pcpo As Object)
Set cpo = pcpo
End Property
'===============================================================
Private Sub Lblev_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
cpo.callback Lblev
End If
End Sub
'===============================================================
Private Sub Txtev_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
cpo.callback Txtev
End If
End Sub
次にThisworkbookのモジュールに
'===============================================================
Option Explicit
Private col As Collection
'===============================================================
Function ccp_open(nm As Variant) As Long
On Error Resume Next
Dim btnCopy As Office.CommandBarButton
Dim btnCut As Office.CommandBarButton
Dim btnPaste As Office.CommandBarButton
Dim barM As Office.CommandBar
ccp_open = 0
Call mk_menu(nm, barM, btnCut, btnCopy, btnPaste)
With col
.add New Class1, nm
ccp_open = Err.Number
If Err.Number = 0 Then
.Item(nm).init barM, btnCut, btnCopy, btnPaste
Else
On Error Resume Next
barM.Delete
On Error GoTo 0
End If
End With
On Error GoTo 0
End Function
'===============================================================
Sub ccp_add(nm As Variant, obj As Object)
col(nm).add obj
End Sub
'===============================================================
Sub ccp_close(nm As Variant)
On Error Resume Next
col(nm).term
Set col(nm) = Nothing
col.Remove nm
CommandBars(nm).Delete
On Error GoTo 0
End Sub
'===============================================================
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Set col = Nothing
On Error GoTo 0
End Sub
'===============================================================
Private Sub Workbook_Open()
Set col = New Collection
End Sub
'===============================================================
Sub mk_menu(ByVal nm As Variant, barM As Office.CommandBar, btnCut As Office.CommandBarButton, btnCopy As Office.CommandBarButton, btnPaste As Office.CommandBarButton)
'メニュー作成
On Error Resume Next
Application.CommandBars(nm).Delete
Set barM = Application.CommandBars.add(nm, msoBarPopup, , True)
With barM
Set btnCut = .Controls.add(msoControlButton)
btnCut.Style = msoButtonCaption
btnCut.Caption = "切り取り"
Set btnCopy = .Controls.add(msoControlButton)
btnCopy.Caption = "コピー"
btnCopy.Style = msoButtonCaption
Set btnPaste = .Controls.add(msoControlButton)
btnPaste.Caption = "貼り付け"
btnPaste.Style = msoButtonCaption
End With
On Error GoTo 0
End Sub
アドイン側のコードは以上です。
VBEにて、デバッグ------Vbprojectのコンパイルを実行し、エラーが出ないことを 確認してください。
ＶＢＥからExcelに戻ってください。
「ファイル」-----「名前を付けて保存」とクリックして、名前を付けて保存するダイアログを表示させてください。
「ファイルの種類」として、「Microsoft Excel アドイン (*.xla)」を選択してください。 保存フォルダが変わりますが、そのまま表示フォルダに保存します。
ファイル名は、cpypst.xla と命名してください。
一度、Excel本体を閉じてから、再度Excelを立ち上げてください。
再び、新規ブックとして、Book1が既定ブックとして作成されていることを 確認してください。
「ツール」----「アドイン」と起動して、アドインダイアログを表示させてください。 アドイン一覧に先に作成した「cpypst」があるはずです。 チェックを入れてＯＫをクリックしてください。
これで準備はＯＫです。アドインcpypst.xlaがインストールされました。
次投稿で使用方法を説明します。
アドインcpypst.xlaのインターフェース
プロシジャー名 ccp_open
機能 コピー＆ペースト機能プロジェクトをオープンする
呼び出し形式 call Workbooks("cpypst.xla").ccp_open(nm)
in nm プロジェクトハンドル名を指定する
他のプロジェクトと重複しない名前を指定します。
out ccp_open 0 正常にオープンされた
1 プロジェクトハンドル名が重複しています
備考 最初に必ず実行するプロシジャーです。
'======================================================================
プロシジャー名 ccp_Add
機能 コピー＆ペーストメニューを表示するオブジェクトを登録する
呼び出し形式 call Workbooks("cpypst.xla").ccp_add(nm,obj)
in nm プロジェクトハンドル名を指定する
obj コピー＆ペーストメニューを表示するオブジェクト
いまところ、TextboxとLabelだけ
備考 ccp_Addで登録後、当該コントロールでは、コピ&ペースト
のメニューが表示されます
'====================================================================
プロシジャー名 ccp_close
機能 コピー＆ペースト機能プロジェクトをクローズする
呼び出し形式 call Workbooks("cpypst.xla").ccp_close(nm)
in nm プロジェクトハンドル名を指定する
備考 ファイルのクローズのように最後に実行するプロシジャーです。
以上です。
次投稿で実例で検証します。
ichinose
例１
新規ブックにて（Sheet1 というシート名が存在する)、 Sheet1にコントロールツールボックスのテキストボックスを 二つ作成してください（TextBox1、TextBox2）。
Thisworkbookのモジュールに
'===========================================================
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
With Workbooks("cpypst.xla")
.ccp_close ThisWorkbook.Name
End With
On Error GoTo 0
End Sub
'=============================================================
Private Sub Workbook_Open()
With Workbooks("cpypst.xla")
If .ccp_open(ThisWorkbook.Name) = 0 Then
.ccp_Add ThisWorkbook.Name, Me.Worksheets("sheet1").OLEObjects("textbox1").Object
.ccp_Add ThisWorkbook.Name, Me.Worksheets("sheet1").OLEObjects("textbox2").Object
Else
MsgBox "Set Can Not"
End If
End With
End Sub
適当な名前で保存してください（例 BOOK1.XLS など)。 一度閉じた後、再度上記のBOOK1.XLSを開いてください。
二つのテキストボックスにて、コピー&ペーストメニューが右クリックで 表示されることを確認してください。
14/9/28 アドインcpypst.xla側のThisworkbookのモジュールに不具合がありましたので、
修正しました。
このスレッドに参加している過程で発見しましたので、修正しました。
ichinose
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.