'===========================================================
' メニュー表示ＶＢＡマクロ サンプルプログラム
'                                   By 1998/ 2/10  Ryn
                           Last Update 1999/10/ 4
'===========================================================
'-----------------------------------------------------------
'　メニューの追加
'-----------------------------------------------------------
Sub UserMenuBarAdd()

    Dim Menubar As CommandBar

    UserMenuBarDelete				' ２重登録のチェック

    Set Menubar = Application.CommandBars.Add _
        (Name:="MyMenu", Position:=msoBarTop, Menubar:=True, Temporary:=True)
    With Menubar
        .Protection = msoBarNoChangeDock + _
                      msoBarNoChangeVisible + _
                      msoBarNoCustomize + _
                      msoBarNoMove + _
                      msoBarNoResize
       .Visible = True
    End With

    With Menubar
        .Controls.Add Type:=msoControlPopup, Temporary:=False
        .Controls(1).Caption = "ファイル(&F)"

        With .Controls(1)
            .Controls.Add Type:=msoControlButton
            With .Controls(1)
                .Caption = "上書き保存(&S)"
                .TooltipText = "上書き保存"
                .Style = msoButtonIconAndCaption
                .FaceId = 3
                .OnAction = "上書き保存"
            End With
        End With

        With .Controls(1)
            .Controls.Add Type:=msoControlButton
            With .Controls(2)
                .Caption = "終了(&X)"
                .TooltipText = "終了"
                .Style = msoButtonIconAndCaption
                .OnAction = "終了"
            End With
        End With
'------
        .Controls.Add Type:=msoControlPopup, Temporary:=False
        .Controls(2).Caption = "設定(&C)"

        With .Controls(2)
            .Controls.Add Type:=msoControlButton
            With .Controls(1)
                .Caption = "自動計算(&A)"
                .TooltipText = "自動計算"
                .Style = msoButtonIconAndCaption
                .OnAction = "自動計算"
            End With
        End With

        With .Controls(2)
            .Controls.Add Type:=msoControlButton
            With .Controls(2)
            .Caption = "手動計算(&M)"
            .TooltipText = "手動計算"
            .Style = msoButtonIconAndCaption
            .OnAction = "手動計算"
            End With
        End With

        With .Controls(2)
            .Controls.Add Type:=msoControlButton
            With .Controls(3)
                .Caption = "再計算(&N)"
                .TooltipText = "再計算"
                .Style = msoButtonIconAndCaption
                .FaceId = 960
                .OnAction = "再計算"
            End With
        End With
'------
       .Controls.Add Type:=msoControlPopup, Temporary:=False
        .Controls(3).Caption = "編集(&E)"

        With .Controls(3)
            .Controls.Add Type:=msoControlButton
            With .Controls(1)
                .Caption = "コピー(&C)"
                .TooltipText = "コピー"
                .Style = msoButtonIconAndCaption
                .FaceId = 19
                .OnAction = "コピー"
            End With
        End With

        With .Controls(3)
            .Controls.Add Type:=msoControlButton
            With .Controls(2)
                .Caption = "値の貼り付け(&P)"
                .TooltipText = "値の貼り付け"
                .Style = msoButtonIconAndCaption
                .FaceId = 22
                .OnAction = "貼り付け"
            End With
        End With

        With .Controls(3)
            .Controls.Add Type:=msoControlButton
            With .Controls(3)
                .Caption = "値のクリア(&D)"
                .TooltipText = "値のクリア"
                .Style = msoButtonIconAndCaption
                .FaceId = 47
                .OnAction = "値クリア"
            End With
        End With

        With .Controls(3)
            .Controls.Add Type:=msoControlButton
            With .Controls(4)
                .Caption = "連続データ[値]の作成(&S)"
                .TooltipText = "連続データ[値]の作成"
                .Style = msoButtonIconAndCaption
                .OnAction = "連続データ"
                .BeginGroup = True
            End With
        End With
'------
        .Controls.Add Type:=msoControlPopup, Temporary:=False
        .Controls(4).Caption = "書式(&O)"

        With .Controls(4)
            .Controls.Add Type:=msoControlButton
            With .Controls(1)
                .Caption = "行高(&W)"
                .TooltipText = "行高"
                .Style = msoButtonIconAndCaption
                .FaceId = 541
                .OnAction = "行高"
            End With
        End With

        With .Controls(4)
            .Controls.Add Type:=msoControlButton
            With .Controls(2)
                .Caption = "列幅(&E)"
                .TooltipText = "列幅"
                .Style = msoButtonIconAndCaption
                .FaceId = 542
                .OnAction = "列幅"
            End With
        End With

        With .Controls(4)
            .Controls.Add Type:=msoControlButton
            With .Controls(3)
                .Caption = "フォント(&F)"
                .TooltipText = "フォント"
                .Style = msoButtonIconAndCaption
                .OnAction = "フォント"
            End With
        End With
'------
        .Controls.Add Type:=msoControlPopup, Temporary:=False
        .Controls(5).Caption = "その他(&O)"
        
        With .Controls(5)
            .Controls.Add Type:=msoControlButton
            With .Controls(1)
                .Caption = "システムメニュー(&D)"
                .TooltipText = "システムメニュー"
                .Style = msoButtonIconAndCaption
                .OnAction = "UserMenuBarDelete"
            End With
        End With

        With .Controls(5)
            .Controls.Add Type:=msoControlButton
            With .Controls(2)
                .Caption = "バージョン情報(&A)"
                .TooltipText = "バージョン情報"
                .Style = msoButtonIconAndCaption
                .FaceId = 1954
                .OnAction = "バージョン情報"
            End With
        End With
    End With

    自動計算					' 計算方法の初期化

