まとめ

▼

2010/06/30

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
Post: 0 件のコメント:

2010/06/29

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
Post: 0 件のコメント:

2010/06/11

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
Post: 0 件のコメント:

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
Post: 0 件のコメント:

2010/06/06

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
Post: 0 件のコメント:

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>
Post: 0 件のコメント:

access2010 contextualTabs tabSet idMso

TabSetFormToolsLayout
TabSetFormTools
TabSetReportToolsLayout
TabSetReportTools
TabSetRelationshipTools
TabSetQueryTools
TabSetMacroTools
TabSetPivotTableAccess
TabSetPivotChartAccess
TabSetTableToolsDatasheet
TabSetTableToolsDesign
TabSetFormDatasheet
TabSetAdpFunctionAndViewTools
TabSetAdpStoredProcedure
TabSetAdpSqlStatement
TabSetAdpDiagram
Post: 1 件のコメント:

2010/06/05

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)
Post: 0 件のコメント:

2010/06/03

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
Post: 0 件のコメント:

2010/06/02

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
Post: 0 件のコメント:

2010/06/01

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
Post: 0 件のコメント:

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
Post: 0 件のコメント: