ADO レコードセットクローン

未検証

Function CloneRecordSet(SourceRecordset As ADODB.Recordset) As ADODB.Recordset
    Dim AdoStrm As New ADODB.Stream
    Set CloneRecordSet = New ADODB.Recordset
    AdoStrm.Open
    SourceRecordset.Save AdoStrm
    CloneRecordSet.Open AdoStrm
    AdoStrm.Close: Set AdoStrm = Nothing
End Function

access2010 ラベルのフェードアウト表示

Shade値を詳細セクション背景色と同じになるまで変更

Option Compare Database
Option Explicit

Private Sub Form_Load()
'    Me.Section(0).BackThemeColorIndex = 1 '背景1:1  背景2:3
'    Me.Section(0).BackShade = 100

    Me.TimerInterval = 0    
    Me.lbl01.ForeThemeColorIndex = Me.Section(0).BackThemeColorIndex
    Me.lbl01.BackStyle = 0 '背景スタイル：透明
    Me.lbl01.BorderStyle = 0 '境界線スタイル：透明
    Me.lbl01.Caption = ""
End Sub

Private Sub Form_Timer()
On Error GoTo ErrHnd
    Me.lbl01.ForeShade = Me.lbl01.ForeShade + 10
    Me.TimerInterval = 50
    If Me.Section(0).BackShade < Me.lbl01.ForeShade Then
        Me.TimerInterval = 0
        Me.lbl01.Caption = ""
    End If
Exit Sub
ErrHnd:
    Me.TimerInterval = 0
    Me.lbl01.Caption = ""
End Sub

Public Sub ShowMsg(MsgString As String)
    Me.TimerInterval = 1000
    Me.lbl01.ForeShade = 0
    Me.lbl01.Caption = MsgString
End Sub

VBA 日付関数草案

'対象日に対応する締め日
'対象日:ExpressionDate:Date
'締日：CutoffDayNum:Int
'戻り値:直近の締め日:Date
Function CutoffDate(ExpressionDate As Date, ByVal CutoffDayNum As Integer) As Date
Dim tmp As String
    tmp = Format(DateAdd("m", 1, ExpressionDate - CutoffDayNum), "yyyy/mm/")
    Do Until IsDate(tmp & CStr(CutoffDayNum))
        CutoffDayNum = CutoffDayNum - 1
    Loop
    CutoffDate = DateValue(tmp & CStr(CutoffDayNum))
End Function

'締め日に対応する支払日
'締め日:ExpressionDate:Date
'隔月:IntervalMonth:Int 0:当月 1:翌月 2:翌々 3:翌々々　....
'月支払日:DayNum:Int
'戻り値:IntervalMonth指定の支払日:Date

Function PayDate(ExpressionDate As Date, IntervalMonth As Integer, ByVal DayNum As Integer) As Date
Dim tmp As String
    tmp = Format(DateAdd("m", IntervalMonth, ExpressionDate), "yyyy/mm/")
    Do Until IsDate(tmp & CStr(DayNum))
        DayNum = DayNum - 1
    Loop
    PayDate = DateValue(tmp & CStr(DayNum))
End Function

'対象日に対応する月初日
'対象日:ExpressionDate:Date
'隔月数IntervalMonth：Int　0:当月　1：翌月　-1：前月
'戻り値:IntervalMonth指定の月初日:Date
Function StartOfMonth(ExpressionDate As Date, Optional IntervalMonth As Integer = 0)
    StartOfMonth = DateSerial(Year(ExpressionDate), Month(ExpressionDate) + IntervalMonth, 1)
End Function

'対象日に対応する月末日
'対象日:ExpressionDate:Date
'隔月数IntervalMonth：Int　0:当月　1：翌月　-1：前月
'戻り値:IntervalMonth指定の月末日:Date
Function EndOfMonth(ExpressionDate As Date, Optional IntervalMonth As Integer = 0)
    EndOfMonth = DateSerial(Year(ExpressionDate), Month(ExpressionDate) + IntervalMonth + 1, 0)
End Function

VBA 配置済みコントロールからレコードセット作成

あまり覚えてないコード
非連結フォームで、エラー表示させたくないときのものだったかも

