access2010 VSTOアプリケーションアドイン -3-

閉じる時、Auto Compactが設定されていると遅いなぁと思うことが多いので。

閉じる時は意図があってAuto Compactだとしても、バックアップをさらっとできるように。

<?xml version="1.0" encoding="UTF-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" 
          onLoad="Ribbon_Load">
  <backstage>
    <button id="cmdQuickBuckUp" 
            imageMso="SaveObjectAs" 
            label="速やかにBackUp"  
            insertBeforeMso="FileSave"
            onAction="BS_cmdClick"
            getVisible="BS_cmdGetVisible"/>
    <tab idMso="TabShare">
      <firstColumn>
        <taskFormGroup idMso="GroupShare">
          <category idMso="FileTypes">
            <task idMso="SaveDatabaseAs">
              <group id="BackUp">
                <primaryItem>
                  <button id="shareQuickBuckUp" 
                          imageMso="SaveObjectAs" 
                          label="速やかにBackUp" 
                          onAction="BS_cmdClick"/>
                </primaryItem>
              </group>
            </task>
          </category>          
        </taskFormGroup>
      </firstColumn>
    </tab>
  </backstage>
</customUI>>

Auto Compactが設定されているならいったん解除してコピーが終わったらもとに戻す時用にThisAddIn.vbにAuto Compactのプロパティを作った。ほんとは例外処理のことをちゃんとしなければならないのだけど、今回のお題については影響が少ないのでこれで。FinallyでCloseしておかないと調子悪い。

Public Property Auto_Compact As Boolean
    Get
        Dim dbs As DAO.Database = Me.Application.CurrentDb
        Try
            Return CInt(dbs.Properties("Auto Compact").Value) = 1I
        Catch ex As Exception
            Return False
        Finally
            dbs.Close()
        End Try
    End Get
    Set(value As Boolean)
        Dim dbs As DAO.Database = Me.Application.CurrentDb
        Try
            dbs.Properties("Auto Compact").Value = Math.Abs(CInt(value))
        Catch ex As Exception
        Finally
            dbs.Close()
        End Try
    End Set
 End Property

で、リボンコントロールに割り当てるプロシージャ。

Public Sub BS_cmdClick(control As Office.IRibbonControl)
    QuickBackUp()
End Sub

Public Function BS_cmdGetVisible(control As Office.IRibbonControl) As Boolean
    Return Not Globals.ThisAddIn.Application.CurrentProject.FullName.Length = 0
End Function

Private Sub QuickBackUp()
    Dim AutoCompact As Boolean = Globals.ThisAddIn.Auto_Compact
    Dim FileFullName As String = Globals.ThisAddIn.Application.CurrentProject.FullName
    Dim FileDir As String = IO.Path.GetDirectoryName(FileFullName)
    Dim FileName As String = IO.Path.GetFileNameWithoutExtension(FileFullName)
    Dim FileExt As String = IO.Path.GetExtension(FileFullName)
    Dim TimeCode As String = Now.ToString("yyyyMMddHHmmss")
    If AutoCompact Then Globals.ThisAddIn.Auto_Compact = False
    Globals.ThisAddIn.Application.CloseCurrentDatabase()
    My.Computer.FileSystem.CopyFile(FileFullName,
                                    IO.Path.Combine(FileDir,
                                                    FileName + TimeCode + FileExt),
                                    FileIO.UIOption.AllDialogs,
                                    FileIO.UICancelOption.DoNothing)
    Globals.ThisAddIn.Application.OpenCurrentDatabase(FileFullName)
    If AutoCompact Then Globals.ThisAddIn.Auto_Compact = True
End Sub

最適化コマンドをオーバーライドにも使うとしよう。adp対応はそのうちに。