'
' メニュ− マクロ
' ﾏｸﾛ作成日 :
'
Const dv As String = "b:"       '[1]実行するマクロの入っているドライブ
Const dr As String = "\VBAtest" '[2]実行するマクロの入っているディレクトリ−
Const mym As String = "Mymenyu" '[3]メニュ−バ−の名前


Dim er As Integer               'シ−トオ−プンをチェック
'
Sub aaaaa()

'--------デバッグの時 ’を外す--------
'   On Error Resume Next
'    CommandBars(mym).Delete
'   On Error GoTo 0
'------------------------------------
'メニューバーの追加
    chkm = 0
    For Each cm In Application.CommandBars
        If cm.Name = mym Then
              CommandBars(mym).Visible = True
              chkm = 1
              Exit Sub
        End If
    Next
 
     If chkm = 0 Then
 Set menu2 = Application.CommandBars.Add _
(Name:=mym, MenuBar:=True)

        With menu2
          .Visible = True
          .Controls.Add Type:=msoControlPopup
              .Controls(1).Caption = "ﾌｧｲﾙ"
          .Controls.Add Type:=msoControlPopup
              .Controls(2).Caption = "HTMLへ変換"
          .Controls.Add Type:=msoControlPopup
              .Controls(3).Caption = "ﾒﾆｭ-終了"
        End With
     End If
'
'メニューの追加
Set menu2 = CommandBars(mym).Controls(1)
With menu2
   .Controls.Add Type:=msoControlButton
   With .Controls(1)
        .Caption = "開く"
        .OnAction = "men10"
   End With
   .Controls.Add Type:=msoControlButton
   With .Controls(2)
        .Caption = "閉じる"
        .OnAction = "men11"
   End With
    .Controls.Add Type:=msoControlButton
   With .Controls(3)
        .Caption = "上書き保存"
        .OnAction = "men12"
        .BeginGroup = True
   End With
    .Controls.Add Type:=msoControlButton
   With .Controls(4)
        .Caption = "名前を付けて保存"
        .OnAction = "men13"
   End With
   .Controls.Add Type:=msoControlButton
   With .Controls(5)
        .Caption = "Excelの終了"
        .OnAction = "men14"
        .BeginGroup = True
   End With
End With

Set menu2 = CommandBars(mym).Controls("HTMLへ変換")
With menu2
   .Controls.Add Type:=msoControlButton
   With .Controls(1)
        .Caption = "HTML変換スタ−ト"
        .OnAction = "Macro1"
   End With
'サブメニュウ項目の追加
   .Controls.Add Type:=msoControlPopup
   With .Controls(2)
        .Caption = "メニュー項目"
        .BeginGroup = True
        .Controls.Add Type:=msoControlButton
        .Controls(1).Caption = "サブメニュウ１"
        .Controls(1).OnAction = "Macro3"
        
        .Controls.Add Type:=msoControlButton
        .Controls(2).Caption = "サブメニュウ２"
        .Controls(2).OnAction = "Macro4"
   End With
End With
   
Set menu2 = CommandBars(mym).Controls("ﾒﾆｭ-終了")
With menu2
   .Controls.Add Type:=msoControlButton
   With .Controls(1)
        .Caption = "excelに戻る"
        .OnAction = "men70"
   End With
    .Controls.Add Type:=msoControlButton
   With .Controls(2)
        .Caption = "キャンセル"
   End With
 End With
End Sub
'
Sub men10()
    fname = Application.GetOpenFilename
      If fname = False Then
      Exit Sub
    End If
    Workbooks.Open Filename:=fname
End Sub
Sub men11()
       ActiveWorkbook.Close
End Sub
Sub men12()
       ActiveWorkbook.Save
End Sub
Sub men13()
    fname = Application.GetSaveAsFilename
      ActiveWorkbook.SaveAs Filename:=fname, FileFormat:=xlNormal, _
      Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
      , CreateBackup:=False
End Sub
Sub men14()
     Application.Quit
End Sub
'
Sub men20()
      Workbooks.Open Filename:=dv & dr & "\cg_EXa.xls"
      Application.Run macro:="cg_EXa.xls!chengs"
End Sub

Sub men70()
    On Error Resume Next
    shsuu = Worksheets.Count
    For i = 1 To shsuu
      Worksheets(i).Activate
      If ActiveSheet.Type = xlWorksheet Then
         MenuBars(xlWorksheet).Activate
         er1 = 1
         Exit For
       End If
     Next
     If er1 = 0 Then
     Workbooks.Add
     MenuBars(xlWorksheet).Activate
     End If
     On Error GoTo 0
End Sub