'*** セクション内コントロールから0件のレコードセット作成
Public Function EmptyRs(SrcSection As Section) As ADODB.Recordset
On Error GoTo ErrLabel
    Dim ctr As Control
    Dim rs As New ADODB.Recordset
    For Each ctr In SrcSection.Controls
        rs.Fields.Append ctr.ControlSource, adVarChar, 1
    Next
    rs.Open
    If rs.Fields.Count > 0 Then
        Set EmptyRs = rs
    Else
        Set EmptyRs = Nothing
    End If
    Set rs = Nothing
Exit Function
ErrLabel:
    If Err.Number = 438 Then Resume Next
End Function

access2010 互換性

ソースなしコンパイル済み(accde)での互換性
64製造32起動

32製造64起動

2007対応を含め、対応先でaccdeを作成してから配布

customUI xmlnsが違う
2007:
http://schemas.microsoft.com/office/2006/01/customui
2010:
http://schemas.microsoft.com/office/2009/07/customui

access2010 CustomUI

全部消しcustomUIxml。でも全部は使わないはず

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <ribbon startFromScratch="true">
    <contextualTabs>
      <tabSet idMso="TabSetFormToolsLayout" visible="false" />
      <tabSet idMso="TabSetFormTools" visible="false" />
      <tabSet idMso="TabSetReportToolsLayout" visible="false" />
      <tabSet idMso="TabSetReportTools" visible="false" />
      <tabSet idMso="TabSetRelationshipTools" visible="false" />
      <tabSet idMso="TabSetQueryTools" visible="false" />
      <tabSet idMso="TabSetMacroTools" visible="false" />
      <tabSet idMso="TabSetPivotTableAccess" visible="false" />
      <tabSet idMso="TabSetPivotChartAccess" visible="false" />
      <tabSet idMso="TabSetTableToolsDatasheet" visible="false" />
      <tabSet idMso="TabSetTableToolsDesign" visible="false" />
      <tabSet idMso="TabSetFormDatasheet" visible="false" />
      <tabSet idMso="TabSetAdpFunctionAndViewTools" visible="false" />
      <tabSet idMso="TabSetAdpStoredProcedure" visible="false" />
      <tabSet idMso="TabSetPivotChartAccess" visible="false" />
      <tabSet idMso="TabSetAdpDiagram" visible="false" />
    </contextualTabs>
  </ribbon>
  <backstage>
    <button idMso="FileSave" visible="false" />
    <button idMso="SaveObjectAs" visible="false" />
    <button idMso="FileSaveAsCurrentFileFormat" visible="false" />
    <button idMso="FileOpen" visible="false" />
    <button idMso="FileCloseDatabase" visible="false" />
    <tab idMso="TabInfo" visible="false" />
    <tab idMso="TabRecent" visible="false" />
    <tab idMso="TabNew" visible="false" />
    <tab idMso="TabPrint" visible="false" />
    <tab idMso="TabShare" visible="false" />
    <tab idMso="TabHelp" visible="false" />
    <button idMso="ApplicationOptionsDialog" visible="false" />
    <button idMso="FileExit" visible="false" />
  </backstage>
</customUI>

access2010 contextualTabs tabSet idMso

TabSetFormToolsLayout
TabSetFormTools
TabSetReportToolsLayout
TabSetReportTools
TabSetRelationshipTools
TabSetQueryTools
TabSetMacroTools
TabSetPivotTableAccess
TabSetPivotChartAccess
TabSetTableToolsDatasheet
TabSetTableToolsDesign
TabSetFormDatasheet
TabSetAdpFunctionAndViewTools
TabSetAdpStoredProcedure
TabSetAdpSqlStatement
TabSetAdpDiagram

RibbonUI VBA Callback Signature

