EXCELのC_Label、ACCESSと仕様が異なります
'-------------------------------------------------------------------
Private WithEvents myLabel As MSForms.Label
Private myParent As C_ObjControl
Private myIndex As Long
'-------------------------------------------------------------------
Private Sub Class_Terminate()
Set myLabel = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
Public Property Let Item(ByRef val As MSForms.Label)
Set myLabel = val
End Property
'--------------------------------------------------------------------
Public Property Get Item() As MSForms.Label
Set Item = myLabel
End Property
'--------------------------------------------------------------------
Public Property Let Parent(ByRef val As Object)
Set myParent = val
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
'--------------------------------------------------------------------
Private Sub myLabel_Click()
Call myParent.onClick(myIndex)
End Sub
'--------------------------------------------------------------------
Private Sub myLabel_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = True
Call myParent.onDblClick(myIndex)
End Sub
'--------------------------------------------------------------------
Private Sub myLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call myParent.onMouseMove(myIndex)
End Sub
プリントプレビューをフォームに表示
Option Explicit
'*******************************************************************
Private Type Posi
Top As Double
Left As Double
End Type
Public Event Click(ByVal Index As Long)
Public Event DblClick(ByVal Index As Long)
Public Event MouseMove(ByVal Index As Long)
Private Obj() As C_Label
Private DefPosi() As Posi
Private myItems As Object
Private myParent As Object
Private AllRows As Long
Private AllColumns As Long
Private AllTop As Double
Private AllLeft As Double
Private HIntv As Double
Private VIntv As Double
Private LabCount As Long
Private Size As Long
Private PHeight As Double
Private PWidth As Double
Private offrow As Double
Private offcol As Double
'*******************************************************************
Public Property Let Parent(ByRef val As Object)
Set myParent = val
End Property
'--------------------------------------------------------------------
Public Property Get Items() As Object
Set Items = myItems
End Property
'--------------------------------------------------------------------
Public Property Let Rows(ByVal val As Long)
AllRows = val
AllColumns = 0
End Property
'--------------------------------------------------------------------
Public Property Let Columns(ByVal val As Long)
AllColumns = val
AllRows = 0
End Property
'--------------------------------------------------------------------
Public Property Let Top(ByVal val As Double)
AllTop = val
End Property
'--------------------------------------------------------------------
Public Property Let Count(ByVal val As Double)
LabCount = val
End Property
'--------------------------------------------------------------------
Public Property Let Left(ByVal val As Double)
AllLeft = val
End Property
'--------------------------------------------------------------------
Public Property Let HoriIntv(ByVal val As Double)
HIntv = val
End Property
'--------------------------------------------------------------------
Public Property Let VertIntv(ByVal val As Double)
VIntv = val
End Property
'--------------------------------------------------------------------
Public Property Let Height(ByVal val As Double)
PHeight = val
End Property
'--------------------------------------------------------------------
Public Property Get Height() As Double
Height = PHeight
End Property
'--------------------------------------------------------------------
Public Property Let Width(ByVal val As Double)
PWidth = val
End Property
'--------------------------------------------------------------------
Public Property Get Width() As Double
Width = PWidth
End Property
'--------------------------------------------------------------------
Public Property Let FontSize(ByVal val As Long)
Size = val
End Property
'--------------------------------------------------------------------
Private Sub Class_Initialize()
AllRows = 0
AllColumns = 0
AllTop = 0
AllLeft = 0
HIntv = 0
VIntv = 0
PHeight = 0
PWidth = 0
LabCount = 0
Size = 10
End Sub
'--------------------------------------------------------------------
Private Sub Class_Terminate()
Dim I As Long
For I = 1 To UBound(Obj)
Set Obj(I) = Nothing
Next I
Set myParent = Nothing
Set myItems = Nothing
End Sub
'--------------------------------------------------------------------
Public Sub onClick(ByVal Index As Long)
RaiseEvent Click(Index)
End Sub
'--------------------------------------------------------------------
Public Sub onDblClick(ByVal Index As Long)
RaiseEvent DblClick(Index)
End Sub
'--------------------------------------------------------------------
Public Sub onMouseMove(ByVal Index As Long)
RaiseEvent MouseMove(Index)
End Sub
'--------------------------------------------------------------------
Public Sub Init(ByRef Dic As Object)
Dim Ctrl As Control
Dim I As Long
Dim Key As Variant
If Dic.Count > 0 Then
LabCount = Dic.Count
End If
If LabCount = 0 Then
Exit Sub
End If
Set myItems = New Collection
ReDim Obj(1 To Dic.Count)
ReDim DefPosi(1 To Dic.Count)
With myParent
I = 1
'-----
For Each Key In Dic.keys
'-----コントロールの追加
Set Ctrl = .Controls.Add("Forms.Label.1", Dic(Key))
'-----コントロールの整形
With Ctrl
.Visible = True
'.Enabled = False
.Caption = Dic(Key)
If AllRows > 0 Then
.Top = AllTop + ((I - 1) Mod AllRows) * (PHeight + VIntv)
.Left = AllLeft + ((I - 1) \ AllRows) * (PWidth + HIntv)
End If
If AllColumns > 0 Then
.Top = AllTop + ((I - 1) \ AllColumns) * (PHeight + VIntv)
.Left = AllLeft + ((I - 1) Mod AllColumns) * (PWidth + HIntv)
End If
.Font.Size = Size
.Height = PHeight
.Width = PWidth
.SpecialEffect = fmSpecialEffectRaised
DefPosi(I).Top = .Top
DefPosi(I).Left = .Left
End With
'-----コントロールのイベントクラスの作成
Set Obj(I) = New C_Label
With Obj(I)
.Item = Ctrl
.Index = Key
.Parent = Me
End With
myItems.Add Obj(I)
I = I + 1
Next Key
End With
End Sub
'*******************************************************************
Public Sub OffSet(ByVal offtop As Double, _
ByVal offleft As Double)
Dim I As Long
For I = 1 To UBound(Obj)
With Obj(I).Item
.Top = DefPosi(I).Top + offtop
.Left = DefPosi(I).Left + offleft
End With
Next I
End Sub
フォームの値をテーブルにセット
Option Compare Database
Private Sub buクリア_Click()
Call CtrlClear
End Sub
Private Sub bu移動_Click()
Me.SUB1.SetFocus
DoCmd.GoToRecord , , acNewRec
Me.SUB1.Form.SelHeight = 1
Call CtrlClear
Me.ID.Value = "新規"
End Sub
Private Sub bu検索_Click()
Dim whereSQL As String
For Each Ctrl In Me.Controls
If TypeName(Ctrl) = "TextBox" Then
If Ctrl.Value <> "" Then
If whereSQL = "" Then
whereSQL = " A.[" & Ctrl.Name & "] Like '*" & Ctrl & "*'"
Else
whereSQL = whereSQL & " AND A.[" & Ctrl.Name & "] Like '*" & Ctrl & "*'"
End If
End If
End If
Next Ctrl
Me.SUB1.Form.RecordSource = "SELECT * FROM 連絡先 AS A WHERE" & whereSQL & ";"
End Sub
Private Sub bu更新_Click()
Dim tableSQL As String
Dim valueSQL As String
Dim mySQL As String
Dim Ctrl As Access.Control
Dim I As Long
If Nz(Me.ID, "") = "" Then
Exit Sub
End If
If Me.ID = "新規" Then
Call ADDNEW
Exit Sub
'追加
For Each Ctrl In Me.Controls
If TypeName(Ctrl) = "TextBox" Then
Select Case Ctrl.Name
Case "ID", "添付ファイル"
Case Else
If tableSQL = "" Then
tableSQL = Ctrl.Name
valueSQL = "'" & Ctrl.Value & "'"
Else
tableSQL = tableSQL & ", " & Ctrl.Name
valueSQL = valueSQL & ", '" & Ctrl.Value & "'"
End If
End Select
End If
Next Ctrl
mySQL = "INSERT INTO 連絡先(" & tableSQL & ") VALUES(" & valueSQL & ");"
DoCmd.RunSQL mySQL
Me.SUB1.Requery
Me.ID.Value = DMax("ID", "連絡先")
Else
Call UPDATE
Exit Sub
'更新
For Each Ctrl In Me.Controls
If TypeName(Ctrl) = "TextBox" Then
Select Case Ctrl.Name
Case "ID", "添付ファイル"
Case Else
If tableSQL = "" Then
tableSQL = Ctrl.Name & "='" & Ctrl.Value & "'"
Else
tableSQL = tableSQL & ", " & Ctrl.Name & "='" & Ctrl.Value & "'"
End If
End Select
End If
Next Ctrl
mySQL = "UPDATE 連絡先 SET " & tableSQL & "WHERE 連絡先.[ID]=" & Me.ID & ";"
DoCmd.RunSQL mySQL
Me.SUB1.Requery
End If
End Sub
Private Sub bu閉じる_Click()
DoCmd.Close acForm, Me.Name, acSaveNo
End Sub
Private Sub Form_Load()
Me.SUB1.SourceObject = "検索SUB"
Me.SUB1.Form.RecordSource = "SELECT * FROM 連絡先;"
End Sub
Private Sub CtrlClear()
Dim Ctrl As Access.Control
For Each Ctrl In Me.Controls
If TypeName(Ctrl) = "TextBox" Then
Ctrl.Value = ""
End If
Next Ctrl
End Sub
Private Sub UPDATE()
Dim CN As ADODB.Connection
Dim RS As New ADODB.Recordset
Dim Ctrl As Access.Control
Set CN = CurrentProject.Connection
RS.Open "連絡先", CN, adOpenKeyset, adLockOptimistic, adCmdTableDirect
Let RS.Index = "Ind"
RS.Seek Me.ID, adSeekFirstEQ
For Each Ctrl In Me.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
Select Case Ctrl.Name
Case "ID"
Case Else
RS.Fields(Ctrl.Name) = Ctrl.Value
End Select
Case "Attachment"
End If
Next Ctrl
RS.UPDATE
RS.Close
Set RS = Nothing
CN.Close
Set CN = Nothing
Me.SUB1.Requery
End Sub
Private Sub ADDNEW()
Dim CN As ADODB.Connection
Dim RS As New ADODB.Recordset
Dim Ctrl As Access.Control
Set Con = CurrentProject.Connection
Set Rst = New ADODB.Recordset
Rst.Open "連絡先", Con, adOpenForwardOnly, adLockPessimistic
With Rst
.ADDNEW
For Each Ctrl In Me.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
Select Case Ctrl.Name
Case "ID"
Case Else
RS.Fields(Ctrl.Name) = Ctrl.Value
End Select
Case "Attachment"
End If
Next Ctrl
.UPDATE
End With
Rst.Close
Set Rst = Nothing
Set Con = Nothing
Me.SUB1.Requery
Me.ID.Value = DMax("ID", "連絡先")
End Sub
Private Sub クリア2()
Call ClearControls
End Sub
Private Sub 閉じる2()
DoCmd.Close acForm, "住所録", acSaveNo
End Sub
Sub ClearControls()
Dim Ctl As Control
For Each Ctl In Me.Controls
If Ctl.ControlType = acTextBox Then
Ctl = Null
End If
Next Ctl
End Sub
Private Sub cmd追加2()
'[追加]ボタンクリック時
'フォームのレコードセットの編集を開始
Me.Recordset.Edit
'商品写真フィールドのレコードセットに対する操作
With Me.Recordset!商品写真.Value
.ADDNEW
!FileData.LoadFromFile "c:\Picture\img17.jpg"
.UPDATE
.Close
End With
'添付ファイルコントロールの表示を更新
Me!商品写真.Requery
End Sub
サブフォームのセレクタをクリックして親フォームにレコードの値をセット
Option Compare Database
Private Sub Form_Click()
Dim Ctrl As Access.Control
If Me.SelHeight > 0 Then
For Each Ctrl In Me.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
If Ctrl.Name = "ID" Then
If Nz(Ctrl.Value, "") = "" Then
'Me.Parent.Controls(Ctrl.Name).Value = DMax(Ctrl.Name, "連絡先") + 1
Me.Parent.Controls(Ctrl.Name).Value = "新規"
Else
Me.Parent.Controls(Ctrl.Name).Value = Ctrl.Value
End If
Else
Me.Parent.Controls(Ctrl.Name).Value = Ctrl.Value
End If
End Select
Next Ctrl
End If
End Sub
Access カレンダーFORM
'----------------------------------------------------------------
'カレンダー
'令和３年５月６日
'----------------------------------------------------------------
Option Compare Database
Option Explicit
Private WithEvents myControls As C_Controls
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 GetYobi As C_KyuZitu
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()
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(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(True)
Case Else
Select Case True
Case InStr(myCont.Name, "Day") = 1
If myCont.SpecialEffect = acEffectSunken Then
Call CloseForm(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(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(False)
Else
Call MoveToToday(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()
Call ChangeDate(IntvDay, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextMonth()
Call ChangeDate(IntvMonth, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextYear()
Call ChangeDate(IntvYear, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextWeek()
Call ChangeDate(IntvWeek, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousDay()
Call ChangeDate(IntvDay, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousMonth()
Call ChangeDate(IntvMonth, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousYear()
Call ChangeDate(IntvYear, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousWeek()
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
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_CheckBox
Option Explicit
'-------------------------------------------------------------------
Private WithEvents myCheckBox As Access.CheckBox
Private myParent As C_Controls
Private myIndex As Long'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CheckBox)
Set myCheckBox = Obj
End Property'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CheckBox
Set Item = myCheckBox
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 myCheckBox = Nothing
Set myParent = Nothing
End Sub'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
Set myCheckBox = Nothing
Set myParent = Nothing
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_Click()
Call myParent.onClick(myCheckBox)
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_DblClick(Cancel As Integer)
Call myParent.onDblClick(myCheckBox, Cancel)
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myCheckBox, Button, Shift, X, Y)
End Sub
C_ComboBox
Option Explicit
'-------------------------------------------------------------------
Private WithEvents myCheckBox As Access.CheckBox
Private myParent As C_Controls
Private myIndex As Long'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CheckBox)
Set myCheckBox = Obj
End Property'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CheckBox
Set Item = myCheckBox
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 myCheckBox = Nothing
Set myParent = Nothing
End Sub'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
Set myCheckBox = Nothing
Set myParent = Nothing
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_Click()
Call myParent.onClick(myCheckBox)
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_DblClick(Cancel As Integer)
Call myParent.onDblClick(myCheckBox, Cancel)
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myCheckBox, Button, Shift, X, Y)
End Sub
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 CheckBoxs As Dictionary
Private ComboBoxs As Dictionary
Private Buttons As Dictionary
Private myParent As Object
'*******************************************************************
'
Public Property Set Parent(ByRef Obj As Object)
Set myParent = Obj
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
Set Labels = New Dictionary
Set TextBoxs = New Dictionary
Set CheckBoxs = New Dictionary
Set ComboBoxs = New Dictionary
Set Buttons = New Dictionary
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 "ComboBox"
With New C_ComboBox
Set .Item = Ctrl
Set .Parent = Me
ComboBoxs.Add Ctrl.Name, .Self
End With
Case "CheckBox"
With New C_CheckBox
Set .Item = Ctrl
Set .Parent = Me
CheckBoxs.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
'*******************************************************************
'
Public Sub DEL()
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 ComboBoxs
ComboBoxs(Keys).DEL
Next Keys
Set ComboBoxs = Nothing
For Each Keys In CheckBoxs
CheckBoxs(Keys).DEL
Next Keys
Set CheckBoxs = Nothing
For Each Keys In Buttons
Buttons(Keys).DEL
Next Keys
Set Buttons = Nothing
Set myParent = Nothing
End Sub
C_TextBox
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_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_Kyuzituクラス
Option Compare Database
Option Explicit
Private Enum YobiType
Shuku = 10
Kokumin = 11
Hurikae = 12
Kanrei = 13
End Enum
Private memShukuzitu As Dictionary
Private memKokumin As Dictionary
Private memHurikae As Dictionary
Private memKanrei As Dictionary
Private memYear As Long
Private memMonth As Long
Private memDay As Long
Private memFormat As String
Public Property Let pYear(val As Long)
Call KyuzituSet(val)
End Property
Public Property Get pYear() As Long
pYear = memYear
End Property
Public Property Let SetStrDate(val As String)
If IsDate(val) Then
Call KyuzituSet(CLng(DatePart("yyyy", val)))
memMonth = CLng(DatePart("m", val))
memDay = CLng(DatePart("d", val))
Else
Call KyuzituSet(1900)
memMonth = 1
memDay = 1
End If
End Property
Public Property Let SetNumDate(val As Long)
Call KyuzituSet(Year(val))
memMonth = Month(val)
memDay = Day(val)
End Property
Public Property Let FormatFormat(val As String)
memFormat = val
End Property
Public Property Get GetStrDate() As String
GetStrDate = Format(DateSerial(memYear, memMonth, memDay), memFormat)
End Property
Public Property Get WeekNum() As Long
WeekNum = Yobi
End Property
Public Property Get DateNum() As Long
DateNum = DateSerial(memYear, memMonth, memDay)
End Property
Private Sub Class_Initialize()
Call KyuzituSet(Year(Date))
memMonth = Month(Date)
memDay = Day(Date)
End Sub
Private Sub Class_Terminate()
Set memShukuzitu = Nothing
Set memKokumin = Nothing
Set memHurikae = Nothing
Set memKanrei = Nothing
End Sub
Private Function Yobi() As Long
If memShukuzitu.Exists(DateNum) Then
Yobi = YobiType.Shuku
Exit Function
End If
If memKokumin.Exists(DateNum) Then
Yobi = YobiType.Kokumin
Exit Function
End If
If memHurikae.Exists(DateNum) Then
Yobi = YobiType.Kanrei
Exit Function
End If
If memKanrei.Exists(DateNum) Then
Yobi = YobiType.Kanrei
Exit Function
End If
Yobi = Weekday(DateNum, vbSunday)
End Function
'---------------------------------------
Private Sub KyuzituSet(NewYear As Long)
If memYear <> NewYear Then
memYear = NewYear
Call makeShukuzitu
Call makeKokumin
Call makeHurikae
Call makeKanrei
End If
End Sub
'---------------------------------------ロング値で与えられた日付の休日判定を行ないます。
Private Sub makeShukuzitu()
Dim iDay As Long
Set memShukuzitu = Nothing
Set memShukuzitu = New Dictionary
'----------元日
If DateSerial(memYear, 1, 1) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 1, 1), "元旦"
End If
'----------成人の日 １月１５日 → １月の第２月曜
If memYear > 1949 And memYear < 2000 Then
memShukuzitu.Add DateSerial(memYear, 1, 15), "成人の日"
ElseIf memYear > 1999 Then
memShukuzitu.Add DateSerial(memYear, 1, 14) - Weekday(DateSerial(memYear, 1, 14), vbTuesday), "成人の日"
End If
'----------建国記念の日
If DateSerial(memYear, 2, 11) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 2, 11), "建国記念の日"
End If
'----------天皇誕生日
If memYear > 2019 Then
memShukuzitu.Add DateSerial(memYear, 2, 23), "天皇誕生日"
End If
'----------春分の日
'int(19.8277+0.242194*(年-1980)-int((年-1983)/4)) ----------1851-1899年通用
'int(20.8357+0.242194*(年-1980)-int((年-1983)/4)) ----------1900-1979年通用
'int(20.8431+0.242194*(年-1980)-int((年-1980)/4)) ----------1980-2099年通用
'int(21.8510+0.242194*(年-1980)-int((年-1980)/4)) ----------2100-2150年通用
Select Case memYear
Case Is < 2100
iDay = Int(20.8431 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
Case Is >= 2100
iDay = Int(20.851 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
End Select
If DateSerial(memYear, 3, iDay) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 3, iDay), "春分の日"
End If
'----------天皇誕生日→みどりの日→昭和の日
If DateSerial(memYear, 4, 29) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 4, 29), "昭和の日"
End If
'----------即位の礼
If memYear = 2019 Then
memShukuzitu.Add DateSerial(memYear, 5, 1), "即位の礼"
End If
'----------憲法記念日
If DateSerial(memYear, 5, 3) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 5, 3), "憲法記念日"
End If
'----------みどりの日
If memYear > 2006 Then
memShukuzitu.Add DateSerial(memYear, 5, 4), "みどりの日"
End If
'----------こどもの日
If DateSerial(memYear, 5, 5) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 5, 5), "こどもの日"
End If
'----------海の日 ７月２０日 → ７月の第３月曜日
If memYear > 1995 And memYear < 2003 Then
memShukuzitu.Add DateSerial(memYear, 7, 20), "海の日"
ElseIf memYear > 2002 Then
If memYear = 2020 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 23), "海の日"
ElseIf memYear = 2021 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 22), "海の日"
Else
memShukuzitu.Add DateSerial(memYear, 7, 21) - Weekday(DateSerial(memYear, 7, 21), vbTuesday), "海の日"
End If
End If
'----------山の日"
If memYear > 2015 Then
If memYear = 2020 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 8, 10), "山の日"
ElseIf memYear = 2021 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 8, 8), "山の日"
Else
memShukuzitu.Add DateSerial(memYear, 8, 11), "山の日"
End If
End If
'----------敬老の日 ９月１５日 → ９月の第３月曜日
If memYear > 1965 And memYear < 2003 Then
memShukuzitu.Add DateSerial(memYear, 9, 15), "敬老の日"
ElseIf memYear > 2002 Then
memShukuzitu.Add DateSerial(memYear, 9, 21) - Weekday(DateSerial(memYear, 9, 21), vbTuesday), "敬老の日"
End If
'----------秋分の日
'int(22.2588+0.242194*(年-1980)-int((年-1983)/4)) ----------1851-1899年通用
'int(23.2588+0.242194*(年-1980)-int((年-1983)/4)) ----------1900-1979年通用
'int(23.2488+0.242194*(年-1980)-int((年-1980)/4)) ----------1980-2099年通用
'int(24.2488+0.242194*(年-1980)-int((年-1980)/4)) ----------2100-2150年通用
Select Case memYear
Case Is < 2100
iDay = Int(23.2488 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
Case Is >= 2100
iDay = Int(24.2488 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
End Select
If DateSerial(memYear, 9, iDay) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 9, iDay), "秋分の日"
End If
'----------体育の日 → スポーツの日 １０月１０日 → １０月の第二月曜日
If memYear > 1965 And memYear < 2000 Then
memShukuzitu.Add DateSerial(memYear, 10, 10), "体育の日"
ElseIf memYear > 1999 Then
If memYear = 2020 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 24), "スポーツの日"
ElseIf memYear = 2021 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 23), "スポーツの日"
Else
memShukuzitu.Add DateSerial(memYear, 10, 14) - Weekday(DateSerial(memYear, 10, 14), vbTuesday), "スポーツの日"
End If
End If
'----------即位礼正殿の儀
If memYear = 2019 Then
memShukuzitu.Add DateSerial(memYear, 10, 22), "即位礼正殿の儀"
End If
'----------文化の日
If DateSerial(memYear, 11, 3) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 11, 3), "文化の日"
End If
'----------勤労感謝の日
If DateSerial(memYear, 11, 23) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 11, 23), "勤労感謝の日"
End If
'----------天皇誕生日
If memYear > 1988 And memYear < 2019 Then
memShukuzitu.Add DateSerial(memYear, 12, 23), "天皇誕生日"
End If
End Sub
Private Sub makeKokumin()
Dim D() As Long
Dim Keys As Variant
Dim iCount As Long
Dim I As Long
Dim J As Long
Dim Target As Long
If memShukuzitu.Count = 0 Then
Exit Sub
End If
If memYear < 1988 Then
Exit Sub
End If
Set memKokumin = Nothing
Set memKokumin = New Dictionary
'-------------------------------国民の休日の判定
ReDim D(memShukuzitu.Count - 1)
For Each Keys In memShukuzitu
D(iCount) = Keys
iCount = iCount + 1
Next
For I = 0 To UBound(D)
For J = 0 To UBound(D)
'-----------------------該当の組み合わせがある場合
If D(J) - D(I) = 2 Then
Target = (D(J) + D(I)) / 2
If Not memShukuzitu.Exists(Target) Then
memKokumin.Add Target, "休日"
End If
End If
Next J
Next I
End Sub
Private Sub makeHurikae()
Dim iDay As Long
Dim fDay As Long
Dim boHurikae As Boolean
If memShukuzitu.Count = 0 Then
Exit Sub
End If
If memYear < 1973 Then
Exit Sub
End If
Set memHurikae = Nothing
Set memHurikae = New Dictionary
For iDay = DateSerial(memYear, 1, 1) To DateSerial(memYear, 12, 31)
'---------------------------日曜日であること
If Weekday(iDay) = 1 Then
'-------------------祝日であること
If memShukuzitu.Exists(iDay) Then
boHurikae = True
fDay = iDay
End If
End If
'---------------------------フラッグを立てた後、最初の祝日でない日を振替日とする
If boHurikae = True Then
If iDay > fDay Then
'-------------------祝休日に該当しない場合、振替日にする
If Not memShukuzitu.Exists(iDay) Then
memHurikae.Add iDay, "振替"
boHurikae = False
End If
End If
End If
Next iDay
End Sub
Private Sub makeKanrei()
Set memKanrei = Nothing
Set memKanrei = New Dictionary
'-----------------------------------慣例になっている休日
With memKanrei
.Add DateSerial(memYear, 1, 1), "慣例"
.Add DateSerial(memYear, 1, 2), "慣例"
.Add DateSerial(memYear, 1, 3), "慣例"
.Add DateSerial(memYear, 12, 31), "慣例"
End With
End Sub