HOME > エクセルVBA > サンプル > CodeMenu

CodeMenu


【ファイル名】CodeMenu.xlam
【バージョン】Ver 1.0.0
【作成日】2015年02月28日
【動作確認】Windows 7
【必要なソフト】Microsoft Excel 2010
【ダウンロード】CodeMenu.zip
【説明】Visual Basic EditorのCode Windowの右クリックメニューに追加するサンプルです。
【注意】実行するにはオプションの「VBA プロジェクト オブジェクト モデルへのアクセルを信頼する」にチェックを入れます。詳細はVBProjectを参照してください。

これはサンプルです。あなたが使いやすいようにヘッダーや定型文の挿入、検索などカスタマイズしてください。
行頭が2個の一重引用符「''」で始まる行はドキュメント用のコメントにする仕様です。抽出してクリップボードにコピーします。
クリップボードにコピーするテキストはUnicodeです。VBEでは使用できません。
CodeMenu.xlamはプロジェクトのロックをしてません。実際に使用する場合は誤って書き換えるかもしれないのでロックした方が良いでしょう。
CodeMenu.xlamを編集すると追加したメニューのコマンドが実行できなくなります。実行するには一度閉じてから再度開いてください。

Code Windowの右クリック メニュー
Code Windowの右クリック メニュー

CodeModule
'' CodeModule
Option Explicit
' 共通処理
'' 選択範囲の文字列を取得します。
'' GetSelectedText() As String
Function GetSelectedText() As String
  Dim i As Long
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
  Dim Text As String

  GetSelectedText = vbNullString
  If Application.VBE.ActiveCodePane Is Nothing Then Exit Function

  With Application.VBE.ActiveCodePane
    .GetSelection StartLine, StartColumn, EndLine, EndColumn ' GetSelectionはShift JIS
    For i = StartLine To EndLine
      Text = StrConv(.CodeModule.Lines(i, 1), vbFromUnicode) ' CodeModule.LinesはUnicode
      Select Case i
        Case StartLine
          If StartLine = EndLine Then
            GetSelectedText = MidB$(Text, StartColumn, EndColumn - StartColumn)
          Else
            GetSelectedText = MidB$(Text, StartColumn) & vbCrLf
          End If
        Case EndLine
          GetSelectedText = GetSelectedText & LeftB$(Text, EndColumn - 1)
        Case Else
          GetSelectedText = GetSelectedText & Text & vbCrLf
      End Select
    Next i
  End With
  GetSelectedText = StrConv(GetSelectedText, vbUnicode) ' Unicodeに戻す
End Function
'' 選択範囲を指定した文字列に設定します。
'' SetSelectedText(Text As String)
Sub SetSelectedText(Text As String)
  Dim i As Long
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
  Dim Head As String
  Dim Tail As String
  Dim LineText As String

  If Application.VBE.ActiveCodePane Is Nothing Then Exit Sub

  With Application.VBE.ActiveCodePane
    .GetSelection StartLine, StartColumn, EndLine, EndColumn ' GetSelectionはShift JIS
    LineText = StrConv(.CodeModule.Lines(StartLine, 1), vbFromUnicode) ' 選択の開始行の文字列 CodeModule.LinesはUnicode
    Head = StrConv(LeftB$(LineText, StartColumn - 1), vbUnicode)  ' 選択範囲よりも前の文字列

    LineText = StrConv(.CodeModule.Lines(EndLine, 1), vbFromUnicode) ' 選択の終了行の文字列 CodeModule.LinesはUnicode
    Tail = StrConv(MidB$(LineText, EndColumn), vbUnicode)  ' 選択範囲よりも後ろの文字列
    .CodeModule.DeleteLines StartLine, EndLine - StartLine + 1 ' 選択行の削除
    .CodeModule.InsertLines StartLine, Head & Text & Tail ' 行の挿入
    .SetSelection StartLine, StartColumn, StartLine, StartColumn ' カーソル位置を最初の行の桁に設定(選択なし)
  End With