要素	コールバック	VBAシグネチャ
(複数のコントロール)	getDescription	Sub GetDescription(control As IRibbonControl, ByRef description)
(複数のコントロール)	getEnabled	Sub GetEnabled(control As IRibbonControl, ByRef enabled)
(複数のコントロール)	getImage	Sub GetImage(control As IRibbonControl, ByRef image)
(複数のコントロール)	getImageMso	Sub GetImageMso(control As IRibbonControl, ByRef imageMso)
comboBox	getItemCount	Sub GetItemCount(control As IRibbonControl, ByRef count)
dropDown	getItemCount	Sub GetItemCount(control As IRibbonControl, ByRef count)
gallery	getItemCount	Sub GetItemCount(control As IRibbonControl, ByRef count)
gallery	getItemHeight	Sub getItemHeight(control As IRibbonControl, ByRef height)
comboBox	getItemID	Sub GetItemID(control As IRibbonControl, index As Integer, ByRef id)
dropDown	getItemID	Sub GetItemID(control As IRibbonControl, index As Integer, ByRef id)
gallery	getItemID	Sub GetItemID(control As IRibbonControl, index As Integer, ByRef id)
comboBox	getItemImage	Sub GetItemImage(control As IRibbonControl, index As Integer, ByRef image)
dropDown	getItemImage	Sub GetItemImage(control As IRibbonControl, index As Integer, ByRef image)
gallery	getItemImage	Sub GetItemImage(control As IRibbonControl, index As Integer, ByRef image)
comboBox	getItemLabel	Sub GetItemLabel(control As IRibbonControl, index As Integer, ByRef label)
dropDown	getItemLabel	Sub GetItemLabel(control As IRibbonControl, index As Integer, ByRef label)
gallery	getItemLabel	Sub GetItemLabel(control As IRibbonControl, index As Integer, ByRef label)
gallery	getItemScreenTip	Sub GetItemScreenTip(control As IRibbonControl, index as Integer, ByRef screen)
comboBox	getItemScreenTip	Sub GetItemScreenTip(control As IRibbonControl, index As Integer, ByRef screentip)
dropDown	getItemScreenTip	Sub GetItemScreenTip(control As IRibbonControl, index As Integer, ByRef screenTip)
gallery	getItemSuperTip	Sub GetItemSuperTip (control As IRibbonControl, index as Integer, ByRef screen)
comboBox	getItemSuperTip	Sub GetItemSuperTip (control As IRibbonControl, index As Integer, ByRef supertip)
dropDown	getItemSuperTip	Sub GetItemSuperTip (control As IRibbonControl, index As Integer, ByRef superTip)
gallery	getItemWidth	Sub getItemWidth(control As IRibbonControl, ByRef width)
(複数のコントロール)	getKeytip	Sub GetKeytip (control As IRibbonControl, ByRef label)
(複数のコントロール)	getLabel	Sub GetLabel(control As IRibbonControl, ByRef label)
checkBox	getPressed	Sub GetPressed(control As IRibbonControl, ByRef returnValue)
toggleButton	getPressed	Sub GetPressed(control As IRibbonControl, ByRef returnValue)
(複数のコントロール)	getScreentip	Sub GetScreentip(control As IRibbonControl, ByRef screentip)
(複数のコントロール)	getSupertip	Sub GetScreentip(control As IRibbonControl, ByRef screentip)
dropDown	getSelectedItemID	Sub GetSelectedItemID(control As IRibbonControl, ByRef index)
gallery	getSelectedItemID	Sub GetSelectedItemID(control As IRibbonControl, ByRef index)
dropDown	getSelectedItemIndex	Sub GetSelectedItemIndex(control As IRibbonControl, ByRef index)
gallery	getSelectedItemIndex	Sub GetSelectedItemIndex(control As IRibbonControl, ByRef index)
button	getShowImage	Sub GetShowImage (control As IRibbonControl, ByRef showImage)
button	getShowLabel	Sub GetShowLabel (control As IRibbonControl, ByRef showLabel)
(複数のコントロール)	getSize	Sub GetSize(control As IRibbonControl, ByRef size)
comboBox	getText	Sub GetText(control As IRibbonControl, ByRef text)
editBox	getText	Sub GetText(control As IRibbonControl, ByRef text)
menuSeparator	getTitle	Sub GetTitle (control As IRibbonControl, ByRef title)
(複数のコントロール)	getVisible	Sub GetVisible(control As IRibbonControl, ByRef visible)
customUI	loadImage	Sub LoadImage(imageId As string, ByRef image)
command	onAction	Sub OnAction(control As IRibbonControl, ByRef CancelDefault)
button	onAction	Sub OnAction(control As IRibbonControl)
toggleButton	onAction	Sub OnAction(control As IRibbonControl, pressed As Boolean)
checkBox	onAction	Sub OnAction(control As IRibbonControl, pressed As Boolean)
dropDown	onAction	Sub OnAction(control As IRibbonControl, selectedId As String, selectedIndex As Integer)
gallery	onAction	Sub OnAction(control As IRibbonControl, selectedId As String, selectedIndex As Integer)
editBox	onChange	Sub OnChange(control As IRibbonControl, text As String)
comboBox	onChange	Sub OnChange(control As IRibbonControl, text As String)
customUI	onLoad	Sub OnLoad(ribbon As IRibbonUI)
customUI	loadImage	Sub LoadImage(imageId As String, ByRef image)
Backstage	onHide	Sub OnHide(contextObject As Object)
Backstage	onShow	Sub OnShow(contextObject As Object)
dynamicMenu	getContent	Sub GetContent(control As IRibbonControl, ByRef returnedVal)
(複数のコントロール)	getHelperText	Sub GetHelperText(control As IRibbonControl, itemIndex as Integer, ByRef returnedVal)
Image Control	getAltText	Sub GetAltText(control As IRibbonControl, ByRef returnedVal)