End Sub


'-----------------------------------------------------------
'　「ファイル」−「上書き保存」「終了」
'-----------------------------------------------------------
Sub 上書き保存()
    Application.EnableCancelKey = xlDisabled
    Application.ScreenUpdating = False
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
End Sub


Sub 終了()
    Application.EnableCancelKey = xlDisabled
    If MsgBox("終了しますか？", vbQuestion + vbOKCancel, "終 了") = vbOK Then
        Application.Quit
    End If
End Sub



'-----------------------------------------------------------
'　「設定」−「手動計算」「自動計算」「再計算」
'-----------------------------------------------------------
Sub 手動計算()
    Application.EnableCancelKey = xlDisabled
    Application.Calculation = xlManual
'
    With CommandBars("MyMenu")
        .Controls("設定(&C)").Controls("自動計算(&A)").State = msoButtonUp
        .Controls("設定(&C)").Controls("手動計算(&M)").State = msoButtonDown
        .Controls("設定(&C)").Controls("再計算(&N)").Enabled = True
    End With
End Sub


Sub 自動計算()
    Application.EnableCancelKey = xlDisabled
    Application.Calculation = xlAutomatic
'
    With CommandBars("MyMenu")
        .Controls("設定(&C)").Controls("自動計算(&A)").State = msoButtonDown
        .Controls("設定(&C)").Controls("手動計算(&M)").State = msoButtonUp
        .Controls("設定(&C)").Controls("再計算(&N)").Enabled = False
    End With
End Sub


Sub 再計算()
    Application.EnableCancelKey = xlDisabled
    Calculate
End Sub



'-----------------------------------------------------------
'　「設定」−「コピー」
'-----------------------------------------------------------
Sub コピー()
    Application.EnableCancelKey = xlDisabled
    Selection.Copy
End Sub


'-----------------------------------------------------------
'　「設定」−「貼り付け」
'-----------------------------------------------------------
' 値のみ貼り付けします。
'
Sub 貼り付け()
    Application.EnableCancelKey = xlDisabled
    On Error GoTo Error_Check
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Exit Sub

Error_Check:
    MsgBox "貼り付け出来ません", vbExclamation, "エラーメッセージ"
    Resume Next
End Sub


'-----------------------------------------------------------
'　「設定」−「クリア」
'-----------------------------------------------------------
' 値のみクリアします。
'
Sub 値クリア()
    Application.EnableCancelKey = xlDisabled
    Selection.ClearContents
End Sub


'-----------------------------------------------------------
'　「設定」−「連続データ」
'-----------------------------------------------------------
' Excelの「連続データ」は書式も変化させますが、
' これは、値のみ変化してゆきます。
'
Sub 連続データ()
    Dim Hanxi, Hanxi2, CELL As Object
    
    Dim Atai As Long
    
    Application.EnableCancelKey = xlDisabled
    On Error GoTo Error_Check
    Application.ScreenUpdating = False
    Set Hanxi = Selection
    Atai = Cells(Hanxi.Row, Hanxi.Column).Value
    Set Hanxi2 = Range(Cells(Hanxi.Row + 1, Hanxi.Column), _
                   Cells(Hanxi.Rows(Hanxi.Rows.Count).Row, Hanxi.Column))
    For Each CELL In Hanxi2
        Atai = Atai + 1
        CELL.Value = Atai
    Next
    Application.ScreenUpdating = True
    Exit Sub

Error_Check:
    MsgBox "処理出来ません", vbExclamation, "エラーメッセージ"
    Application.ScreenUpdating = True
End Sub



'-----------------------------------------------------------
'　「書式」−「列幅」「行高」「フォント」
'-----------------------------------------------------------
Sub 列幅()
    Application.Dialogs(xlDialogColumnWidth).Show
End Sub


Sub 行高()
    Application.Dialogs(xlDialogRowHeight).Show
End Sub


Sub フォント()
    Selection.Activate
    Application.Dialogs(xlDialogActiveCellFont).Show
End Sub



'-----------------------------------------------------------
'　「その他」−「システムメニュー」
'-----------------------------------------------------------
' MyMenuコマンドバーがあれば、削除します。
'
Sub UserMenuBarDelete()
    Dim cb As Object
    
    For Each cb In CommandBars
        If cb.Name = "MyMenu" Then
            cb.Delete
        End If
    Next
End Sub


'-----------------------------------------------------------
'　「その他」−「バージョン情報」
'-----------------------------------------------------------
Sub バージョン情報()
    Application.EnableCancelKey = xlDisabled
    MsgBox "メニュー表示ＶＢＡマクロ サンプルプログラム" & Chr$(13) & Chr$(10) & _
        Chr$(9) & Chr$(9) & "　　［１９９８／０２／１０］" & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10) & _
        Chr$(9) & "Ｐｒｏｇｒａｍｉｎｇ　Ｂｙ　Ｒｙｎ（林　道雄）" & Chr$(13) & Chr$(10), _
        vbInformation, "バージョン情報"
End Sub