[[20100930194658]] 『テキストボックスでショートカットメニューを表示』(キョロ) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『テキストボックスでショートカットメニューを表示させたい』(キョロ)
いつもお世話になっています。
エクセルsheetにActiveXコントロールのTextBoxを貼り付けています。このTextBoxに右クリックでショートカットメニューを表示させたいのですが、何かいい方法はないでしょうか?
以前、こちらでユーザーフォームにあるTextBoxにオリジナルのショートカットメニューを表示させる方法がのっており、これなら!と試していますがうまくいきません…。
よろしくお願いします。
Excel2003 WindowsXP


 こちらでってどこですか?
 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のコンパイルを実行し、エラーが出ないことを
 確認してください。

 VBEからExcelに戻ってください。

 「ファイル」-----「名前を付けて保存」とクリックして、名前を付けて保存するダイアログを表示させてください。

 「ファイルの種類」として、「Microsoft Excel アドイン (*.xla)」を選択してください。
 保存フォルダが変わりますが、そのまま表示フォルダに保存します。

 ファイル名は、cpypst.xla と命名してください。

 一度、Excel本体を閉じてから、再度Excelを立ち上げてください。

 再び、新規ブックとして、Book1が既定ブックとして作成されていることを
 確認してください。

 「ツール」----「アドイン」と起動して、アドインダイアログを表示させてください。
 アドイン一覧に先に作成した「cpypst」があるはずです。
 チェックを入れてOKをクリックしてください。

 これで準備はOKです。アドイン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


 例1

 新規ブックにて(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のモジュールに不具合がありましたので、
          修正しました。

[[20140926184519]]

 このスレッドに参加している過程で発見しましたので、修正しました。

 ichinose


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.