求助：修改Excel VBA时间选择器以支持24小时以上时长输入

原代码的核心问题是依赖Excel的TimeValue函数和时间格式，而Excel的时间系统以天为单位，超过24小时会自动取模重置为0。要支持99小时以内的时长输入，必须改用纯数值处理时分秒，脱离Excel的时间限制。

关键修改说明 #

1. 移除所有依赖Excel时间类型的常量和格式，改用自定义的时分秒数值处理
2. 新增两个辅助函数：
   • GetTimeParts：拆分文本框的时间字符串为小时、分钟、秒的数值
   • FormatTimeString：把时分秒数值格式化为hh:mm:ss格式的字符串
3. 调整上下按钮的逻辑：直接对时分秒数值加减，同时限制范围（小时0-99，分秒0-59），处理借位/进位
4. 保留原有的光标切换、选择逻辑，适配新的时间格式

修改后的完整代码 #

Private mtmPosition1 As tmPosition1

Private Const miRIGHTARROW1 As Integer = 39
Private Const miLEFTARROW1 As Integer = 37

Private Enum tmPosition1
    tmPositionHour1
    tmPositionMinute1
    tmPositionSecond1
End Enum

' 拆分时间字符串为小时、分钟、秒数值
Private Function GetTimeParts(ByVal timeStr As String, ByRef hourVal As Integer, ByRef minuteVal As Integer, ByRef secondVal As Integer)
    Dim parts() As String
    parts = Split(timeStr, ":")
    
    ' 处理非法输入，默认设为00:00:00
    hourVal = IIf(UBound(parts) >= 0 And IsNumeric(parts(0)), CInt(parts(0)), 0)
    minuteVal = IIf(UBound(parts) >= 1 And IsNumeric(parts(1)), CInt(parts(1)), 0)
    secondVal = IIf(UBound(parts) >= 2 And IsNumeric(parts(2)), CInt(parts(2)), 0)
    
    ' 强制限制范围
    hourVal = WorksheetFunction.Max(0, WorksheetFunction.Min(99, hourVal))
    minuteVal = WorksheetFunction.Max(0, WorksheetFunction.Min(59, minuteVal))
    secondVal = WorksheetFunction.Max(0, WorksheetFunction.Min(59, secondVal))
End Function

' 格式化时分秒为hh:mm:ss字符串
Private Function FormatTimeString(hourVal As Integer, minuteVal As Integer, secondVal As Integer) As String
    FormatTimeString = Format(hourVal, "00") & ":" & Format(minuteVal, "00") & ":" & Format(secondVal, "00")
End Function

Private Sub sbTime1_SpinDown()
    Dim h As Integer, m As Integer, s As Integer
    GetTimeParts Me.tbxTimePicker1.Text, h, m, s
    
    If Me.IsHour1 Then
        h = h - 1
        If h < 0 Then h = 0 ' 小时最小为0
    ElseIf Me.IsMinute1 Then
        m = m - 1
        If m < 0 Then
            m = 59
            h = h - 1
            If h < 0 Then h = 0 ' 小时不能小于0
        End If
    ElseIf Me.IsSecond1 Then
        s = s - 1
        If s < 0 Then
            s = 59
            m = m - 1
            If m < 0 Then
                m = 59
                h = h - 1
                If h < 0 Then h = 0
            End If
        End If
    End If
    
    Me.tbxTimePicker1.Text = FormatTimeString(h, m, s)
    SelectCurrentPosition ' 保持当前选中部分
End Sub

Private Sub sbTime1_SpinUp()
    Dim h As Integer, m As Integer, s As Integer
    GetTimeParts Me.tbxTimePicker1.Text, h, m, s
    
    If Me.IsHour1 Then
        h = h + 1
        If h > 99 Then h = 99 ' 小时最大为99
    ElseIf Me.IsMinute1 Then
        m = m + 1
        If m > 59 Then
            m = 0
            h = h + 1
            If h > 99 Then h = 99 ' 小时不能超过99
        End If
    ElseIf Me.IsSecond1 Then
        s = s + 1
        If s > 59 Then
            s = 0
            m = m + 1
            If m > 59 Then
                m = 0
                h = h + 1
                If h > 99 Then h = 99
            End If
        End If
    End If
    
    Me.tbxTimePicker1.Text = FormatTimeString(h, m, s)
    SelectCurrentPosition ' 保持当前选中部分
End Sub

' 辅助函数：根据当前位置重新选中对应部分
Private Sub SelectCurrentPosition()
    Select Case mtmPosition1
        Case tmPositionHour1: SelectHour1
        Case tmPositionMinute1: SelectMinute1
        Case tmPositionSecond1: SelectSecond1
    End Select
End Sub

Private Sub tbxTimePicker1_Enter()
    ' 初始化显示为00:00:00（如果为空）
    If Me.tbxTimePicker1.Text = "" Then
        Me.tbxTimePicker1.Text = "00:00:00"
    End If
    SelectHour1
End Sub

Private Sub tbxTimePicker1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = miRIGHTARROW1 Then
        If Me.IsHour1 Then
            SelectMinute1
        ElseIf Me.IsMinute1 Then
            SelectSecond1
        End If
    ElseIf KeyCode = miLEFTARROW1 Then
        If Me.IsSecond1 Then
            SelectMinute1
        Else
            SelectHour1
        End If
    Else
        ' 输入后重新格式化，确保符合格式
        Dim h As Integer, m As Integer, s As Integer
        GetTimeParts Me.tbxTimePicker1.Text, h, m, s
        Me.tbxTimePicker1.Text = FormatTimeString(h, m, s)
        SelectCurrentPosition
    End If
End Sub

Private Sub tbxTimePicker1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Me.tbxTimePicker1.SelStart < 3 Then
        SelectHour1
    ElseIf Me.tbxTimePicker1.SelStart < 6 Then
        SelectMinute1
    ElseIf Me.tbxTimePicker1.SelStart < 9 Then
        SelectSecond1
    End If
End Sub

Public Property Get IsHour1() As Boolean
    IsHour1 = mtmPosition1 = tmPositionHour1
End Property

Public Property Get IsMinute1() As Boolean
    IsMinute1 = mtmPosition1 = tmPositionMinute1
End Property

Public Property Get IsSecond1() As Boolean
    IsSecond1 = mtmPosition1 = tmPositionSecond1
End Property

Private Sub SelectMinute1()
    With Me.tbxTimePicker1
        .SetFocus
        .SelStart = 3
        .SelLength = 2
    End With
    mtmPosition1 = tmPositionMinute1
End Sub

Private Sub SelectHour1()
    With Me.tbxTimePicker1
        .SetFocus
        .SelStart = 0
        .SelLength = 2
    End With
    mtmPosition1 = tmPositionHour1
End Sub

Private Sub SelectSecond1()
    With Me.tbxTimePicker1
        .SetFocus
        .SelStart = 6
        .SelLength = 2
    End With
    mtmPosition1 = tmPositionSecond1
End Sub

代码功能说明 #

• 支持小时范围0-99，分秒范围0-59，超过范围会自动限制
• 上下按钮操作时自动处理借位/进位（比如分钟减到-1时，自动借1小时，分钟设为59）
• 输入非法字符时，会自动修正为合法数值
• 保留原有的光标切换、鼠标点击选择功能

内容的提问来源于stack exchange，提问作者NewbieNils