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

Workbook



【ファイル名】Workbook.xlsm
【バージョン】Ver 1.0.3.0
【作成日】2015年02月15日
【更新日】2019年03月06日
【動作確認】Windows 7
【必要なソフト】Microsoft Excel 2010
【ダウンロード】Workbook.zip
【説明】Workbookのサンプルです。

メニュー

Windowsのファイル名に下記の半角文字は使えません。
\ / : * ? " < > |
またブックの名前に下記の半角文字を含む名前を付けて保存できません。(既に存在すれば開いたり上書き保存は可能)
[ ]
VBAで上記の文字を含むフォルダに名前を付けて保存する場合はカレントディレクトリを移動してからブック名のみで保存してください。

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="Sample" insertBeforeMso="TabHome" keytip="SAM">
        <group id="Group1" label="Workbook">
          <box id="Box1" boxStyle="horizontal">
 <!-- ■■■ プロパティ -->
            <menu id="PropertyMenu" label="プロパティ(&amp;P)" itemSize="normal" imageMso="PropertySheet" size="normal" keytip="P">
              <button id="ActiveWorkbookNameButton" label="ActiveWorkbook.Name(&amp;N)" supertip="アクティブワークブックのパスを除いたファイル名を表示します。"  imageMso="FunctionsRecentlyUsedtInsertGallery" onAction="onAction" />
              <button id="ActiveWorkbookFullNameButton" label="ActiveWorkbook.FullName(&amp;F)" supertip="アクティブワークブックのフル名を表示します。"  imageMso="BuildingBlocksOrganizer" onAction="onAction" />
              <button id="WorkbooksCountButton" label="Workbooks.Count(&amp;C)" supertip="開いているワークブックの数を表示します。"  imageMso="FunctionsEngineeringInsertGallery" onAction="onAction" />
              <button id="IsAddinButton" label="IsAddin(&amp;A)" supertip="現在のブックがアドインかを表示します。"  imageMso="AddInCommandsMenu" onAction="onAction" />
              <button id="PathButton" label="Path(&amp;P)" supertip="現在のブックのパスを表示します。"  imageMso="Folder" onAction="onAction" />
              <button id="ReadOnlyButton" label="ReadOnly(&amp;R)" supertip="現在のブックが読み込み専用かを表示します。"  imageMso="ReadOnly" onAction="onAction" />
              <button id="SavedButton" label="Saved(&amp;S)" supertip="現在のブックの保存状態を表示します。"  imageMso="FileSave" onAction="onAction" />
            </menu>
 <!-- ■■■ メソッド -->
            <menu id="MethodMenu" label="メソッド(&amp;M)" itemSize="normal" imageMso="Diamond" size="normal" keytip="M">
              <button id="WorkbooksAddButton" label="Workbooks.Add(&amp;N)" supertip="新しいブックのファイルを作成します。"  imageMso="FileNewDefault" onAction="onAction" />
              <button id="ChangeFileAccessButton" label="ChangeFileAccess(&amp;C)" supertip="現在のファイルを読み込み専用にします。"  imageMso="ReadOnly" onAction="onAction" />
              <button id="OpenButton" label="Open ReadOnly(&amp;O)" supertip="ファイルを読み取り専用で開きます。"  imageMso="FileOpen" onAction="onAction" />
              <menuSeparator id="MethodMenuSeparator1" />
              <button id="SaveButton" label="Save(&amp;S)" supertip="現在のファイルを上書き保存します。"  imageMso="FileSave" onAction="onAction" />
              <button id="SaveAsButton" label="SaveAs(&amp;A)" supertip="現在のファイルに名前を付けて保存します。"  imageMso="FileSaveAs" onAction="onAction" />
              <button id="CloseButton" label="Close(&amp;W)" supertip="現在のファイルを閉じます。"  imageMso="FileClose" onAction="onAction" />
              <button id="PrintPreviewButton" label="PrintPreview(&amp;P)" supertip="印刷プレビューします。"  imageMso="PrintAttach" onAction="onAction" />
            </menu>
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

このページの上

WorkbookModule
Option Explicit
Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理l
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  Dim fn As Variant

  On Error GoTo ErrorHandler ' エラー処理ルーチン
  Select Case control.ID