End Sub
'' テキストファイルをすべて読み込み、文字列を返します。
'' Function TextFileReadAll(FileName As String) As String
Function TextFileReadAll(FileName As String) As String
  Dim FSO, file

  TextFileReadAll = vbNullString
  Err.Clear
  On Error GoTo Error_ReadAll
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set file = FSO.OpenTextFile(FileName)
  TextFileReadAll = file.ReadAll()
  file.Close
  Set FSO = Nothing
  Exit Function
Error_ReadAll:
  If Err.Number > 0 Then
    MsgBox Prompt:=Err.Number & ":" & Err.Description, Buttons:=vbCritical, Title:="エラー"
  End If
  file.Close
  Set FSO = Nothing
  On Error GoTo 0
End Function
' < メニューの処理 >------------------------------------------------------------------------------------------------------
'' 現在の行を選択します。(開始行は1桁目、終了行は最後の桁まで選択)
'' SelectLine
Sub SelectLine()
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long

  With Application.VBE.ActiveCodePane
    .GetSelection StartLine, StartColumn, EndLine, EndColumn
    EndColumn = 1 + LenB(.CodeModule.Lines(EndLine, 1)) ' 【注意】 LenでなくLenBを使います。
    .SetSelection StartLine, 1, EndLine, EndColumn
  End With
End Sub
'' 現在のカーソルの開始行に日付と時間を挿入します。
'' Insert_DateTime()
Sub Insert_DateTime()
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
  Dim Text As String

  Text = Format(Now, "' ggge年mm月dd日 hh時mm分ss秒")
  Application.VBE.ActiveCodePane.GetSelection StartLine, StartColumn, EndLine, EndColumn
  Application.VBE.ActiveCodePane.CodeModule.InsertLines StartLine, Text
End Sub
'' 現在の行に定型文「GetOpenFilename」の挿入します。
'' Insert_GetOpenFilename_Text()
Sub Insert_GetOpenFilename_Text()
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
  Dim Text As String

  Text = "  Dim FileName As Variant" & vbCrLf & vbCrLf
  Text = Text & "  FileName = Application.GetOpenFilename(FileFilter:=""エクセルファイル(*.xl*),*.xl*,テキストファイル(*.prn;*.txt;*.csv),*.prn;*.txt;*.csv,すべてのファイル(*.*),*.*"", FilterIndex:=1, Title:=""ファイルを開く"", ButtonText:=""開く"", MultiSelect:=False)" & vbCrLf
  Text = Text & "  If TypeName(FileName) = ""Boolean"" Then Exit Sub" & vbCrLf

  With Application.VBE.ActiveCodePane
    .GetSelection StartLine, StartColumn, EndLine, EndColumn
    .CodeModule.InsertLines StartLine, Text
  End With
End Sub
'' 選択したファイルを最初のプロシージャーの前に挿入します。
'' Insert_File()
Sub Insert_File()
  Dim FileName As Variant
'  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long

  FileName = Application.GetOpenFilename(FileFilter:="テキストファイル(*.txt),*.txt,すべてのファイル(*.*),*.*", FilterIndex:=1, Title:="ファイルの挿入", ButtonText:="挿入", MultiSelect:=False)
  If TypeName(FileName) = "Boolean" Then Exit Sub
  With Application.VBE.ActiveCodePane
'    .GetSelection StartLine, StartColumn, EndLine, EndColumn
    .CodeModule.AddFromFile FileName
    .SetSelection 1, 1, 1, 1
  End With
