CONTACT

Public Sub ToggleProgressGroup()

Dim ws As Worksheet, shp As Shape, groupId As String, lastRow As Long, r As Long

Dim parentRow As Long, childCount As Long, childLastRow As Long

Dim anyVisible As Boolean, targetHidden As Boolean

Set ws = ThisWorkbook.Worksheets("現場進行予定")

On Error Resume Next

Set shp = ws.Shapes(CStr(Application.Caller))

On Error GoTo 0

If shp Is Nothing Then Exit Sub

groupId = ShapeProgressGroupId(shp)

If Len(groupId) = 0 Then Exit Sub

parentRow = shp.TopLeftCell.Row

childCount = CLng(NzD(ws.Cells(parentRow, 18).value))

If CStr(ws.Cells(parentRow, 15).value) = "PARENT" And CStr(ws.Cells(parentRow, 16).value) = groupId And childCount > 0 Then

childLastRow = parentRow + childCount

For r = parentRow + 1 To childLastRow

If CStr(ws.Cells(r, 16).value) = groupId And CStr(ws.Cells(r, 15).value) = "CHILD" Then

If Not ws.Rows(r).Hidden Then anyVisible = True

End If

targetHidden = anyVisible

For r = parentRow + 1 To childLastRow

If CStr(ws.Cells(r, 16).value) = groupId And CStr(ws.Cells(r, 15).value) = "CHILD" Then ws.Rows(r).Hidden = targetHidden

Else

lastRow = LastProgressDataRow(ws)

For r = PROGRESS_FIRST_ROW To lastRow

If CStr(ws.Cells(r, 16).value) = groupId And CStr(ws.Cells(r, 15).value) = "CHILD" Then

If Not ws.Rows(r).Hidden Then anyVisible = True

End If

targetHidden = anyVisible

For r = PROGRESS_FIRST_ROW To lastRow

If CStr(ws.Cells(r, 16).value) = groupId And CStr(ws.Cells(r, 15).value) = "CHILD" Then ws.Rows(r).Hidden = targetHidden

End If

shp.TextFrame.Characters.text = IIf(targetHidden, "+", "-")

shp.TextFrame2.TextRange.text = IIf(targetHidden, "+", "-")

UpdateProgressExpandButtonCaption ws

End Sub

'************************************************************************************

Option Compare Database

Option Explicit

Private Const EXPORT_PATH As String = "C:\ドキュメント\work\Codex\予定\data\課内予定\section_schedule.csv"

Private Const MAX_MEMBER_COUNT As Long = 5

Public Sub Export_Schedule_SummaryCSV_FromAccess()

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim ff As Integer

Dim tmpPath As String

Dim dateText As String

Dim weekdayText As String

Dim planText As String

Dim dayShift As String

Dim nightShift As String

Dim dayPlanOff As String

Dim daySuddenOff As String

Dim dayAbsent As String

Dim daySupport As String

Dim nightPlanOff As String

Dim nightSuddenOff As String

Dim nightAbsent As String

Dim nightSupport As String

Dim trainingText As String

Set db = CurrentDb

Set rs = db.OpenRecordset("SELECT * FROM [schedule_T] ORDER BY [日付];", dbOpenSnapshot)

tmpPath = EXPORT_PATH & ".tmp"

ff = FreeFile

Open tmpPath For Output As #ff

Print #ff, CsvLineAccess(Array( _

"日付", "曜日", "予定", _

"昼勤務", "昼計休", "昼突休", "昼欠員", "昼臨出", _

"夜勤務", "夜計休", "夜突休", "夜欠員", "夜臨出", _

"講習関係" _

))

Do Until rs.EOF

dateText = AccessDateText(GetFieldValue(rs, "日付"))

If Len(dateText) > 0 Then

weekdayText = GetWeekdayFromDateTextAccess(dateText)

planText = JoinAccessFixedFields(rs, Array("予定1", "予定2", "予定3"))

trainingText = GetFieldText(rs, "講習関係")

dayShift = GetFieldText(rs, "昼勤務")

nightShift = GetFieldText(rs, "夜勤務")

dayPlanOff = JoinAccessNumberedFields(rs, "昼計休", MAX_MEMBER_COUNT)

daySuddenOff = JoinAccessNumberedFields(rs, "昼突休", MAX_MEMBER_COUNT)

daySupport = JoinAccessNumberedFields(rs, "昼臨出", MAX_MEMBER_COUNT)

dayAbsent = JoinTwoTextAccess(dayPlanOff, daySuddenOff)

nightPlanOff = JoinAccessNumberedFields(rs, "夜計休", MAX_MEMBER_COUNT)

nightSuddenOff = JoinAccessNumberedFields(rs, "夜突休", MAX_MEMBER_COUNT)

nightSupport = JoinAccessNumberedFields(rs, "夜臨出", MAX_MEMBER_COUNT)

nightAbsent = JoinTwoTextAccess(nightPlanOff, nightSuddenOff)

Print #ff, CsvLineAccess(Array( _

dateText, weekdayText, planText, _

dayShift, dayPlanOff, daySuddenOff, dayAbsent, daySupport, _

nightShift, nightPlanOff, nightSuddenOff, nightAbsent, nightSupport, _

trainingText _

))