'---< プロパティ >--------------------------------------------------------------------------------------------------------
    Case "ActiveWorkbookFullNameButton"
      MsgBox Prompt:=Application.ActiveWorkbook.FullName, Buttons:=vbInformation, Title:="ActiveWorkbook.FullName"
    Case "IsAddinButton"
      MsgBox Prompt:=ActiveWorkbook.IsAddin, Buttons:=vbInformation, Title:="IsAddin"
    Case "PathButton"
      MsgBox Prompt:=ActiveWorkbook.Path, Buttons:=vbInformation, Title:="Path"
    Case "ReadOnlyButton"
      MsgBox Prompt:=ActiveWorkbook.ReadOnly, Buttons:=vbInformation, Title:="ReadOnly"
    Case "SavedButton"
      MsgBox Prompt:=ActiveWorkbook.Saved, Buttons:=vbInformation, Title:="Saved"
    Case "WorkbooksCountButton"
      MsgBox Prompt:=Application.Workbooks.Count, Buttons:=vbInformation, Title:="Workbooks.Count"
'---< メソッド >--------------------------------------------------------------------------------------------------------
    Case "WorkbooksAddButton"
      Workbooks.Add
    Case "ChangeFileAccessButton"
      ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly ' xlReadWriteは読み書きモード
    Case "CloseButton"
      ActiveWorkbook.Close
    Case "PrintPreviewButton"
      ActiveWorkbook.PrintPreview
    Case "SaveButton"
      ActiveWorkbook.Save
    Case "SaveAsButton"
      fn = Application.GetSaveAsFilename
'      Application.DisplayAlerts = False ' 上書き保存などの確認メッセージを表示しません。
      If VarType(fn) <> vbBoolean Then ActiveWorkbook.SaveAs FileName:=fn ' [Cancel]ボタンの場合は、vbBoolean
'      Application.DisplayAlerts = True ' メッセージを表示します。
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical, Title:="エラー"
  End Select
  Exit Sub

ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical, Title:="エラー"
End Sub
' 入力した数のシート数でブックを新規作成します。
Sub NewWorkBookSheetCount()
  Dim Num As Variant ' 入力数
  Dim sCount As Long ' ブックを新規作成時のシート数

  Num = Application.InputBox(Prompt:="シート数:", Title:="シート数の入力", Type:=1)
  If VarType(Num) = vbBoolean Then Exit Sub ' [キャンセル]ボタンを押した。
  If Num < 1 Then
    MsgBox Prompt:="1以上の数字を入力してください。", Buttons:=vbCritical, Title:="エラー"
    Exit Sub
  End If
  sCount = Application.SheetsInNewWorkbook
  Application.SheetsInNewWorkbook = CDec(Num)
  Workbooks.Add
  Application.SheetsInNewWorkbook = sCount
End Sub
' ダイアログで選択したファイルを読み込み専用で開きます。
Sub OpenReadOnly()
  Dim fn As Variant ' ファイル名

  fn = Application.GetOpenFilename(FileFilter:="エクセルファイル(*.xl*),*.xl*,テキストファイル(*.txt), *.txt,すべてのファイル(*.*),*.*", FilterIndex:=1, Title:="ファイルを読み込み専用モードで開く", ButtonText:="開く", MultiSelect:=False)
  If VarType(fn) = vbBoolean Then Exit Sub
  Workbooks.Open FileName:=fn, ReadOnly:=True ' 読み込み専用で開く
End Sub
' パス名に [ かあるいは、] を含むファイルでも名前を付けて保存します。
Sub SaveAsExcel(pWorkbook As Workbook, FileName As String)
  Dim drive As String
  Dim currentDir As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  currentDir = CurDir ' カレントディレクトリを保存します。
  ChDrive FSO.GetDriveName(FileName) ' ドライブを変更します。
  ChDir FSO.GetParentFolderName(FileName) ' カレントディレクトリを移動します。

  pWorkbook.SaveAs FileName:=FSO.GetFileName(FileName) ' カレントディレクトリに名前を付けて保存します。

  ChDrive FSO.GetDriveName(currentDir) ' ドライブを元に戻します。
  ChDir FSO.GetParentFolderName(currentDir) ' カレントディレクトリを元に戻します。
  Set FSO = Nothing
End Sub

下記はこのブックを、c:\temp\[Excel]フォルダに、test.xlsmのファイル名で保存します。
SaveAsExcel ThisWorkbook, "c:\temp\[Excel]\test.xlsm"

このページの上