End Sub
'' ダイアログで選択したテキストファイルを、指定した行に挿入します。
'' InsertLinesFile(Optional Line As Long = 0) ' Lineを省略した場合はカレント行
Sub InsertLinesFile(Optional Line As Long = 0)
  Dim Text As String
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
  Dim FileName As Variant

  FileName = Application.GetOpenFilename(FileFilter:="テキストファイル(*.prn;*.txt;*.csv),*.prn;*.txt;*.csv,すべてのファイル(*.*),*.*", FilterIndex:=1, Title:="ファイルを開く", ButtonText:="開く", MultiSelect:=False)
  If TypeName(FileName) = "Boolean" Then Exit Sub
  Text = TextFileReadAll(CStr(FileName))

  If Line > 0 Then
    StartLine = Line
  Else
    Application.VBE.ActiveCodePane.GetSelection StartLine, StartColumn, EndLine, EndColumn
  End If
  Application.VBE.ActiveCodePane.CodeModule.InsertLines StartLine, Text
End Sub
'' 選択した行の左側に文字列を連結します。
'' CatLeft()
Sub CatLeft()
  Dim i As Long
  Dim buf As String
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
  Dim Text As Variant

  Text = Application.InputBox(Prompt:="文字列:", Title:="選択した行の左側に文字列を連結", Type:=2)
  If TypeName(Text) = "Boolean" Then Exit Sub ' [キャンセル]ボタンを押した
  Application.VBE.ActiveCodePane.GetSelection StartLine, StartColumn, EndLine, EndColumn
  buf = vbNullString
  With Application.VBE.ActiveCodePane.CodeModule
    For i = StartLine To EndLine
      If i <> StartLine Then buf = buf & vbCrLf
      buf = buf & Text & .Lines(i, 1)
    Next i
    .DeleteLines StartLine, EndLine - StartLine + 1
    .InsertLines StartLine, buf
    .CodePane.SetSelection StartLine, 1, StartLine, 1
  End With
End Sub
'' 選択した行の右側に文字列を連結します。
'' CatRight()
Sub CatRight()
Dim i As Long
  Dim buf As String
  Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
  Dim Text As Variant

  Text = Application.InputBox(Prompt:="文字列:", Title:="選択した行の左側に文字列を連結", Type:=2)
  If TypeName(Text) = "Boolean" Then Exit Sub ' [キャンセル]ボタンを押した
  Application.VBE.ActiveCodePane.GetSelection StartLine, StartColumn, EndLine, EndColumn
  buf = vbNullString
  With Application.VBE.ActiveCodePane.CodeModule
    For i = StartLine To EndLine
      If i <> StartLine Then buf = buf & vbCrLf
      buf = buf & .Lines(i, 1) & Text
    Next i
    .DeleteLines StartLine, EndLine - StartLine + 1
    .InsertLines StartLine, buf
    .CodePane.SetSelection StartLine, 1, StartLine, 1
  End With
End Sub
''テキストをクリップボードにコピーします。
'' CopyText(buf As String)
Sub CopyText(buf As String)
    Dim CB As New DataObject ' 「Microsoft Forms 2.0 Object Library」を参照してます。

    If Len(buf) < 1 Then Exit Sub
    With CB
      .SetText buf    ' 変数のデータをDataObjectに格納する
      .PutInClipboard ' DataObjectのデータをクリップボードに格納する
    End With
    Set CB = Nothing
End Sub
'' アクティブ モジュールに行番号を付けてクリップボードにコピーします。
'' AddLineToClip()
Sub AddLineToClip()
  Dim i As Long
  Dim buf As String

  buf = vbNullString
  With Application.VBE.ActiveCodePane.CodeModule
    For i = 1 To .CountOfLines
      buf = buf & Format(i, "00000: ") & .Lines(i, 1) & vbCrLf
    Next i
  End With
  CopyText buf
End Sub
'' 行頭が''の行のみクリップボードにコピーします。
'' DocToClip()
Sub DocToClip()
  Dim IsBreakLine As Boolean
  Dim i As Long
  Dim buf As String

  IsBreakLine = False
  buf = vbNullString
  With Application.VBE.ActiveCodePane.CodeModule
    For i = 1 To .CountOfLines
      If Left$(.Lines(i, 1), 2) = "''" Then
        If IsBreakLine Then
          buf = buf & vbCrLf
        End If
        buf = buf & .Lines(i, 1) & vbCrLf
        IsBreakLine = False
      Else
        IsBreakLine = True
      End If
    Next i
  End With
  CopyText buf
End Sub
'' 検索文字を含む行をクリップボードにコピーします。
'' FindLineToClip()
Sub FindLineToClip()
  Dim i As Long
  Dim buf As String
  Dim FindText As Variant

  FindText = Application.InputBox(Prompt:="検索文字列:", Title:="検索文字を含む行をクリップボードにコピー", Type:=2)
  If TypeName(FindText) = "Boolean" Then Exit Sub ' [キャンセル]ボタンを押した
  buf = vbNullString
  With Application.VBE.ActiveCodePane.CodeModule
    For i = 1 To .CountOfLines
      If InStr(1, .Lines(i, 1), FindText, vbBinaryCompare) > 0 Then
        buf = buf & Format(i, "###0行 ") & .Lines(i, 1) & vbCrLf
      End If
    Next i
  End With

  If Len(buf) > 0 Then
    CopyText buf
  Else
    MsgBox Prompt:="検索の文字列がありませんでした。", Buttons:=vbExclamation
  End If
End Sub
'' 指定した行に移動します。
'' GotoLine()
Sub GotoLine()
  Dim InputNum
  Dim Num As Long
  Dim sl As Long, sc As Long, el As Long, ec As Long

  With Application.VBE.ActiveCodePane.CodeModule
    .CodePane.GetSelection sl, sc, el, ec
    InputNum = Application.InputBox(Prompt:="行数:", Default:=sl, Title:="指定した行に移動", Type:=1)
    If TypeName(InputNum) = "Boolean" Then Exit Sub
    Num = CLng(InputNum)
    .CodePane.SetSelection Num, 1, Num, 1
  End With
End Sub
' --------------------------------------------------------------------------------------------------------------------------------------
' 下記からは使用してません。
'' コマンド バーのリセット
'' ResetCommandBars()
Private Sub ResetCommandBars()
  Dim CB As CommandBar

  If MsgBox(Prompt:="やり直しできませんが、すべてのVBEのコマンドバーをリセットしますか?", Buttons:=vbYesNo + vbQuestion, Title:="確認") <> vbYes Then Exit Sub
  On Error Resume Next
  Application.Cursor = xlWait ' 砂時計型ポインタ
  Application.StatusBar = "すべてのコマンドバーをリセットしてます。しばらくお待ちください..."
  For Each CB In Application.VBE.CommandBars
    If CB.BuiltIn Then
      Application.VBE.CommandBars(CB.Name).Reset ' 標準のコマンド バーは削除をリセット
    Else
      Application.VBE.CommandBars(CB.Name).Delete ' ユーザーのコマンド バーのみ削除
    End If
  Next
  Application.StatusBar = ""
  Application.Cursor = xlDefault ' 標準のポインタ
  On Error GoTo 0
End Sub

このページの上

MenuModule
'' MenuModule
Option Explicit

Public Const mcMainMenu As String = "VBE Code Window Menu(&V)"

Public Const mcSelectLine As String = "行を選択(&L)"

' Sub Menu
Public Const mcInsertDateTime As String = "日付と時間を挿入(&D)"

Public Const mcInsertGetOpenFilename As String = "定型文「GetOpenFilename」の挿入(&G)"

Public Const mcInsertFile As String = "最初のプロシージャーの前にファイルを挿入(&I)..."

Public Const mcInsertLinesFile As String = "現在の行にファイルを挿入(&E)..."

Public Const mcCatLeft As String = "行の左側に文字列を連結(&L)..."

Public Const mcCatRight As String = "行の右側に文字列を連結(&R)..."

Public Const mcFindLineToClip As String = "検索文字を含む行をクリップボードにコピー(&F)"

Public Const mcAddLineToClip As String = "行番号を付けてクリップボードにコピー(&N)"

Public Const mcDocToClip As String = "行頭が ''の行のみクリップボードにコピー(&C)"

