Option Explicit

Public Sub 飛行作業線表生成()

    Const INPUT_SHEET_NAME As String = "入力データ"
    Const OUTPUT_SHEET_NAME As String = "出力データ"
    
    Const DATA_FIRST_ROW As Long = 61
    
    Const OUT_FIRST_ROW As Long = 26
    Const OUT_ROW_STEP As Long = 4
    Const DEFAULT_TEMPLATE_BLOCKS As Long = 6
    
    Const DAY_START_MIN As Long = 420   ' 07:00
    Const DAY_END_MIN As Long = 1320    ' 22:00
    
    Dim wsIn As Worksheet
    Dim wsOut As Worksheet
    
    Dim dicAircraft As Object
    Dim dicOutRow As Object
    
    Dim keys As Variant
    Dim i As Long
    Dim r As Long
    Dim ac As String
    Dim dataLastRow As Long
    
    Dim originLeft As Double
    Dim nextHourLeft As Double
    Dim minuteWidth As Double
    
    Dim requiredBlocks As Long
    Dim existingBlocks As Long
    
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set wsIn = ResolveInputSheet(ThisWorkbook, INPUT_SHEET_NAME)
    Set wsOut = ResolveOutputSheet(ThisWorkbook, OUTPUT_SHEET_NAME)
    
    If wsIn Is Nothing Then
        Err.Raise vbObjectError + 1000, , "入力データ用のシートを特定できませんでした。"
    End If
    
    If wsOut Is Nothing Then
        Err.Raise vbObjectError + 1001, , "出力データ用のシートを特定できませんでした。"
    End If
    
    dataLastRow = GetLastInputRow(wsIn, DATA_FIRST_ROW)
    
    Set dicAircraft = CreateObject("Scripting.Dictionary")
    Set dicOutRow = CreateObject("Scripting.Dictionary")
    
    For r = DATA_FIRST_ROW To dataLastRow
        If IsValidRecord(wsIn, r) Then
            ac = Trim$(CStr(wsIn.Cells(r, "D").Value))
            If ac <> "" Then
                If Not dicAircraft.Exists(ac) Then
                    dicAircraft.Add ac, ac
                End If
            End If
        End If
    Next r
    
    If dicAircraft.Count = 0 Then
        MsgBox "入力データが見つかりませんでした。", vbExclamation
        GoTo ExitProc
    End If
    
    requiredBlocks = dicAircraft.Count
    existingBlocks = GetStoredBlockCount(ThisWorkbook, DEFAULT_TEMPLATE_BLOCKS)
    
    ClearGeneratedShapes wsOut
    
    If requiredBlocks > existingBlocks Then
        EnsureOutputCapacity wsOut, OUT_FIRST_ROW, OUT_ROW_STEP, DEFAULT_TEMPLATE_BLOCKS, existingBlocks, requiredBlocks
        existingBlocks = requiredBlocks
        SetStoredBlockCount ThisWorkbook, existingBlocks
    Else
        If existingBlocks < DEFAULT_TEMPLATE_BLOCKS Then
            existingBlocks = DEFAULT_TEMPLATE_BLOCKS
        End If
        SetStoredBlockCount ThisWorkbook, existingBlocks
    End If
    
    ClearAircraftLabels wsOut, OUT_FIRST_ROW, OUT_ROW_STEP, existingBlocks
    
    keys = dicAircraft.Keys
    SortVariantArray keys
    
    For i = LBound(keys) To UBound(keys)
        ac = CStr(keys(i))
        dicOutRow.Add ac, OUT_FIRST_ROW + (i * OUT_ROW_STEP)
        wsOut.Range("C" & (OUT_FIRST_ROW + (i * OUT_ROW_STEP))).Value = ac
    Next i
    
    originLeft = wsOut.Range("J1").Left
    nextHourLeft = wsOut.Range("P1").Left
    minuteWidth = (nextHourLeft - originLeft) / 60#
    
    For r = DATA_FIRST_ROW To dataLastRow
        
        If IsValidRecord(wsIn, r) Then
            
            ac = Trim$(CStr(wsIn.Cells(r, "D").Value))
            
            If dicOutRow.Exists(ac) Then
                
                Dim sMin As Long
                Dim eMin As Long
                Dim eteHour As Double
                
                Dim leftPts As Double
                Dim widthPts As Double
                
                Dim outRow As Long
                Dim topY As Double, topH As Double
                Dim mainY As Double, mainH As Double
                Dim noteY As Double, noteH As Double
                
                Dim crewText As String
                Dim missText As String
                Dim eteText As String
                Dim noteText As String
                Dim kindText As String
                Dim fillColor As Long
                
                sMin = HHMMToMinutes(wsIn.Cells(r, "H").Value)
                eMin = HHMMToMinutes(wsIn.Cells(r, "L").Value)
                
                If sMin >= 0 Then
                    
                    If eMin <= sMin Then
                        eteHour = GetNumericValue(wsIn.Cells(r, "P").Value)
                        If eteHour > 0 Then
                            eMin = sMin + CLng(eteHour * 60#)
                        End If
                    End If
                    
                    If eMin > sMin Then
                        
                        If sMin < DAY_END_MIN And eMin > DAY_START_MIN Then
                            
                            If sMin < DAY_START_MIN Then sMin = DAY_START_MIN
                            If eMin > DAY_END_MIN Then eMin = DAY_END_MIN
                            
                            outRow = CLng(dicOutRow(ac))
                            
                            leftPts = originLeft + ((sMin - DAY_START_MIN) * minuteWidth) + 1
                            widthPts = ((eMin - sMin) * minuteWidth) - 2
                            If widthPts < 36 Then widthPts = 36
                            
                            topY = wsOut.Rows(outRow).Top + 1
                            topH = wsOut.Rows(outRow).Height - 2
                            
                            mainY = wsOut.Rows(outRow + 1).Top + 1
                            mainH = wsOut.Rows(outRow + 1).Height - 2
                            
                            noteY = wsOut.Rows(outRow + 2).Top + 1
                            noteH = wsOut.Rows(outRow + 2).Height + wsOut.Rows(outRow + 3).Height - 2
                            
                            crewText = BuildCrewText(wsIn, r)
                            missText = Trim$(CStr(wsIn.Cells(r, "BQ").Text))
                            eteText = GetEteText(wsIn.Cells(r, "P").Value)
                            noteText = BuildRemarksText(wsIn, r, dataLastRow)
                            kindText = GetKindText(wsIn, r)
                            fillColor = GetLineColor(kindText)
                            
                            AddFreeTextBox wsOut, _
                                           "senpyo_top_" & CStr(r), _
                                           leftPts, topY, widthPts, topH, _
                                           crewText, 6.5, False, _
                                           msoAlignLeft, msoAnchorMiddle
                            
                            AddMainBox wsOut, _
                                       "senpyo_main_" & CStr(r), _
                                       leftPts, mainY, widthPts, mainH, _
                                       missText & "   " & eteText, fillColor
                            
                            AddFreeTextBox wsOut, _
                                           "senpyo_note_" & CStr(r), _
                                           leftPts, noteY, widthPts, noteH, _
                                           noteText, 6, True, _
                                           msoAlignLeft, msoAnchorTop
                            
                        End If
                    End If
                End If
            End If
        End If
    Next r

ExitProc:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "エラー: " & Err.Description, vbCritical
End Sub

Private Function ResolveInputSheet(ByVal wb As Workbook, ByVal preferredName As String) As Worksheet
    Dim ws As Worksheet
    
    On Error Resume Next
    Set ResolveInputSheet = wb.Worksheets(preferredName)
    On Error GoTo 0
    
    If Not ResolveInputSheet Is Nothing Then Exit Function
    
    For Each ws In wb.Worksheets
        If HasInputSignature(ws) Then
            Set ResolveInputSheet = ws
            Exit Function
        End If
    Next ws
End Function

Private Function ResolveOutputSheet(ByVal wb As Workbook, ByVal preferredName As String) As Worksheet
    Dim ws As Worksheet
    Dim nm As String
    
    On Error Resume Next
    Set ResolveOutputSheet = wb.Worksheets(preferredName)
    On Error GoTo 0
    
    If Not ResolveOutputSheet Is Nothing Then Exit Function
    
    For Each ws In wb.Worksheets
        nm = Replace(Trim$(ws.Name), " ", "")
        If UCase$(nm) = "SHEET2" Then
            Set ResolveOutputSheet = ws
            Exit Function
        End If
    Next ws
    
    For Each ws In wb.Worksheets
        If HasOutputSignature(ws) Then
            Set ResolveOutputSheet = ws
            Exit Function
        End If
    Next ws
End Function

Private Function HasInputSignature(ByVal ws As Worksheet) As Boolean
    Dim score As Long
    
    score = 0
    
    If SheetContainsText(ws, "NO") Then score = score + 1
    If SheetContainsText(ws, "A/C") Then score = score + 1
    If SheetContainsText(ws, "ETD") Then score = score + 1
    If SheetContainsText(ws, "ETA") Then score = score + 1
    If SheetContainsText(ws, "ETE") Then score = score + 1
    
    HasInputSignature = (score >= 4)
End Function

Private Function HasOutputSignature(ByVal ws As Worksheet) As Boolean
    Dim score As Long
    
    score = 0
    
    If SheetContainsText(ws, "機番") Then score = score + 1
    If SheetContainsText(ws, "０７００") Or SheetContainsText(ws, "0700") Then score = score + 1
    If SheetContainsText(ws, "０８００") Or SheetContainsText(ws, "0800") Then score = score + 1
    
    HasOutputSignature = (score >= 2)
End Function

Private Function SheetContainsText(ByVal ws As Worksheet, ByVal searchText As String) As Boolean
    Dim f As Range
    
    On Error Resume Next
    Set f = ws.Cells.Find(What:=searchText, _
                          After:=ws.Cells(1, 1), _
                          LookIn:=xlValues, _
                          LookAt:=xlWhole, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlNext, _
                          MatchCase:=False)
    On Error GoTo 0
    
    SheetContainsText = Not f Is Nothing
End Function

Private Function GetLastInputRow(ByVal ws As Worksheet, ByVal minimumRow As Long) As Long
    Dim cols As Variant
    Dim i As Long
    Dim r As Long
    Dim lastRow As Long
    
    cols = Array("B", "D", "H", "L", "P", "BQ", "BY")
    lastRow = minimumRow
    
    For i = LBound(cols) To UBound(cols)
        r = ws.Cells(ws.Rows.Count, cols(i)).End(xlUp).Row
        If r > lastRow Then lastRow = r
    Next i
    
    If lastRow < minimumRow Then lastRow = minimumRow
    
    GetLastInputRow = lastRow
End Function

Private Function IsValidRecord(ByVal ws As Worksheet, ByVal r As Long) As Boolean
    Dim ac As String
    Dim etd As Long
    
    ac = Trim$(CStr(ws.Cells(r, "D").Value))
    etd = HHMMToMinutes(ws.Cells(r, "H").Value)
    
    If ac = "" Then Exit Function
    If etd < 0 Then Exit Function
    
    IsValidRecord = True
End Function

Private Function HHMMToMinutes(ByVal v As Variant) As Long
    Dim s As String
    Dim hh As Long
    Dim mm As Long
    
    On Error GoTo ErrHandler
    
    If IsDate(v) Then
        HHMMToMinutes = Hour(CDate(v)) * 60 + Minute(CDate(v))
        Exit Function
    End If
    
    s = Trim$(CStr(v))
    s = Replace(s, ":", "")
    s = Replace(s, "：", "")
    
    If s = "" Then
        HHMMToMinutes = -1
        Exit Function
    End If
    
    If Not IsNumeric(s) Then
        HHMMToMinutes = -1
        Exit Function
    End If
    
    s = Right$("0000" & s, 4)
    hh = CLng(Left$(s, 2))
    mm = CLng(Right$(s, 2))
    
    If hh < 0 Or hh > 23 Or mm < 0 Or mm > 59 Then
        HHMMToMinutes = -1
    Else
        HHMMToMinutes = hh * 60 + mm
    End If
    
    Exit Function

ErrHandler:
    HHMMToMinutes = -1
End Function

Private Function BuildCrewText(ByVal ws As Worksheet, ByVal r As Long) As String
    Dim cols As Variant
    Dim i As Long
    Dim txt As String
    Dim buf As String
    
    cols = Array("T", "AA", "AH", "AO", "AV", "BC")
    
    For i = LBound(cols) To UBound(cols)
        txt = Trim$(CStr(ws.Cells(r, cols(i)).Text))
        If txt <> "" Then
            If buf <> "" Then buf = buf & "　"
            buf = buf & txt
        End If
    Next i
    
    BuildCrewText = buf
End Function

Private Function BuildRemarksText(ByVal ws As Worksheet, ByVal r As Long, ByVal lastRow As Long) As String
    Dim rr As Long
    Dim txt As String
    Dim buf As String
    Dim endRow As Long
    
    endRow = r + 3
    If endRow > lastRow Then endRow = lastRow
    
    For rr = r To endRow
        txt = Trim$(CStr(ws.Cells(rr, "BY").Text))
        If txt <> "" Then
            If buf <> "" Then buf = buf & vbLf
            buf = buf & txt
        End If
    Next rr
    
    BuildRemarksText = buf
End Function

Private Function GetKindText(ByVal ws As Worksheet, ByVal r As Long) As String
    GetKindText = Trim$(CStr(ws.Cells(r, "B").Text))
End Function

Private Function GetLineColor(ByVal kindText As String) As Long
    kindText = Trim$(kindText)
    
    Select Case True
        Case kindText Like "訓*"
            GetLineColor = RGB(0, 112, 192)
        Case kindText Like "試*"
            GetLineColor = RGB(255, 0, 0)
        Case kindText Like "要*"
            GetLineColor = RGB(255, 255, 0)
        Case UCase$(kindText) = "GND"
            GetLineColor = RGB(255, 255, 255)
        Case Else
            GetLineColor = RGB(255, 255, 255)
    End Select
End Function

Private Function GetEteText(ByVal v As Variant) As String
    If Trim$(CStr(v)) = "" Then
        GetEteText = ""
    ElseIf IsNumeric(v) Then
        GetEteText = Format$(CDbl(v), "0.0")
    Else
        GetEteText = Trim$(CStr(v))
    End If
End Function

Private Function GetNumericValue(ByVal v As Variant) As Double
    If IsNumeric(v) Then
        GetNumericValue = CDbl(v)
    Else
        GetNumericValue = 0
    End If
End Function

Private Sub ClearAircraftLabels(ByVal ws As Worksheet, ByVal firstRow As Long, ByVal rowStep As Long, ByVal blockCount As Long)
    Dim i As Long
    For i = 0 To blockCount - 1
        ws.Range("C" & (firstRow + i * rowStep)).Value = ""
    Next i
End Sub

Private Sub ClearGeneratedShapes(ByVal ws As Worksheet)
    Dim i As Long
    
    For i = ws.Shapes.Count To 1 Step -1
        If Left$(ws.Shapes(i).Name, 7) = "senpyo_" Then
            ws.Shapes(i).Delete
        End If
    Next i
End Sub

Private Sub EnsureOutputCapacity(ByVal ws As Worksheet, _
                                 ByVal firstRow As Long, _
                                 ByVal rowStep As Long, _
                                 ByVal templateBlocks As Long, _
                                 ByVal currentBlocks As Long, _
                                 ByVal requiredBlocks As Long)
    
    Dim sourceStartRow As Long
    Dim destStartRow As Long
    Dim blockIndex As Long
    
    If requiredBlocks <= currentBlocks Then Exit Sub
    
    sourceStartRow = firstRow + (templateBlocks - 1) * rowStep
    
    For blockIndex = currentBlocks To requiredBlocks - 1
        destStartRow = firstRow + blockIndex * rowStep
        
        ws.Rows(sourceStartRow & ":" & sourceStartRow + rowStep - 1).Copy
        ws.Rows(destStartRow & ":" & destStartRow + rowStep - 1).Insert Shift:=xlDown
        Application.CutCopyMode = False
        
        ws.Range("C" & destStartRow).Value = ""
    Next blockIndex
End Sub

Private Function GetStoredBlockCount(ByVal wb As Workbook, ByVal defaultCount As Long) As Long
    Dim nm As Name
    Dim v As Variant
    
    On Error Resume Next
    Set nm = wb.Names("_SenpyoBlockCount")
    On Error GoTo 0
    
    If nm Is Nothing Then
        GetStoredBlockCount = defaultCount
        Exit Function
    End If
    
    On Error Resume Next
    v = Evaluate(nm.RefersTo)
    On Error GoTo 0
    
    If IsNumeric(v) Then
        If CLng(v) >= defaultCount Then
            GetStoredBlockCount = CLng(v)
        Else
            GetStoredBlockCount = defaultCount
        End If
    Else
        GetStoredBlockCount = defaultCount
    End If
End Function

Private Sub SetStoredBlockCount(ByVal wb As Workbook, ByVal blockCount As Long)
    On Error Resume Next
    wb.Names("_SenpyoBlockCount").Delete
    On Error GoTo 0
    
    wb.Names.Add Name:="_SenpyoBlockCount", RefersTo:="=" & CStr(blockCount)
End Sub

Private Sub AddMainBox(ByVal ws As Worksheet, _
                       ByVal shpName As String, _
                       ByVal leftPts As Double, _
                       ByVal topPts As Double, _
                       ByVal widthPts As Double, _
                       ByVal heightPts As Double, _
                       ByVal textValue As String, _
                       ByVal fillColor As Long)

    Dim shp As Shape
    
    Set shp = ws.Shapes.AddShape(msoShapeRectangle, leftPts, topPts, widthPts, heightPts)
    shp.Name = shpName
    shp.Placement = xlMoveAndSize
    
    With shp
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Line.Weight = 0.75
        
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = fillColor
        .Fill.Solid
        
        With .TextFrame2
            .TextRange.Text = textValue
            .TextRange.ParagraphFormat.Alignment = msoAlignLeft
            .VerticalAnchor = msoAnchorMiddle
            .MarginLeft = 3
            .MarginRight = 1
            .MarginTop = 1
            .MarginBottom = 1
            .WordWrap = msoTrue
            .AutoSize = msoAutoSizeTextToFitShape
            
            With .TextRange.Font
                .Size = 11
                .Bold = msoTrue
                .Fill.ForeColor.RGB = RGB(0, 0, 0)
            End With
        End With
    End With
End Sub

Private Sub AddFreeTextBox(ByVal ws As Worksheet, _
                           ByVal shpName As String, _
                           ByVal leftPts As Double, _
                           ByVal topPts As Double, _
                           ByVal widthPts As Double, _
                           ByVal heightPts As Double, _
                           ByVal textValue As String, _
                           ByVal fontSize As Double, _
                           ByVal shrinkToFit As Boolean, _
                           ByVal horizontalAlign As MsoParagraphAlignment, _
                           ByVal verticalAnchor As MsoVerticalAnchor)

    Dim shp As Shape
    
    Set shp = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, leftPts, topPts, widthPts, heightPts)
    shp.Name = shpName
    shp.Placement = xlMoveAndSize
    
    With shp
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
        
        With .TextFrame2
            .TextRange.Text = textValue
            .TextRange.ParagraphFormat.Alignment = horizontalAlign
            .VerticalAnchor = verticalAnchor
            .MarginLeft = 2
            .MarginRight = 1
            .MarginTop = 1
            .MarginBottom = 1
            .WordWrap = msoTrue
            
            If shrinkToFit Then
                .AutoSize = msoAutoSizeTextToFitShape
            Else
                .AutoSize = msoAutoSizeNone
            End If
            
            With .TextRange.Font
                .Size = fontSize
                .Bold = msoFalse
                .Fill.ForeColor.RGB = RGB(0, 0, 0)
            End With
        End With
    End With
End Sub

Private Sub SortVariantArray(ByRef arr As Variant)
    Dim i As Long
    Dim j As Long
    Dim tmp As Variant
    
    If IsEmpty(arr) Then Exit Sub
    
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If CStr(arr(i)) > CStr(arr(j)) Then
                tmp = arr(i)
                arr(i) = arr(j)
                arr(j) = tmp
            End If
        Next j
    Next i
End Sub