About a week ago, I went to the board for some time-saving help on a 'quick & dirty' utility. Then (Honest, I'm not making this up) the client expanded the specs! Anyway, I'm posting the results as a small down-payment on all the help I've gotten from the board over time,
Speaking of time. the records here extend back to the mid 1800s. Obviously a Johnny-come-lately by the standards of a religious institution. Something odd occurred with dates at the turn of the 19th/20th century. 1900 was NOT a leap year. Luckily, I remembered reading something about this during the Y2K panic (century years not divisible by 400 are not leap years. An old adage is to "Never trust a man who says trust me", so you'll probably want to Google this) and didn't totally lose my mind when doing calcs for the first 2 months of 1900, This also is probably why the doc for Exxcel's DATE variable-type starts the serial value in 1904 but I'm already testing the limits of my knowledge here.
Hope something in here might help somebody.
Form has 2 optButtons, 3 txtBoxes & 2 cmdButons
Speaking of time. the records here extend back to the mid 1800s. Obviously a Johnny-come-lately by the standards of a religious institution. Something odd occurred with dates at the turn of the 19th/20th century. 1900 was NOT a leap year. Luckily, I remembered reading something about this during the Y2K panic (century years not divisible by 400 are not leap years. An old adage is to "Never trust a man who says trust me", so you'll probably want to Google this) and didn't totally lose my mind when doing calcs for the first 2 months of 1900, This also is probably why the doc for Exxcel's DATE variable-type starts the serial value in 1904 but I'm already testing the limits of my knowledge here.
Hope something in here might help somebody.
Code:
'--------------------------------------------------------------------
Sub Edit_TDS()
'
'Change day/hour/min of an existing time-value
'Cursor must be on value to be changed when procedure is called.
'11/08/14: Recorded at Bishop MacLean
'
Dim cAddSub As String, cFormat As String, cMsg As String
Dim dNew As Date, dOrig As Date
Dim iPromptAns As Integer
'Confirm the date to be modified
dOrig = ActiveCell.Value
cMsg = "The date you will be changimg is " & dOrig
iPromptAns = zPrompt(cMsg, 1, "Confirm Value") '==> Prompt(OK/Cxl)
If iPromptAns = vbCancel Then GoTo endEditTDS
'Get Days/Mins/Hours to change
frmEdit_TDS.Show
'Exit Sub if no changes were mafe
dNew = ActiveCell.Value
If dNew = dOrig Then GoTo endEditTDS
'Confirm or Restore the TDS
cMsg = "Accept new date of " & dNew & " ?"
iPromptAns = zPrompt(cMsg, 4, "Confirm Value") '==> Prompt(OK/Cxl)
If iPromptAns = vbNo Then
'Save current display format
cFormat = ActiveCell.NumberFormat
ActiveCell.Value = dOrig
'Without this, DATE var will display mm/dd/yyyy h:m:s
ActiveCell.NumberFormat = cFormat
MsgBox "Date will remain " & dOrig
End If
endEditTDS:
End Sub
'-------------------------------------------------------------------
Function zPrompt(cPrompt As String, iOptions As Integer, cTitle As String) _
As Integer
'
' Ask for user-response
' MsgBox(prompt[, buttons] [, title] [, helpfile, context])
' Displays a message in a dialog box, waits for the user to click a button,
' and returns an Integer indicating which button the user clicked. MsgBox
' has no "positioning" options, unlike Get_Input()
' System constants fo iOption: vbOKOnly, vbOKCancel, vbAbortRetryIgnore,
' vbYesNoCancel, vbYesNo, vbRetryCancel
'7/7/2013
zPrompt = MsgBox(cPrompt, iOptions, cTitle)
'iOption codes: Return value (of SYS-constants):
'0 -- OK only (i.e., pause) 1 -- vbOK
'1 -- OK Cancel 2 -- vbCancel
'2 -- Abort Retry Ignore 3 -- vbAbort
'3 -- Yes No Cancel 4 -- vbRetry
'4 -- Yes No 5 -- vbIgnore
'5 -- Retry Cancel 6 -- vbYes
'(No Option 6) 7 -- vbNo
End Function
'--------------------------------------------------------------------
Code:
'--------------------------------------------------------------------
Private Sub cmdChange_Click()
'
'Event-code for frmEditTDS
'Change cell-value per numbers entered, confim in calling preoram
'11/12/14
'
Dim bSubtract As Boolean
Dim cFormat As String
Dim dChange As Date, dNew As Date, dOrig As Date
Dim iDays As Long, iHours As Integer, iMins As Integer, iSecs As Integer
Dim iError As Integer
On Error GoTo Err_EditTDS
'Store cell-values to mVars
cFormat = ActiveCell.NumberFormat
dOrig = ActiveCell.Value
'Read data from form into mVars
bSubtract = Me.optSubtract.Value
iDays = Me.TxtDays.Value
iHours = Me.TxtHrs.Value
iMins = Me.TxtMins.Value
'Convert D/H/M to TDS serial-value, update cell
iDays = iDays * 1440
iHours = iHours * 60
dChange = (iDays + iHours + iMins) / 1440
If dChange = 0 Then
Me.TxtDays.SetFocus
MsgBox "Please enter at least one nunumber"
GoTo Err_EditTDS
ElseIf bSubtract Then
dChange = dChange * -1
End If
dNew = dOrig + dChange
ActiveCell.Value = dNew
ActiveCell.NumberFormat = cFormat
Err_EditTDS:
'Store E.Num to mVar for readability
iError = Err.Number
Select Case iError
Case 1004
'1900 was not a leap-year so prior calcs can cause confusion
MsgBox "Calculated Date (" & dNew & ") cannot be displayed in Excel" & vbCr & vbCrLf _
& "The 59 days prior to 3/1/1900 will appear to be off by 1 day"
'Clear all text-boxes and get new valurs
Me.TxtDays.Value = 0
Me.TxtHrs.Value = 0
Me.TxtMins.Value = 0
Me.TxtDays.SetFocus
Case Is <> 0 'Use std system errr-msg
MsgBox Err.Number & ": " & Err.Description
End
End Select
On Error GoTo 0
Unload Me
End Sub
'--------------------------------------------------------------------
Private Sub cmdCancel_Click()
Unload Me
End Sub
'--------------------------------------------------------------------
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the button!"
End If
End Sub
'--------------------------------------------------------------------
'--------------------------------------------------------------------