End If

rs.MoveNext

Loop

Close #ff

rs.Close

Set rs = Nothing

Set db = Nothing

If Dir(EXPORT_PATH) <> "" Then Kill EXPORT_PATH

Name tmpPath As EXPORT_PATH

End Sub

Private Function JoinAccessFixedFields(ByVal rs As DAO.Recordset, ByVal fieldNames As Variant) As String

Dim i As Long

Dim result As String

Dim part As String

For i = LBound(fieldNames) To UBound(fieldNames)

part = GetFieldText(rs, CStr(fieldNames(i)))

result = AppendPartAccess(result, part)

Next i

JoinAccessFixedFields = result

End Function

Private Function JoinAccessNumberedFields( _

ByVal rs As DAO.Recordset, _

ByVal prefix As String, _

ByVal maxCount As Long) As String

Dim i As Long

Dim result As String

Dim part As String

For i = 1 To maxCount

part = GetFieldText(rs, prefix & CStr(i))

result = AppendPartAccess(result, part)

Next i

JoinAccessNumberedFields = result

End Function

Private Function JoinTwoTextAccess(ByVal a As String, ByVal b As String) As String

Dim result As String

result = ""

result = AppendPartAccess(result, a)

result = AppendPartAccess(result, b)

JoinTwoTextAccess = result

End Function

Private Function AppendPartAccess(ByVal baseText As String, ByVal addText As String) As String

addText = AccessCleanText(addText)

If Len(addText) = 0 Then

AppendPartAccess = baseText

ElseIf Len(baseText) = 0 Then

AppendPartAccess = addText

Else

AppendPartAccess = baseText & "／" & addText

End If

End Function

Private Function GetFieldValue(ByVal rs As DAO.Recordset, ByVal fieldName As String) As Variant

If FieldExists(rs, fieldName) Then

GetFieldValue = rs.Fields(fieldName).Value

Else

GetFieldValue = Null

End If

End Function

Private Function GetFieldText(ByVal rs As DAO.Recordset, ByVal fieldName As String) As String

If FieldExists(rs, fieldName) Then

GetFieldText = AccessCleanText(rs.Fields(fieldName).Value)

Else

GetFieldText = ""

End If

End Function

Private Function FieldExists(ByVal rs As DAO.Recordset, ByVal fieldName As String) As Boolean

Dim f As DAO.Field

For Each f In rs.Fields

If StrComp(f.Name, fieldName, vbTextCompare) = 0 Then

FieldExists = True

Exit Function

End If

Next f

FieldExists = False

End Function

Private Function AccessDateText(ByVal v As Variant) As String

If IsNull(v) Or IsEmpty(v) Then

AccessDateText = ""

ElseIf IsDate(v) Then

AccessDateText = Format$(CDate(v), "yyyy/mm/dd")

Else

AccessDateText = AccessCleanText(v)

End If

End Function

Private Function GetWeekdayFromDateTextAccess(ByVal dateText As String) As String

Dim d As Date

Dim weekChars As String

If Not IsDate(dateText) Then

GetWeekdayFromDateTextAccess = ""

Exit Function

End If

d = CDate(dateText)

weekChars = "日月火水木金土"

GetWeekdayFromDateTextAccess = Mid$(weekChars, Weekday(d, vbSunday), 1)

End Function

Private Function AccessCleanText(ByVal v As Variant) As String

Dim s As String

If IsNull(v) Or IsEmpty(v) Then

AccessCleanText = ""

Exit Function

End If

s = CStr(v)

s = Replace(s, vbCrLf, " ")

s = Replace(s, vbCr, " ")

s = Replace(s, vbLf, " ")

AccessCleanText = Trim$(s)

End Function

Private Function CsvLineAccess(ByVal values As Variant) As String

Dim i As Long

Dim result As String

For i = LBound(values) To UBound(values)

If i > LBound(values) Then result = result & ","

result = result & CsvEscapeAccess(CStr(values(i)))

Next i

CsvLineAccess = result

End Function

Private Function CsvEscapeAccess(ByVal s As String) As String

s = Replace(s, """", """""")

CsvEscapeAccess = """" & s & """"

End Function

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'************************************************************************************

Private Function FirstProgressChildRow(ByVal ws As Worksheet, ByVal rowNumber As Long) As Long

Dim groupId As String, r As Long, lastRow As Long, childCount As Long

FirstProgressChildRow = rowNumber

If CStr(ws.Cells(rowNumber, 15).value) <> "PARENT" Then Exit Function

groupId = CStr(ws.Cells(rowNumber, 16).value)

childCount = CLng(NzD(ws.Cells(rowNumber, 18).value))

If childCount > 0 Then

For r = rowNumber + 1 To rowNumber + childCount

If CStr(ws.Cells(r, 16).value) = groupId And CStr(ws.Cells(r, 15).value) = "CHILD" Then

FirstProgressChildRow = r

Exit Function

End If

lastRow = LastProgressDataRow(ws)

For r = rowNumber + 1 To lastRow

If CStr(ws.Cells(r, 16).value) <> groupId Then Exit For

If CStr(ws.Cells(r, 15).value) = "CHILD" Then

FirstProgressChildRow = r

Exit Function

End If

End Function

'************************************************************************************