ShellSpecialFolderConstants Enumeration

ShellSpecialFolderConstants Enumeration
Shellでフォルダパスを取得するときに使う定数

Sub sample()
    Debug.Print CreateObject("Shell.Application").NameSpace(&H27)
    Debug.Print CreateObject("Shell.Application").NameSpace(&H27).self.Path
End Sub

access2010 CustomUI xml読み込んでからのRibbon設定

'Form:F01
Option Compare Database
Option Explicit

Private Sub Form_Load()
    rbn01.CreateRibbon
    Me.RibbonName = rbn01.rbnName
End Sub

'標準Module:rbn01
Option Compare Database
Option Explicit

Private rbn As IRibbonUI

Public Const rbnName = "rbnName"
Private Const xmlFilePath = "xmlFileFullPath"

Public Function OnLoad(ribbon As IRibbonUI)
    Set rbn = ribbon
End Function

Public Sub CreateRibbon()
    If Not rbn Is Nothing Then Exit Sub
    Dim xmldoc As Object
    Set xmldoc = CreateObject("MSXML2.DOMDocument")
    xmldoc.Load xmlFilePath
    Application.LoadCustomUI rbnName, xmldoc.xml
    Set xmldoc = Nothing
End Sub

access2010 AllowBypasskey Tool

アプリケーションパーツでツール
モーダルにしとけばいいんだな

Option Compare Database
Option Explicit

Private Sub Form_Load()
    Me.RecordSelectors = False
    Me.NavigationButtons = False
    SettglAllowBypasskey
End Sub

Private Sub cmdDelAllowBypassKey_Click()
On Error Resume Next
    CurrentDb.Properties.Delete "AllowBypassKey"
    SettglAllowBypasskey
End Sub

Private Sub tglAllowBypasskey_Click()
    With Me.tglAllowBypasskey
        SetBypassProperty .Value
        .Caption = "AllowBypasskey = " & CBool(.Value)
    End With
End Sub

Private Sub cmdClose_Click()
    DoCmd.Close
End Sub

Private Sub SetBypassProperty(fBool As Boolean)
Const DB_Boolean As Long = 1
    ChangeProperty "AllowBypassKey", DB_Boolean, fBool
End Sub

Private Sub SettglAllowBypasskey()
On Error GoTo ErrHnd
    With Me.tglAllowBypasskey
        .Value = CurrentDb.Properties("AllowBypassKey")
        .Caption = "AllowBypasskey = " & .Value
    End With
Exit Sub
ErrHnd:
    If Err.Number = 3270 Then
        Me.tglAllowBypasskey.Caption = "未設定"
        Me.tglAllowBypasskey = True
    Else
        MsgBox Err.Number
    End If
End Sub

Private Function ChangeProperty(strPropName As String, _
                                varPropType As Variant, _
                                varPropValue As Variant) As Integer

    Dim dbs As Object, prp As Variant
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo Change_Err
    dbs.Properties(strPropName) = varPropValue
    ChangeProperty = True

Change_Bye:
    Exit Function

Change_Err:
    If Err = conPropNotFoundError Then ' プロパティが見つからないエラーの場合。
        Set prp = dbs.CreateProperty(strPropName, _
                                     varPropType, varPropValue)
        dbs.Properties.Append prp
        Resume Next
    Else
        ' 不明なエラーの場合。
        ChangeProperty = False
        Resume Change_Bye
    End If
End Function

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