Option Explicit
'Option Private Module
Public vArrDates As Variant
Public vFormulas() As Variant 'Array(1 to MAX_UNDO, 1 to 3)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'Get Your Own Date Workbook.
'ModuleStuff module - xxjamesconexx@gmail.com - Copyrighted
'Jan 2011
'Jan 2013 - Simplified some of the code and added check for minimum form size.
'May 2013 - Updated ShowInsertInfo sub.
Sub AskFor_A_Date()
On Error GoTo DateFromHell
Application.EnableCancelKey = xlErrorHandler
If TypeName(ActiveSheet) = "Worksheet" Then
If ActiveSheet.ProtectContents Then
MsgBox "The worksheet must be unprotected. ", vbInformation, "Insert Date"
Else 'modeless option on 10/12/2011
#If VBA6 Then
ArrDateForm.Show False
#ElseIf VBA7 Then
ArrDateForm.Show False
#Else
ArrDateForm.Show
#End If
End If
End If
Exit Sub
DateFromHell:
Beep
Resume Next
End Sub
Function GetDayNames() As Variant
'Determines name of the first day of the week (varies by country).
'Used to display day names on form and to choose the 1st day element in vArrDates.
'Called by CmdButtonReset_Click, UserForm_Initialize
'Feb 2013 - Modifed by Hans Vogelaar to use country specific day names.
On Error GoTo NightTime
Dim i As Long
Dim lngDay As Long
Dim arrDays(0 To 6) As String
lngDay = VBA.Weekday(#1/1/2000#, vbUseSystem)
For i = 0 To 6
arrDays(i) = VBA.Left(VBA.Format$(VBA.DateSerial(2000, 1, i + 9 - lngDay), "ddd"), 2)
Next 'i
GetDayNames = arrDays
Exit Function
NightTime:
Beep
Resume Next
End Function
Function IsArraySet(v As Variant) As Boolean
'Nov 07, 2011 and Feb 12, 2013
On Error GoTo Squashed
Dim blnSet As Boolean
On Error Resume Next
'lower limit for a Long
blnSet = (UBound(v, 1) >= -2147483647)
On Error GoTo Squashed
If blnSet Then
'Cell address is in 3rd column.
blnSet = Len(vFormulas(1, 3)) > 0
End If
IsArraySet = blnSet
Exit Function
Squashed:
Beep
IsArraySet = False
End Function
Function PutDaysInArray(ByRef CurMonth As Long, ByRef CurYear As Long) As Byte
On Error GoTo MyErrorTrap
Application.EnableCancelKey = xlErrorHandler
Dim StartDay As Date
Dim FinalDay As Date
Dim lngRow As Long
Dim lngCol As Long
Dim DaysInMth As Long
Dim blnEnd As Boolean
ReDim vArrDates(2 To 7, 1 To 7)
'Get the date value of the first day of the month.
StartDay = VBA.DateSerial(CurYear, CurMonth, 1)
'Calculate the first day of the next month.
FinalDay = VBA.DateSerial(CurYear, CurMonth + 1, 1)
DaysInMth = FinalDay - StartDay
'Place a 1 in array element that corresponds to calendar position for the 1st day of month
vArrDates(2, VBA.Weekday(StartDay, vbUseSystem)) = 1
'Loop through array incrementing each element after the "1" element.
For lngRow = 2 To 7
For lngCol = 1 To 7
If lngCol <> 1 Then
'If array element is not in 1st column.
If vArrDates(lngRow, lngCol - 1) > 0 Then
vArrDates(lngRow, lngCol) = vArrDates(lngRow, lngCol - 1) + 1
'Stop when the last day of the month has been entered.
If vArrDates(lngRow, lngCol) > DaysInMth Then
vArrDates(lngRow, lngCol) = vbNullString
blnEnd = True
Exit For
End If
End If
'If array element is in 1st column.
ElseIf lngRow > 2 And lngCol = 1 Then
vArrDates(lngRow, lngCol) = vArrDates(lngRow - 1, 7) + 1
'Stop when the last day of the month has been entered.
If vArrDates(lngRow, lngCol) > DaysInMth Or vArrDates(lngRow, lngCol) = 1 Then
vArrDates(lngRow, lngCol) = vbNullString
blnEnd = True
Exit For
End If
End If
Next 'Col
If blnEnd Then Exit For
Next 'Row
'Prior month dates added.
Select Case VBA.Weekday(StartDay, vbUseSystem)
Case 2
vArrDates(2, 1) = VBA.Day(StartDay - 1)
Case 3
vArrDates(2, 2) = VBA.Day(StartDay - 1)
vArrDates(2, 1) = VBA.Day(StartDay - 2)
Case 4
vArrDates(2, 3) = VBA.Day(StartDay - 1)
vArrDates(2, 2) = VBA.Day(StartDay - 2)
vArrDates(2, 1) = VBA.Day(StartDay - 3)
Case 5
vArrDates(2, 4) = VBA.Day(StartDay - 1)
vArrDates(2, 3) = VBA.Day(StartDay - 2)
vArrDates(2, 2) = VBA.Day(StartDay - 3)
vArrDates(2, 1) = VBA.Day(StartDay - 4)
Case 6
vArrDates(2, 5) = VBA.Day(StartDay - 1)
vArrDates(2, 4) = VBA.Day(StartDay - 2)
vArrDates(2, 3) = VBA.Day(StartDay - 3)
vArrDates(2, 2) = VBA.Day(StartDay - 4)
vArrDates(2, 1) = VBA.Day(StartDay - 5)
Case 7
vArrDates(2, 6) = VBA.Day(StartDay - 1)
vArrDates(2, 5) = VBA.Day(StartDay - 2)
vArrDates(2, 4) = VBA.Day(StartDay - 3)
vArrDates(2, 3) = VBA.Day(StartDay - 4)
vArrDates(2, 2) = VBA.Day(StartDay - 5)
vArrDates(2, 1) = VBA.Day(StartDay - 6)
End Select
Exit Function
MyErrorTrap:
Beep
End Function
Function RefinishTheForm(ByRef objForm As Object, ByRef sngMarginH As Single, _
ByRef sngMarginW As Single, ByRef sngRatio As Single, _
Optional ByRef HeightCtrl As control, Optional ByRef WidthCtrl As control) As Byte
'Jim Cone - Portland, Oregon USA - copyrighted.
'Provides bottom/right edge margins for userform controls.
'Jan 19, 2013 - Added check for minimum form size.
On Error GoTo NoManners
Application.EnableCancelKey = xlErrorHandler
Dim sngTarget As Single
Dim x As Single
'FORM HEIGHT
If Not HeightCtrl Is Nothing Then
sngTarget = HeightCtrl.Top + HeightCtrl.Height + (sngMarginH * sngRatio)
If sngTarget > objForm.InsideHeight Then
Do
objForm.Height = objForm.Height + 0.8!
If sngTarget < objForm.InsideHeight Then Exit Do
Loop
ElseIf sngTarget < objForm.InsideHeight Then
'x value used to determine if form at smallest size allowed by Excel.
Do
x = objForm.Height
objForm.Height = objForm.Height - 0.8!
If sngTarget > objForm.InsideHeight Or _
objForm.Height = x Then Exit Do
Loop
End If
RefinishTheForm = 1
End If
'FORM WIDTH
If Not WidthCtrl Is Nothing Then
sngTarget = WidthCtrl.Left + WidthCtrl.Width + (sngMarginW * sngRatio)
If sngTarget > objForm.InsideWidth Then
Do
objForm.Width = objForm.Width + 0.7!
If sngTarget < objForm.InsideWidth Then Exit Do
Loop
ElseIf sngTarget < objForm.InsideWidth Then
Do
x = objForm.Width
objForm.Width = objForm.Width - 0.7!
If sngTarget > objForm.InsideWidth Or _
objForm.Width = x Then Exit Do
Loop
End If
RefinishTheForm = 2
End If
Exit Function
NoManners:
Beep
RefinishTheForm = 0
End Function
Function ResizeToRightSize() As Single
'Provides adjustment factor for screen resolution differences.
'Displayed size of form can be altered by changing constant values.
'Jim Cone - Portland, Oregon USA - copyrighted.
'Jun 28, 2012 - Changed screen resolution.
'Jan 19, 2013 - Removed tweaks to sngReturn value.
On Error GoTo DoesNotFit
Dim varSize As Variant
Dim RatioX As Single
Dim RatioY As Single
Dim sngReturn As Single
Const BaseX As Single = 2560! '1920!
Const BaseY As Single = 1440! '1200!
Const Size_Tweaker As Single = 4!
varSize = Array(GetSystemMetrics(0), GetSystemMetrics(1))
RatioX = varSize(0) / BaseX
RatioY = varSize(1) / BaseY
'Both ratios > 1 Or both < 1
If RatioX > 1! Xor RatioY < 1! Then
If RatioX > 1! Then
'Use smallest
If RatioX > RatioY Then
sngReturn = RatioY
Else
sngReturn = RatioX
End If
Else
'Use largest
If RatioX < RatioY Then
sngReturn = RatioY
Else
sngReturn = RatioX
End If
End If
'Const derived from testing at various screen resolutions.
sngReturn = (sngReturn - 1!) / Size_Tweaker + 1!
Else
sngReturn = 1!
End If
ResizeToRightSize = sngReturn
Exit Function
DoesNotFit:
Beep
ResizeToRightSize = 1!
End Function
Sub ShowInsertInfo()
On Error GoTo WrongInfo
Dim strInfo As String
strInfo = "Release 2.0 by xxjamesconexx@gmail.com" & vbCr & _
"'Get Your Own Date' is located in... " & vbCr & _
ThisWorkbook.Path & " " & vbCr & "---------------" & vbCr
strInfo = strInfo & "If you found the program helpful and want to make a" & vbCr & _
"donation (of any amount) go to: https://www.paypal.com"
strInfo = strInfo & vbCr & " Click the Buy tab." & vbCr & " Use " & Chr$(34) & _
"xxjamesconexx@gmail.com " & Chr$(34) & " as the recipient." & vbCr & _
" PayPal accepts credit/debit cards and there is no fee to send money. "
Application.Cursor = xlDefault
MsgBox strInfo, vbInformation, "Get Your Own Date - Copyright 2013"
DoEvents
Exit Sub
WrongInfo:
Beep
Resume Next
End Sub
|
