access2010 SharedResources Tool

アプリケーションパーツでツール

Option Compare Database
Option Explicit

Private objFileSys As Object
Private objShell As Object

Private Sub Form_Load()
    Me.RecordSelectors = False
    Me.NavigationButtons = False
    Set objFileSys = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    SetlstResoueces
End Sub

Private Sub Form_Close()
    Set objFileSys = Nothing
    Set objShell = Nothing
End Sub

Private Sub addImage(imgnamestring As Variant, fullpathstring As Variant)
On Error Resume Next
    CurrentProject.AddSharedImage imgnamestring, fullpathstring
End Sub

Private Sub listResources()
    Dim Srs As SharedResources
    Dim Sr As SharedResource
    
    Set Srs = CurrentProject.Resources
    For Each Sr In Srs
        Debug.Print Sr.Name, Sr.Type
    Next
End Sub

Private Sub delResource(resourcenamestring As String)
    Dim Srs As SharedResources
    Dim Sr As SharedResource

    Set Srs = CurrentProject.Resources
    For Each Sr In Srs
        If Sr.Name = resourcenamestring Then Sr.Delete
    Next
End Sub

Private Sub cmdDelResource_Click()
    If IsNull(Me.lstResources) Then Exit Sub
    delResource Me.lstResources
    SetlstResoueces
End Sub

Private Sub cmdImageFile_Click()
    Dim fdialog As Office.FileDialog
    Dim varFilePath As Variant
    
    Set fdialog = Application.FileDialog(msoFileDialogFilePicker)
    With fdialog
        .AllowMultiSelect = True
        .Title = "ImageFileSelect"
        .Filters.Clear
        .Filters.Add "ImageFile", "*.gif; *.jpg; *.jpeg; *.png"
        .Filters.Add "すべてのファイル", "*.*"
        .InitialFileName = objShell.Namespace(&H27).self.Path & "\"
        If .Show = True Then
            For Each varFilePath In .SelectedItems
                addImage objFileSys.getbasename(varFilePath), varFilePath
            Next
        End If
    End With
    SetlstResoueces
End Sub

Private Sub cmdThemeFile_Click()
    CommandBars.ExecuteMso ("ThemeBrowseForThemes")
    SetlstResoueces
End Sub

Private Sub SetlstResoueces()
    Dim rs As Recordset
    Set rs = CurrentDb.OpenRecordset("select Name,Type from MSysResources order by Type;", dbReadOnly)
    Set Me.lstResources.Recordset = rs.Clone
    rs.Close: Set rs = Nothing
    Me.lstResources = Null
End Sub