VBAコード
EXCEL-VBA
概要
仕事でよく使う、表計算のEXCELのVBA、シート関数、簡易データベースのACCESSのVBA、SQLなどの資源となるコードを書き綴ったものです。
オリジナルカレンダー
アクセスの日付入力補助フォーム
フォームに追加された日付/時刻型のフィールドには、標準で日付選択カレンダーが表示され、カレンダーから日付をクリックするだけで日付を入力できますが、スピンボタンが月単位の送りしかできないので、過去の古い日付を入れようとすると手間がかかる２年前を入れようと思ったら、２４回押さなくてはいけない。
あと、土曜日、日曜日、休日の色分けがあったほうが、やっぱり扱いやすい。
ということで、作りました。
左上のスピンボタンは、年をインクリメントします。名前は「PY」「NY]とし、間のテキストボックスは「DYEAR」としています。
右の２つのスピンボタンは、月をインクリメントをして名前は「PM」「NM]とし間のテキストボックスは「DMONTH」としています。
下の横に並んだ７つラベルは曜日を表示し、名前は「Y0」・・「Y6」とします。
その下４２個のラベルは、日にちを表示し、名前は「Day０」・・「Day4１」とします。
最下部のボタンは、初期はカレンダーを開いた時の日付に戻します。削除は呼び出したコントロール（編集不可の場合）の値を削除します。閉じるはフォームを閉じます。
コントロールの名前を図で表すと次のようになっています。
赤色は Label、青色はCommandButton、緑色は TextBox です。
C_Controls
'-----------------------------------
'イベントクラスをまとめる C_Controls
'-----------------------------------
Option Explicit
'-----------------------------------
'このクラスが発生するイベント
Public Event Click(myCont As Object)
Public Event Change(myCont As Object)
Public Event DblClick(myCont As Object, _
Cancel As Integer)
Public Event MouseMove(myCont As Object, _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Public Event KeyPress(myCont As Object, _
KeyAscii As Integer)
Public Event KeyDown(myCont As Object, _
KeyCode As Integer, _
Shift As Integer)
'イベントクラスのリスト
Private Labels As Dictionary
Private TextBoxs As Dictionary
Private Buttons As Dictionary
'呼び出しフォーム
Private myParent As Object
'-----------------------------------
'呼び出しフォームを格納します。
Public Property Set Parent(ByRef Obj As Object)
Set myParent = Obj
End Property
'-----------------------------------
'イベントクラスがあるかの確認に使います。
Public Property Get Exitst(ByVal objTypeName As String) As Boolean
Select Case objTypeName
Case "TextBox"
Exitst = (TextBoxs.Count > 0)
Case "Label"
Exitst = (Labels.Count > 0)
Case "CommandButton"
Exitst = (Buttons.Count > 0)
End Select
End Property
'-----------------------------------
'子オブジェクトから呼び出されます。
Public Sub onClick(myCont As Object)
'イベントを発生します。
RaiseEvent Click(myCont)
End Sub
'-----------------------------------
'子オブジェクトから呼び出されます。
Public Sub onDblClick(myCont As Object, Cancel As Integer)
'イベントを発生します。
RaiseEvent DblClick(myCont, Cancel)
End Sub
'-----------------------------------
'子オブジェクトから呼び出されます。
Public Sub onMouseMove(myCont As Object, _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
'イベントを発生します。
RaiseEvent MouseMove(myCont, Button, Shift, X, Y)
End Sub
'-----------------------------------
'子オブジェクトから呼び出されます。
Public Sub onChange(myCont As Object)
'イベントを発生します。
RaiseEvent Change(myCont)
End Sub
'-----------------------------------
'子オブジェクトから呼び出されます。
Public Sub onKeyPress(myCont As Object, _
KeyAscii As Integer)
'イベントを発生します。
RaiseEvent KeyPress(myCont, KeyAscii)
End Sub
'-----------------------------------
'子オブジェクトから呼び出されます。
Public Sub onKeyDown(myCont As Object, _
KeyCode As Integer, _
Shift As Integer)
'イベントを発生します。
RaiseEvent KeyDown(myCont, KeyCode, Shift)
End Sub
'-----------------------------------
'フォームから呼び出されます。
Public Sub Init()
Dim Ctrl As Control
Dim Obj As Object
'フォームの格納がなければ処理をしません。
If myParent Is Nothing Then
Exit Sub
End If
'フォームを探査してコントロールのイベントクラスを登録します。
For Each Ctrl In myParent.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
With New C_TextBox
Set .Item = Ctrl
Set .Parent = Me
TextBoxs.Add Ctrl.Name, .Self
End With
Case "Label"
With New C_Label
Set .Item = Ctrl
Set .Parent = Me
Labels.Add Ctrl.Name, .Self
End With
Case "CommandButton"
With New C_Button
Set .Item = Ctrl
Set .Parent = Me
Buttons.Add Ctrl.Name, .Self
End With
End Select
Next Ctrl
End Sub
'-----------------------------------
'イベントクラスのリストの中身を削除します。
Private Sub ObjectDelete()
Dim Keys As Variant
For Each Keys In TextBoxs
TextBoxs(Keys).DEL
Next Keys
Set TextBoxs = Nothing
For Each Keys In Labels
Labels(Keys).DEL
Next Keys
Set Labels = Nothing
For Each Keys In Buttons
Buttons(Keys).DEL
Next Keys
Set Buttons = Nothing
Set myParent = Nothing
End Sub
'-----------------------------------
'イベントクラスのリストを作成します。
Private Sub Class_Initialize()
Set Labels = New Dictionary
Set TextBoxs = New Dictionary
Set Buttons = New Dictionary
End Sub
'-----------------------------------
'クラスの廃棄時、イベントクラスのリストを廃棄します。
Private Sub Class_Terminate()
Call ObjectDelete
End Sub
C_TextBox
'-----------------------------------
'イベントクラス C_TextBox
'-----------------------------------
Option Explicit
'-----------------------------------
Private WithEvents myTextBox As Access.TextBox
Private myParent As C_Controls
Private myIndex As Long
'-----------------------------------
'
Public Property Set Item(ByRef Obj As Access.TextBox)
Set myTextBox = Obj
End Property
'-----------------------------------
'
Public Property Get Item() As Access.TextBox
Set Item = myTextBox
End Property
'-----------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'-----------------------------------
'
Public Property Let Index(ByVal Val As Long)
myIndex = Val
End Property
'-----------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'-----------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'-----------------------------------
'
Public Sub DEL()
Set myTextBox = Nothing
Set myParent = Nothing
End Sub
'-----------------------------------
'
Private Sub Class_Terminate()
Set myTextBox = Nothing
Set myParent = Nothing
End Sub
'-----------------------------------
'
Private Sub myTextBox_Change()
Call myParent.onChange(myTextBox)
End Sub
'-----------------------------------
'
Private Sub myTextBox_DblClick(Cancel As Integer)
Call myParent.onDblClick(myTextBox, Cancel)
End Sub
'-----------------------------------
'
Private Sub myTextBox_KeyPress(KeyAscii As Integer)
Call myParent.onKeyPress(myTextBox, KeyAscii)
End Sub
'-----------------------------------
'
Private Sub myTextBox_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myTextBox, Button, Shift, X, Y)
End Sub
C_Label
'-----------------------------------
'イベントクラス C_Label
'-----------------------------------
Option Explicit
'-----------------------------------
Private WithEvents myLabel As Access.Label
Private myParent As C_Controls
Private myIndex As Long
'-----------------------------------
'
Public Property Set Item(ByRef Obj As Access.Label)
Set myLabel = Obj
End Property
'-----------------------------------
'
Public Property Get Item() As Access.Label
Set Item = myLabel
End Property
'-----------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'-----------------------------------
'
Public Property Let Index(ByVal Val As Long)
myIndex = Val
End Property
'-----------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'-----------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'-----------------------------------
'
Public Sub DEL()
Set myLabel = Nothing
Set myParent = Nothing
End Sub
'-----------------------------------
'
Private Sub Class_Terminate()
Set myLabel = Nothing
Set myParent = Nothing
End Sub
'-----------------------------------
'
Private Sub myLabel_Click()
Call myParent.onClick(myLabel)
End Sub
'-----------------------------------
'
Private Sub myLabel_DblClick(Cancel As Integer)
Call myParent.onDblClick(myLabel, Cancel)
End Sub
'-----------------------------------
'
Private Sub myLabel_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myLabel, Button, Shift, X, Y)
End Sub
C_Button
'-----------------------------------
'イベントクラス C_Button
'-----------------------------------
Option Explicit
'-----------------------------------
Private WithEvents myButton As Access.CommandButton
Private myParent As C_Controls
Private myIndex As Long
'-----------------------------------
'
Public Property Set Item(ByRef Obj As Access.CommandButton)
Set myButton = Obj
End Property
'-----------------------------------
'
Public Property Get Item() As Access.CommandButton
Set Item = myButton
End Property
'-----------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'-----------------------------------
'
Public Property Let Index(ByVal Val As Long)
myIndex = Val
End Property
'-----------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'-----------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'-----------------------------------
'
Public Sub DEL()
Set myButton = Nothing
Set myParent = Nothing
End Sub
'-----------------------------------
'
Private Sub Class_Terminate()
Set myButton = Nothing
Set myParent = Nothing
End Sub
'-----------------------------------
'
Private Sub myButton_Click()
Call myParent.onClick(myButton)
End Sub
'-----------------------------------
'
Private Sub myButton_DblClick(Cancel As Integer)
Call myParent.onDblClick(myButton, Cancel)
End Sub
'-----------------------------------
'
Private Sub myButton_KeyDown(KeyCode As Integer, Shift As Integer)
Call myParent.onKeyDown(myButton, KeyCode, Shift)
End Sub
'-----------------------------------
'
Private Sub myButton_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myButton, Button, Shift, X, Y)
End Sub
C_Kyuzitu
令和4年11月16日投稿「VBA で作った休日クラス」にあります。
フォーム カレンダー
'-----------------------------------
'フォーム名を カレンダー とします。
'-----------------------------------
Option Compare Database
Option Explicit
Private WithEvents myControls As C_Controls
Private GetYobi As C_KyuZitu
Private Const SHIFT_MASK As Long = 1
Private Const FirstYobi As Long = vbSunday
Private HoldDate As Long
Private HoldYear As Long
Private HoldMonth As Long
Private HoldDay As Long
Private Enum IncType
Forward = 1
Backward = -1
End Enum
Private Const IntvDay As String = "d"
Private Const IntvMonth As String = "m"
Private Const IntvYear As String = "yyyy"
Private Const IntvWeek As String = "ww"
Private CurYear As Long
Private CurMonth As Long
Private CurDay As Long
Private DaysAndWeeks() As Long
Private Yobi As Variant
Private SelectDay As String
Public Property Get DateNum() As Long
If CurYear = 0 Then
DateNum = 0
Else
DateNum = DateSerial(CurYear, CurMonth, CurDay)
End If
End Property
Public Property Get WeekNum() As Long
GetYobi.SetNumDate = DateSerial(CurYear, CurMonth, CurDay)
WeekNum = GetYobi.WeekNum
End Property
'-----------------------------------
'
Private Sub Form_Load()
Dim Ctrl As Access.Control
Dim I As Long
If Nz(Me.OpenArgs, "") = "" Then
HoldDate = Date
Else
If IsDate(Me.OpenArgs) Then
HoldDate = DateSerial(DatePart("YYYY", Me.OpenArgs), _
DatePart("m", Me.OpenArgs), _
DatePart("d", Me.OpenArgs))
Else
HoldDate = Date
End If
End If
'カレンダーを開いたときの値を取得し、以後変更はありません。
HoldYear = Year(HoldDate)
HoldMonth = Month(HoldDate)
HoldDay = Day(HoldDate)
Set GetYobi = New C_KyuZitu
GetYobi.pYear = HoldYear
CurYear = HoldYear
CurMonth = HoldMonth
CurDay = HoldDay
Set myControls = New C_Controls
With myControls
Set .Parent = Me
.Init
End With
Yobi = Array("日", "月", "火", "水", "木", "金", "土")
For I = 0 To 6
Me("Y" & I).Caption = Yobi((FirstYobi - 1 + I) Mod 7)
Select Case I
Case 0
Me("Y" & I).ForeColor = vbRed
Case 6
Me("Y" & I).ForeColor = vbBlue
End Select
Next I
Call SetCurDisp
Call DispDraw
End Sub
'-----------------------------------
'
Private Sub Form_Close()
'参照を破棄します。
Set myControls = Nothing
Set GetYobi = Nothing
End Sub
'-----------------------------------
'
Private Sub SetCurDisp()
Me.DMONTH.Caption = CurMonth
Me.DYEAR.Caption = CurYear
End Sub
'-----------------------------------
'
Private Sub DispDraw()
Dim Ctrl As Access.Control
Dim NewSelect As String
Dim OneDayYobi As Long
Dim OneDaySerial As Long
Dim I As Long
GetYobi.pYear = CurYear
'選択月の最初の日のシリアル値
OneDaySerial = DateSerial(CurYear, CurMonth, 1)
'選択月の最初の日の曜日
OneDayYobi = Weekday(OneDaySerial, FirstYobi)
'配列にシリアル値をセット
ReDim DaysAndWeeks(0 To 41)
For I = 0 To UBound(DaysAndWeeks)
DaysAndWeeks(I) = OneDaySerial - (OneDayYobi - 1) + I
Next I
'ラベルのキャプションに日にちをセット
For I = 0 To UBound(DaysAndWeeks)
Me("Day" & I).Caption = Day(DaysAndWeeks(I))
If Me.DMONTH.Caption <> Month(DaysAndWeeks(I)) Then
Me("Day" & I).FontSize = 10
Else
Me("Day" & I).FontSize = 12
End If
If Me("Day" & I).ForeColor <> InteriorColor(DaysAndWeeks(I)) Then
Me("Day" & I).ForeColor = InteriorColor(DaysAndWeeks(I))
End If
If DaysAndWeeks(I) = DateSerial(CurYear, CurMonth, CurDay) Then
NewSelect = "Day" & I
End If
Next I
Call EffectDraw(NewSelect)
End Sub
'-----------------------------------
'
Private Sub EffectDraw(NewSelect As String)
If Len(SelectDay) > 0 Then
If SelectDay <> NewSelect Then
Me(SelectDay).SpecialEffect = acNormal
End If
End If
SelectDay = NewSelect
Me(SelectDay).SpecialEffect = acEffectSunken
Me.Repaint
End Sub
'-----------------------------------
'
Private Function InteriorColor(DrawDate As Long) As Long
GetYobi.SetNumDate = DrawDate
Select Case GetYobi.WeekNum
Case 1, 10, 11, 12, 13
InteriorColor = vbRed
Case 7
InteriorColor = vbBlue
Case Else
InteriorColor = vbBlack
End Select
End Function
'-----------------------------------
'
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Call ShiftKeys(KeyCode, Shift)
End Sub
'-----------------------------------
'
Private Sub myControls_Click(myCont As Object)
Select Case myCont.Name
Case "NM"
Me.buDummy.SetFocus
Call NextMonth
Case "NY"
Me.buDummy.SetFocus
Call NextYear
Case "PM"
Me.buDummy.SetFocus
Call PreviousMonth
Case "PY"
Me.buDummy.SetFocus
Call PreviousYear
Case "bu閉じる"
Me.buDummy.SetFocus
Call CloseForm(Hide:=False)
Case "bu初期"
Me.buDummy.SetFocus
CurYear = HoldYear
CurMonth = HoldMonth
CurDay = HoldDay
Call SetCurDisp
Call DispDraw
Case "bu削除"
Me.buDummy.SetFocus
CurYear = 0
Call CloseForm(Hide:=True)
Case Else
Select Case True
Case InStr(myCont.Name, "Day") = 1
If myCont.SpecialEffect = acEffectSunken Then
Call CloseForm(Hide:=True)
Else
If CurMonth <> Month(DaysAndWeeks(Mid(myCont.Name, Len("Day") + 1))) Then
Call ClickDate(myCont.Name)
Call SetCurDisp
Call DispDraw
Else
Call EffectDraw(myCont.Name)
Call ClickDate(myCont.Name)
End If
End If
End Select
End Select
End Sub
'-----------------------------------
'
Private Sub myControls_DblClick(myCont As Object, Cancel As Integer)
Select Case True
Case InStr(myCont.Name, "Day") = 1
Call EffectDraw(myCont.Name)
Call ClickDate(myCont.Name)
Call CloseForm(Hide:=True)
End Select
End Sub
'-----------------------------------
'
Private Sub myControls_KeyDown(myCont As Object, KeyCode As Integer, Shift As Integer)
Select Case myCont.Name
Case "PM", "NM", "PY", "NY", "bu閉じる", "bu初期", "bu削除"
Call ShiftKeys(KeyCode, Shift)
Case Else
Select Case True
Case InStr(myCont.Name, "Day") = 1
Call ShiftKeys(KeyCode, Shift)
End Select
End Select
End Sub
'-----------------------------------
'
Private Sub ShiftKeys(KeyCode As Integer, Shift As Integer)
Dim ShiftDown As Boolean
ShiftDown = ((Shift And SHIFT_MASK) > 0)
Select Case KeyCode
Case vbKeyEscape
Call CloseForm(Hide:=False)
Case vbKeyReturn
Call CloseForm(Hide:=True)
Case vbKeyHome
If ShiftDown Then
Call MoveToToday(UseCurYear:=False)
Else
Call MoveToToday(UseCurYear:=True)
End If
Case vbKeyPageUp
If ShiftDown Then
Call PreviousYear
Else
Call PreviousMonth
End If
Case vbKeyPageDown
If ShiftDown Then
Call NextYear
Else
Call NextMonth
End If
Case vbKeyRight
If ShiftDown Then
Call NextYear
Else
Call NextDay
End If
Case vbKeyLeft
If ShiftDown Then
Call PreviousYear
Else
Call PreviousDay
End If
Case vbKeyUp
If ShiftDown Then
Call PreviousMonth
Else
Call PreviousWeek
End If
Case vbKeyDown
If ShiftDown Then
Call NextMonth
Else
Call NextWeek
End If
End Select
KeyCode = 0
End Sub
'-----------------------------------
'
Public Sub Today()
Call MoveToToday(UseCurYear:=True)
End Sub
'-----------------------------------
'
Public Sub NextDay()
'1日進めます。
Call ChangeDate(IntvDay, IncType.Forward)
End Sub
'-----------------------------------
'
Public Sub NextMonth()
'1月進めます。
Call ChangeDate(IntvMonth, IncType.Forward)
End Sub
'-----------------------------------
'
Public Sub NextYear()
'1年進めます。
Call ChangeDate(IntvYear, IncType.Forward)
End Sub
'-----------------------------------
'
Public Sub NextWeek()
'1週進めます。
Call ChangeDate(IntvWeek, IncType.Forward)
End Sub
'-----------------------------------
'
Public Sub PreviousDay()
'1日戻ります。
Call ChangeDate(IntvDay, IncType.Backward)
End Sub
'-----------------------------------
'
Public Sub PreviousMonth()
'1月戻ります。
Call ChangeDate(IntvMonth, IncType.Backward)
End Sub
'-----------------------------------
'
Public Sub PreviousYear()
'1年戻ります。
Call ChangeDate(IntvYear, IncType.Backward)
End Sub
'-----------------------------------
'
Public Sub PreviousWeek()
'1週戻ります。
Call ChangeDate(IntvWeek, IncType.Backward)
End Sub
'-----------------------------------
'
Private Sub MoveToToday(UseCurYear As Boolean)
If UseCurYear Then
CurYear = HoldYear
End If
CurMonth = HoldMonth
CurDay = HoldDay
Call SetCurDisp
Call DispDraw
End Sub
'-----------------------------------
'
Private Sub ChangeDate(IntvStr As String, IT As IncType)
Dim bufMonth As Integer
Dim bufYear As Integer
Dim bufDay As Integer
Dim NewSelect As String
Dim OLDDate As Long
Dim NewDate As Long
Dim Inc As Long
Dim I As Long
If IT = Forward Then
Inc = 1
Else
Inc = -1
End If
OLDDate = DateSerial(CurYear, CurMonth, CurDay)
NewDate = DateAdd(IntvStr, Inc, OLDDate)
bufMonth = DatePart(IntvMonth, NewDate)
bufYear = DatePart(IntvYear, NewDate)
bufDay = DatePart(IntvDay, NewDate)
If CurMonth = bufMonth And _
CurYear = bufYear Then
CurDay = bufDay
For I = 0 To UBound(DaysAndWeeks)
If DaysAndWeeks(I) = DateSerial(CurYear, CurMonth, CurDay) Then
NewSelect = "Day" & I
End If
Next I
Call EffectDraw(NewSelect)
Else
CurDay = bufDay
CurMonth = bufMonth
CurYear = bufYear
Call SetCurDisp
Call DispDraw
End If
End Sub
'-----------------------------------
'
Private Sub CloseForm(Hide As Boolean)
'サブフォームになっているときの処理
If ThisFormSub() Then
Exit Sub
End If
If Hide Then
Me.Visible = False
Else
DoCmd.Close acForm, Me.Name, acSaveNo
End If
End Sub
'-----------------------------------
'サブフォームになっているかの確認
Private Function ThisFormSub() As Boolean
Dim strName As String
On Error Resume Next
strName = Me.Parent.Name
ThisFormSub = (Err.Number = 0)
Err.Clear
End Function
'-----------------------------------
'
Private Sub ClickDate(ClickName As String)
Dim Num As Long
Num = Mid(ClickName, Len("Day") + 1)
CurYear = Year(DaysAndWeeks(Num))
CurMonth = Month(DaysAndWeeks(Num))
CurDay = Day(DaysAndWeeks(Num))
End Sub
呼び出すコントロールのCODE
Private Sub コントロール名_DblClick(Cancel As Integer)
Dim UF As Access.Form
'コントロールの値を初期表示するようにしています。
DoCmd.OpenForm "カレンダー", WindowMode:=acDialog, OpenArgs:=Me.コントロール名.Value
For Each UF In Forms
If UF.Name = "カレンダー" Then
If UF.DateNum = 0 Then
'削除ボタンが押されたので、コントロールを空にします。
Me.コントロール名.Value = ""
Else
'和暦で値をセットします。
Me.コントロール名.Value = Format(UF.DateNum, "ggge年m月d日")
End If
'値を取得したので開いているフォームを閉じます。
DoCmd.Close acForm, "カレンダー", acSaveNo
End If
Next UF
End Sub