Public Const mcGotoLine As String = "指定した行に移動(&L)..."

Public Const mcGotoTop As String = "先頭行に移動(&T)  Ctrl + HOME"

Public Const mcGotoBottom As String = "最終行に移動(&B)  Ctrl + END"

Public Const mcGotoPrevProc As String = "前のプロシージャーに移動(&P)  Ctrl + Up"

Public Const mcGotoNextProc As String = "次のプロシージャーに移動(&N)  Ctrl + Down"

Public Const mcDeleteCurrentLine As String = "現在の1行を削除(&Y)  Ctrl + Y"

Public Const mcImmdiateCutAll As String = "イミディエイト ウィンドウのテキストをすべて切り取り(&X)"

このページの上

ThisWorkbook
Option Explicit
' 【注意】VBEのClickイベントはOnActionではできません。クラス モジュールにWithEventsでCommandBarEventsとして宣言します。
Dim CmdCtrl As CommandBarControl
Dim CmdEvtCls As CmdEventClass
Dim CmdEvtList As New Collection ' 複数のイベントの変数を保存します。

'' メニューの削除
'' DeleteMenu()
Sub DeleteMenu()
  On Error Resume Next
  ' コード ウィンドウの右クリック メニューの削除
  Application.VBE.CommandBars("Code Window").Controls(mcMainMenu).Delete
  Application.VBE.CommandBars("Code Window").Controls(mcSelectLine).Delete
  On Error GoTo 0
End Sub
'' メニューの追加
'' AddMenu()
Sub AddMenu()
  Dim i As Long

  For i = CmdEvtList.Count To 1 Step -1
    CmdEvtList.Remove i
  Next i
  ' コード ウィンドウの右クリック メニューの追加
  ' 行を選択
  Set CmdEvtCls = New CmdEventClass
  Set CmdCtrl = Application.VBE.CommandBars("Code Window").Controls.Add(msoControlButton)
  CmdCtrl.Caption = mcSelectLine
  CmdCtrl.BeginGroup = True
    CmdCtrl.FaceId = 801
  Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
  CmdEvtList.Add CmdEvtCls
  ' VBE Code Window Menu
  With Application.VBE.CommandBars("Code Window").Controls.Add(Type:=msoControlPopup, Temporary:=True) ' Temporary:=True で終了時に削除
    .Caption = mcMainMenu
    ' 日付と時間を挿入
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcInsertDateTime
    CmdCtrl.FaceId = 33
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 定型文「GetOpenFilename」の挿入
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcInsertGetOpenFilename
    CmdCtrl.FaceId = 23
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 最初のプロシージャーの前にファイルを挿入
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcInsertFile
    CmdCtrl.FaceId = 777
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 現在の行にファイルを挿入
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcInsertLinesFile
    CmdCtrl.FaceId = 235
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 行の左側に文字列を連結
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcCatLeft
    CmdCtrl.BeginGroup = True
    CmdCtrl.FaceId = 371
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 行の右側に文字列を連結
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcCatRight
    CmdCtrl.FaceId = 868
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 検索文字を含む行をクリップボードにコピー
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcFindLineToClip
    CmdCtrl.FaceId = 46
    CmdCtrl.BeginGroup = True
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 行番号を付けてクリップボードにコピー
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcAddLineToClip
    CmdCtrl.FaceId = 462
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 行頭が ''の行のみクリップボードにコピー
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcDocToClip
    CmdCtrl.FaceId = 2007
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 指定した行に移動
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcGotoLine
    CmdCtrl.BeginGroup = True
    CmdCtrl.FaceId = 1811
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 先頭行に移動
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcGotoTop
    CmdCtrl.FaceId = 1265
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls ' イベントの変数は上書きされません。保存されます。
    ' 最終行に移動
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcGotoBottom
    CmdCtrl.FaceId = 1266
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 前のプロシージャーに移動
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcGotoPrevProc
    CmdCtrl.BeginGroup = True
    CmdCtrl.FaceId = 38
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 次のプロシージャーに移動
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcGotoNextProc
    CmdCtrl.FaceId = 40
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' 現在の1行を削除
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcDeleteCurrentLine
    CmdCtrl.BeginGroup = True
    CmdCtrl.FaceId = 293
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
    ' イミディエイト ウィンドウのテキストをすべて切り取り
    Set CmdEvtCls = New CmdEventClass
    Set CmdCtrl = .Controls.Add(msoControlButton)
    CmdCtrl.Caption = mcImmdiateCutAll
    CmdCtrl.FaceId = 21
    Set CmdEvtCls.CmdEvent = Application.VBE.Events.CommandBarEvents(CmdCtrl)
    CmdEvtList.Add CmdEvtCls
  End With
  Set CmdEvtCls = Nothing
  Set CmdCtrl = Nothing
