Excel2000 VBA メニューバーに新しいメニューを作りファイルを開く 実験

Excel2000 VBA  メニューバーに新しいメニューを作りファイルを開く　実験

Sub メニューバーにメニューを追加()
'
'ttp://officetanaka.net/excel/vba/tips/tips05.htm

Dim NewM, NewC, cntrl, WMC As Variant
Dim Mname As String

'メニューの名前（メニューバーに表示される名前）
    Mname = "File(&L)"  '(&L)はALT+Lキーで開く
'メニューバーの重複チェック
For Each cntrl In CommandBars("Worksheet Menu Bar").Controls
    If cntrl.Caption = Mname Then cntrl.Delete  '重複を削除する
Next cntrl
    
'メニューバーに新しいメニューを追加
    Set NewM = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
    NewM.Caption = Mname
'オリジナルコマンドを追加する(1)
    Set NewC = NewM.Controls.Add
    With NewC
        .Caption = "So-netBlog"
        .OnAction = "sonetblog_open"
        .BeginGroup = False
        '.FaceId =
    End With
'オリジナルコマンドを追加する(2)
    Set NewC = NewM.Controls.Add
    With NewC
        .Caption = "出納帳"
        .OnAction = "出納帳_open"
        .BeginGroup = True
        .FaceId = 450
    End With
End Sub

ファイルを開くマクロ
Sub 出納帳_open()
On Error Resume Next 'パスワードが掛かっていてキャンセルが押された時のエラー処理
Workbooks.Open Filename:="D:\bk\office\2010出納帳.xls"
End Sub

Sub sonetblog_open()
On Error Resume Next 'パスワードが掛かっていてキャンセルが押された時のエラー処理
Workbooks.Open Filename:="d:\bk\office\sonetblog2.xls"
End Sub

---

 

アクティブブックからファイルオープン用VBAコード作成




Sub ブックオープン作成()
'アクティブブックのファイルオープン用マクロ文字列を作成
'マクロ名？（プロシージャ）は拡張子を取り除いたファイル名
'
Dim newStr, book_name As String

'アクティブブック名を取得
    book_name = ActiveWorkbook.Name
'拡張子削除
    strLen = Len(book_name)
    For i = 1 To strLen
   ' Debug.Print Mid(book_name, i, 1)
        If Mid(book_name, i, 1) = "." Then dotL = i
    Next i
    book_name = Left(book_name, dotL - 1)

'ドット以下の文字を削除
    'book_name = Left(book_name, InStr(book_name, ".") - 1)

'文字列作成
    newStr = "Sub " & book_name & "()" & vbCr & "    On Error Resume Next" & vbCr & "    Workbooks.Open Filename:=" & Chr(34) & ActiveWorkbook.FullName & Chr(34) & vbCr & "End Sub"

'クリップボードにコピー
    'DataObjectを利用するには、Microsoft Forms 2.0 Object Libraryが必要
    'VBEでツール→参照設定→Microsoft Forms 2.0 Object Libraryにチェックを入れる
    Dim CB As DataObject
        Set CB = New DataObject
    With CB
        .SetText newStr
        .PutInClipboard
    End With

    Set CB = Nothing
    MsgBox newStr & vbCrLf + vbCrLf & "クリップボードにコピーしました。"
End Sub

タグ：Excel2000 VBA