COPY
Option Compare Database
Option Explicit
'----------------------------------------------------------------
Private NenTuki() As String
Private Fname As Dictionary
Private ViewPosi As Long
Private ShiftPosi As Long
Private memSQL As String
Private memTableSQL As String 'SUBフォームがセットして年シフト時使用
Private memOrderSQL As String 'SUBフォームがセットして年シフト時使用
Private memClickLabel As String
'----------------------------------------------------------------
Public Property Get mySQL() As String
mySQL = memSQL
End Property
'----------------------------------------------------------------
Public Property Let mySQL(ByVal val As String)
memSQL = val
End Property
'----------------------------------------------------------------
Public Property Get TableSQL() As String
TableSQL = memTableSQL
End Property
'----------------------------------------------------------------
Public Property Let TableSQL(ByVal val As String)
memTableSQL = val
End Property
'----------------------------------------------------------------
Public Property Get OrderSQL() As String
OrderSQL = memOrderSQL
End Property
'----------------------------------------------------------------
Public Property Let OrderSQL(ByVal val As String)
memOrderSQL = val
End Property
Public Property Get ClickLabel() As String
ClickLabel = memClickLabel
End Property
'----------------------------------------------------------------
Public Property Let ClickLabel(ByVal val As String)
memClickLabel = val
End Property
'----------------------------------------------------------------
Private Sub Form_Open(Cancel As Integer)
Dim EDate As Long
Dim SDate As Long
Dim I As Long
Me.車検点検予定表SUB.SourceObject = "車検点検予定表SUB"
ShiftPosi = 0
ViewPosi = 13
memTableSQL = ""
memOrderSQL = ""
'点検月名とフォームの表題の対照表の作成
Call FNameMake
Me.車検点検予定表SUB.Form.Painting = False
Call ListAdd
Call SubControl(True)
Me.車検点検予定表SUB.Form.Painting = True
End Sub
'----------------------------------------------------------------
Private Sub Form_Close()
Set Fname = Nothing
End Sub
'----------------------------------------------------------------
Private Sub エクセル_Click()
Dim Rst As Recordset
Dim Ws As Object
Dim xls As Object
Dim I As Long
Set Ws = CreateObject("Wscript.Shell")
'得意先テーブルを開く
Set Rst = Me.車検点検予定表SUB.Form.Recordset.Clone
'Excelオブジェクトを生成
Set xls = CreateObject("Excel.Application")
With xls
'新しいブックを追加
.Workbooks.Add
For I = 0 To Rst.Fields.Count - 1
.Cells(1, I + 1).Value = Fname(Rst.Fields(I).Name)
Next I
'2行目の1列目からレコードセットを出力
.Cells(2, 1).CopyFromRecordset Rst
Set Rst = Nothing
.Visible = True
End With
Set xls = Nothing
End Sub
'----------------------------------------------------------------
Private Sub シフト右_Click()
ShiftPosi = ShiftPosi + 1
'点検月名とフォームの表題の対照表の作成
Call FNameMake
Me.車検点検予定表SUB.Form.Painting = False
Call ListAdd
Call SubControl(True)
Me.車検点検予定表SUB.Form.Painting = True
End Sub
'----------------------------------------------------------------
Private Sub シフト左_Click()
ShiftPosi = ShiftPosi - 1
'点検月名とフォームの表題の対照表の作成
Call FNameMake
Me.車検点検予定表SUB.Form.Painting = False
Call ListAdd
Call SubControl(True)
Me.車検点検予定表SUB.Form.Painting = True
End Sub
'----------------------------------------------------------------
Private Sub 右_Click()
ViewPosi = ViewPosi + 1
Me.車検点検予定表SUB.Form.Painting = False
Call SubControl
Me.車検点検予定表SUB.Form.Painting = True
End Sub
'----------------------------------------------------------------
Private Sub 左_Click()
ViewPosi = ViewPosi - 1
Me.車検点検予定表SUB.Form.Painting = False
Call SubControl
Me.車検点検予定表SUB.Form.Painting = True
End Sub
'----------------------------------------------------------------
Private Sub 解除_Click()
Dim Ctrl As Access.Control
Me.車検点検予定表SUB.Form.Painting = False
For Each Ctrl In Me.車検点検予定表SUB.Form.Controls
If Ctrl.ControlType = acLabel Then
With Ctrl
Select Case True
Case InStr(.Caption, "_■") > 0
.Caption = Replace(.Caption, "_■", "")
Case InStr(.Caption, "_▲") > 0
.Caption = Replace(.Caption, "_▲", "")
Case InStr(.Caption, "_▼") > 0
.Caption = Replace(.Caption, "_▼", "")
End Select
End With
End If
Next Ctrl
ClickLabel = ""
TableSQL = ""
OrderSQL = ""
Me.車検点検予定表SUB.Form.RecordSource = mySQL & ";"
Me.車検点検予定表SUB.Form.Requery
Me.車検点検予定表SUB.Form.Painting = True
End Sub
'----------------------------------------------------------------
Private Sub ListAdd()
Dim Rs As DAO.Recordset
Dim Touroku As String
Dim TourokuDate As Long
Dim HaishaDate As Long
Dim BaseDate As Long
Dim ShokaiSpan As Long
Dim ShakenSpan As Long
Dim TenkenSpan As Long
Dim I As Long
Dim SetSQL As String
Set Rs = CurrentDb.OpenRecordset("車検証", dbOpenSnapshot)
If Rs.BOF Then
Set Rs = Nothing
Exit Sub
End If
Do Until Rs.EOF
'車検証（レコードセット）から値を取得
Touroku = Rs("登録番号")
TourokuDate = Rs("登録日")
HaishaDate = Nz(Rs("廃車日"), 999999)
BaseDate = Rs("有効期限")
ShokaiSpan = Rs("初回有効期間")
ShakenSpan = Rs("継続有効期間")
TenkenSpan = Rs("点検有効期間")
'テーブル車検点検listに追加
Call ListMake(Touroku, TourokuDate, HaishaDate, BaseDate, ShokaiSpan, ShakenSpan, TenkenSpan)
Rs.MoveNext
Loop
'レコードセットの参照破棄
Set Rs = Nothing
'フォームのデータSQLの作成
mySQL = "SELECT A.登録番号"
mySQL = mySQL & ", Max(A.ID) AS ID"
mySQL = mySQL & ", Max(A.登録日) AS 登録日"
mySQL = mySQL & ", Max(A.廃車日) AS 廃車日"
mySQL = mySQL & ", Max(A.有効期限) AS 有効期限"
For I = 1 To UBound(NenTuki)
mySQL = mySQL & ", Max(IIf(A.年月='" & NenTuki(I) & "',A.車検点検ID,Null)) AS " & "F" & I
Next I
mySQL = mySQL & " FROM 車検点検list AS A"
mySQL = mySQL & " GROUP BY A.登録番号"
If TableSQL <> "" Then
If OrderSQL <> "" Then
SetSQL = "SELECT X.* FROM (" & Replace(mySQL, "車検点検list", TableSQL) & ") AS X " & OrderSQL & ";"
Else
SetSQL = "SELECT X.* FROM (" & Replace(mySQL, "車検点検list", TableSQL) & ") AS X;"
End If
Else
SetSQL = mySQL & ";"
End If
Me.車検点検予定表SUB.Form.RecordSource = SetSQL
End Sub
'----------------------------------------------------------------
Private Sub 実行_Click()
Dim Rs As DAO.Recordset
Dim Touroku As String
Dim TourokuDate As Long
Dim HaishaDate As Long
Dim BaseDate As Long
Dim ShokaiSpan As Long
Dim ShakenSpan As Long
Dim TenkenSpan As Long
Dim EDate As Long
Dim SDate As Long
Dim I As Long
Dim Qdf As QueryDef
Dim mySQL As String
SDate = DateSerial(Year(Date) - 1, Month(Date), 1)
EDate = DateSerial(Year(Date) + 2, Month(Date), 0)
Set Rs = CurrentDb.OpenRecordset("車検証", dbOpenSnapshot)
If Rs.BOF Then
Set Rs = Nothing
Exit Sub
End If
'DoCmd.RunSQL "DELETE * FROM 車検点検list;"
Do Until Rs.EOF
'車検証（レコードセット）から値を取得
Touroku = Rs("登録番号")
TourokuDate = Rs("登録日")
HaishaDate = Nz(Rs("廃車日"), 999999)
BaseDate = Rs("有効期限")
ShokaiSpan = Rs("初回有効期間")
ShakenSpan = Rs("継続有効期間")
TenkenSpan = Rs("点検有効期間")
'テーブル車検点検listに追加
Call ListMake(Touroku, TourokuDate, BaseDate, HaishaDate, ShokaiSpan, ShakenSpan, TenkenSpan)
Rs.MoveNext
Loop
'レコードセットの参照破棄
Set Rs = Nothing
'点検月名とフォームの表題の対照表の作成
Set Fname = New Dictionary
Do Until DateSerial(Year(SDate), Month(SDate) + I, 1) > EDate
I = I + 1
ReDim Preserve NenTuki(I)
NenTuki(I) = StrConv(Format(DateSerial(Year(SDate), Month(SDate) + I - 1, 1), "geemm"), vbUpperCase)
Fname.Add "F" & I, NenTuki(I)
Loop
'フォームのデータSQLの作成
memSQL = "SELECT A.登録番号"
memSQL = memSQL & ", Max(A.登録日) AS 登録日"
memSQL = memSQL & ", Max(A.廃車日) AS 廃車日"
memSQL = memSQL & ", Max(A.有効期限) AS 有効期限"""
For I = 1 To UBound(NenTuki)
memSQL = memSQL & ", Max(IIf(A.年月='" & NenTuki(I) & "', A.車検点検ID, Null)) AS " & "F" & I
Next I
memSQL = memSQL & " FROM 車検点検list AS A"
memSQL = memSQL & " GROUP BY A.登録番号"
'クエリの作成
Set Qdf = CurrentDb.CreateQueryDef("Q_一覧表", mySQL & ";")
Set Qdf = Nothing
End Sub
'----------------------------------------------------------------
Private Sub ListMake(ByVal Touroku As String, _
ByVal TourokuDate As Long, _
ByVal HaishaDate As Long, _
ByVal BaseDate As Long, _
ByVal ShokaiSpan As Long, _
ByVal ShakenSpan As Long, _
ByVal TenkenSpan As Long)
Dim ShuseiDate As Long
Dim BUF As Long
Dim I As Long
Dim NenTuki As String
Dim ShaID As String
Dim FLG As String
Dim bufSQL As String
ShuseiDate = BaseDate + 1
For I = -(6 + Abs(ShiftPosi)) To (6 + Abs(ShiftPosi))
BUF = DateSerial(Year(ShuseiDate), Month(ShuseiDate) + TenkenSpan * I, Day(ShuseiDate)) - 1
If BUF <= TourokuDate Then
'登録日以前に車検・点検はない
NenTuki = StrConv(Format(TourokuDate, "geemm"), vbUpperCase)
ShaID = "登_" & Format(TourokuDate, "eemmdd") & "_" & Touroku
FLG = "登"
BUF = TourokuDate
ElseIf BUF >= HaishaDate Then
'廃車日以降に車検・点検はない
NenTuki = StrConv(Format(HaishaDate, "geemm"), vbUpperCase)
ShaID = "廃_" & Format(HaishaDate, "eemmdd") & "_" & Touroku
FLG = "廃"
BUF = HaishaDate
Else
If BUF < DateSerial(Year(TourokuDate), Month(TourokuDate) + ShokaiSpan, Day(TourokuDate)) - 1 Then
'初回有効期限内に車検はないが、有効期限であるばあい車検とする
If I = 0 Then
NenTuki = StrConv(Format(BUF, "geemm"), vbUpperCase)
ShaID = "検_" & Format(BUF, "eemmdd") & "_" & Touroku
FLG = "検"
Else
NenTuki = StrConv(Format(BUF, "geemm"), vbUpperCase)
ShaID = "点_" & Format(BUF, "eemmdd") & "_" & Touroku
FLG = "点"
End If
Else
If I = 0 Then
'有効期限は車検
NenTuki = StrConv(Format(BUF, "geemm"), vbUpperCase)
ShaID = "検_" & Format(BUF, "eemmdd") & "_" & Touroku
FLG = "検"
Else
If (TenkenSpan * I) Mod ShakenSpan = 0 Then
'車検と点検が重なる場合は車検
NenTuki = StrConv(Format(BUF, "geemm"), vbUpperCase)
ShaID = "検_" & Format(BUF, "eemmdd") & "_" & Touroku
FLG = "検"
Else
'重ならない場合は点検
NenTuki = StrConv(Format(BUF, "geemm"), vbUpperCase)
ShaID = "点_" & Format(BUF, "eemmdd") & "_" & Touroku
FLG = "点"
End If
End If
End If
End If
If DCount("車検点検ID", "車検点検list", "車検点検ID='" & ShaID & "'") = 0 Then
'追加クエリの作成
bufSQL = "INSERT INTO 車検点検list"
bufSQL = bufSQL & " (年月日,"
bufSQL = bufSQL & " 登録日,"
bufSQL = bufSQL & " 廃車日,"
bufSQL = bufSQL & " 有効期限,"
bufSQL = bufSQL & " 年月,"
bufSQL = bufSQL & " 登録番号,"
bufSQL = bufSQL & " 車検点検ID,"
bufSQL = bufSQL & " 車検点検別)"
bufSQL = bufSQL & " VALUES "
bufSQL = bufSQL & " (" & BUF & ","
bufSQL = bufSQL & " " & TourokuDate & ","
bufSQL = bufSQL & " " & IIf(HaishaDate = 999999, "NULL", HaishaDate) & ","
bufSQL = bufSQL & " " & BaseDate & ","
bufSQL = bufSQL & " '" & NenTuki & "',"
bufSQL = bufSQL & " '" & Touroku & "',"
bufSQL = bufSQL & " '" & ShaID & "',"
bufSQL = bufSQL & " '" & FLG & "');"
'追加の実行
DoCmd.RunSQL bufSQL
End If
Next I
End Sub
'----------------------------------------------------------------
Private Sub 閉じる_Click()
DoCmd.Close acForm, Me.Name, acSaveYes
End Sub
'----------------------------------------------------------------
Private Sub SubControl(Optional ByVal FLG As Boolean = False)
Dim I As Long
Dim Posi As Double
Dim Span As Double
Dim fCount As Long
Me.車検点検予定表SUB.Form.SelHeight = 1
Posi = Me.車検点検予定表SUB.Form("F1").Left
For I = 1 To Fname.Count
If Fname.Exists("F" & I) Then
If I > (ViewPosi - 1) And I < (ViewPosi + 13) Then
'13テキストボックス・ラベルを表示にし隙間なく並べる
With Me.車検点検予定表SUB
With .Form("F" & I)
Span = .Width
.Left = Posi
.Visible = True
End With
With .Form("L" & I)
If FLG Then
If InStr(ClickLabel, Fname("F" & I)) > 0 Then
.Caption = ClickLabel
Else
.Caption = Fname("F" & I)
End If
End If
.Left = Posi
.Visible = True
End With
With .Form("BK" & I)
.Left = Posi
.Visible = True
End With
Posi = Posi + Span
End With
Else
'その他は非表示にする
With Me.車検点検予定表SUB
.Form("F" & I).Visible = False
With .Form("L" & I)
If FLG Then
If InStr(ClickLabel, Fname("F" & I)) > 0 Then
.Caption = ClickLabel
Else
.Caption = Fname("F" & I)
End If
End If
.Visible = False
End With
With .Form("BK" & I)
.Visible = False
End With
End With
End If
'ラベルにセットした数をカウント
fCount = fCount + 1
End If
Next I
'ラベルにセットした数を上限にする
If (ViewPosi + 12) >= fCount Then
If Me.右.Enabled Then
Me.右.Enabled = False
End If
Else
If Not Me.右.Enabled Then
Me.右.Enabled = True
End If
End If
If ViewPosi <= 1 Then
If Me.左.Enabled Then
Me.左.Enabled = False
End If
Else
If Not Me.左.Enabled Then
Me.左.Enabled = True
End If
End If
End Sub
'----------------------------------------------------------------
Private Sub FNameMake()
Dim SDate As Long
Dim EDate As Long
Dim I As Long
SDate = DateSerial(Year(Date) - 1 + ShiftPosi, Month(Date), 1)
EDate = DateSerial(Year(Date) + 2 + ShiftPosi, Month(Date) + 1, 0)
'点検月名とフォームの表題の対照表の作成
Set Fname = Nothing
Set Fname = New Dictionary
Do Until DateSerial(Year(SDate), Month(SDate) + I, 1) > EDate
I = I + 1
ReDim Preserve NenTuki(I)
NenTuki(I) = StrConv(Format(DateSerial(Year(SDate), Month(SDate) + I - 1, 1), "geemm"), vbUpperCase)
Fname.Add "F" & I, NenTuki(I)
Loop
With Fname
.Add "登録番号", "登録番号"
.Add "登録日", "登録日"
.Add "廃車日", "廃車日"
.Add "有効期限", "有効期限"
End With
Call SetSelectCell
End Sub
'----------------------------------------------------------------
Private Sub SetSelectCell()
Dim Rs As DAO.Recordset
Dim SDate As Long
Dim EDate As Long
Dim mySQL As String
Dim bufStr() As String
Dim I As Long
SDate = DateSerial(Year(Date) - 1 + ShiftPosi, Month(Date), 1)
EDate = DateSerial(Year(Date) + 2 + ShiftPosi, Month(Date) + 1, 0)
mySQL = "SELECT"
mySQL = mySQL & " A.車検点検ID"
mySQL = mySQL & " FROM"
mySQL = mySQL & " 車検点検list AS A"
mySQL = mySQL & " WHERE (A.年月日>=" & SDate & ") AND (A.年月日<=" & EDate & ");"
Set Rs = CurrentDb.OpenRecordset(mySQL, dbOpenSnapshot)
If Rs.BOF Then
Exit Sub
End If
I = 0
Do Until Rs.EOF
ReDim Preserve bufStr(I)
bufStr(I) = Rs("車検点検ID")
I = I + 1
Rs.MoveNext
Loop
Rs.Close
Set Rs = Nothing
Me.車検点検予定表SUB.Form.SelectCell = Join(bufStr, ",")
End Sub