End Sub
'' 初期処理
'' Workbook_Open()
Private Sub Workbook_Open()
  Call DeleteMenu ' メニューの削除
  Call AddMenu ' メニューの追加
End Sub
'' 終了処理
'' Workbook_BeforeClose(Cancel As Boolean)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Call DeleteMenu ' メニューの削除
End Sub

このページの上

CmdEventClass
Option Explicit
'' VBE のコマンドのイベントのクラス
Public WithEvents CmdEvent As VBIDE.CommandBarEvents
'' メニューの処理
Private Sub CmdEvent_Click(ByVal CommandBarControl As Object, Handled As Boolean, CancelDefault As Boolean)
  Select Case CommandBarControl.Caption
    Case mcSelectLine ' 現在の行を選択します。(開始行は1桁目、終了行は最後の桁まで選択)
      Application.Run "SelectLine"
    Case mcInsertDateTime ' 現在の行に日付と時間を挿入します。
      Application.Run "Insert_DateTime"
    Case mcInsertGetOpenFilename ' 定型文「GetOpenFilename」の挿入
      Application.Run "Insert_GetOpenFilename_Text"
    Case mcInsertFile ' 最初のプロシージャーの前にファイルを挿入
      Application.Run "Insert_File"
    Case mcInsertLinesFile ' 現在の行に選択したファイルを挿入します。
      Application.Run "InsertLinesFile"
    Case mcCatLeft ' 行の左側に文字列を連結
      Application.Run "CodeModule.CatLeft"
    Case mcCatRight ' 行の右側に文字列を連結
      Application.Run "CodeModule.CatRight"
    Case mcAddLineToClip ' 行番号を付けてクリップボードにコピー
      Application.Run "CodeModule.AddLineToClip"
    Case mcFindLineToClip ' 検索文字を含む行をクリップボードにコピー
      Application.Run "CodeModule.FindLineToClip"
    Case mcDocToClip ' 行頭が ''の行のみクリップボードにコピー
      Application.Run "CodeModule.DocToClip"
    Case mcGotoLine ' 指定した行に移動
      Application.Run "CodeModule.GotoLine"
    Case mcGotoTop ' 先頭行に移動します。
      SendKeys "^{HOME}"
    Case mcGotoBottom ' 最終行に移動します。
      SendKeys "^{END}"
    Case mcGotoPrevProc ' 前のプロシージャーに移動します。
      SendKeys "^{UP}"
    Case mcGotoNextProc ' 次のプロシージャーに移動します。
      SendKeys "^{DOWN}"
    Case mcDeleteCurrentLine ' [Ctrl] + [Y]で現在の1行を削除します。
      SendKeys "^{y}"
    Case mcImmdiateCutAll
      SendKeys "^g", Wait:=True ' イミディエイト ウィンドウを表示します。
      SendKeys "^a", Wait:=True ' すべて選択
      SendKeys "^x", Wait:=True ' 切り取り
    Case Else
      MsgBox Prompt:=CommandBarControl.Caption & " コマンドの実行処理がありません!", Buttons:=vbCritical, Title:="エラー"
  End Select
  Handled = True
  CancelDefault = True
End Sub

このページの上