Code:
Option Explicit ' “Window"s is a name for a programming idea which might result in something we “see” as what we conceive as Windows. Manipulating of the actual “Windows” seems the key to pseudo “making my own” InputBox with range selection. Direct linked libraries (dll) are available to run as and when required, hence the wording of direct link: They are used as an efficient means to organise Microsoft’s software generally allowing different Applications to share smaller programs which are shipped as standard with the Microsoft Windows Operating system. They are however also available to programmers , programming the applications. They are usually contained in Folder with name similar to User 32. "API calls”: just means usually that you are using those things and related “Windows” concept-all gets gets bundled up in imprecise intimidating term API, for Application Programming interface
Public Declare Function APIsinUserDLL_MsgBox Lib "user32.dll" Alias "MessageBoxTimeoutA" (Optional ByVal hWnd As Long, Optional ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal uType As Long, Optional ByVal wLanguageID As Long, Optional ByVal Delay_ms As Long) As Long
Private Sub WhatsInMyGlobies() '
Dim WndNumber As Long
APIsinUserDLL_MsgBox hWnd:=WndNumber, Prompt:="Using DateSerial(2021, 12, 1) inside VBA will give" & vbCr & vbLf & vbCr & DateSerial(2021, 12, 1), Title:="NonModalPopUpThingy", uType:=4, wLanguageID:=0, Delay_ms:=5000 ' ' The error will occur if I do not have a pro open so the MsgBox line will error at ProWb.Name
End Sub
Sub MessinMitdates()
Rem 1 Attempt to get the sShortDate from registry via DateSerial( ) implification way
On Error GoTo Bed
Dim TestDateSerial As String
Let TestDateSerial = DateSerial(9, 3, 4) ' DateSerial(year, month, day) https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dateserial-function
' By experimenting, it appears that for the day and month, if the sShortDate in the registry needs more than one character then a zero is added to that retuned by DateSerial(9, 3, 4) For the year any missing characters seem to be relplaced by a 0 2 or 1 - For this reason I don't use 1 or 2 for the day or month becuse if i do , there may be some wrong determination below: We use the number to determine if we have a day or month or year
If InStr(1, TestDateSerial, "9", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Year in your short date format": Exit Sub
If InStr(1, TestDateSerial, "3", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Month number in your short date format": Exit Sub
If InStr(1, TestDateSerial, "4", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Day number in your short date format": Exit Sub
Dim C As Variant ' This is each character. It can be a number or letter, so I used Variant but string would work also
Dim Cnt As Long: Let Cnt = 1
Let C = Mid(TestDateSerial, Cnt, 1) ' ========= start of returned string
Do While IsNumeric(C) = True
Let Cnt = Cnt + 1 ' we are counting through the characters, (numbers), from the start, while we have a number. So we are counting the first number section
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = True
Dim Cnt1 As Long: Let Cnt1 = Cnt - 1 ' this will be the count of the characters ( numbers ) in the first number section
' =============================================
Dim Sep1 As String
Do While IsNumeric(C) = False
Let Sep1 = Sep1 & C ' In the first seperator
Let Cnt = Cnt + 1 ' we are counting through the character in the thing used as the first seperator. (These should not be numbers)
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = False
Dim DMY As String ' At this point we have reached the end of the first seperator,
' the next lines search the numbers in the first number section to determine if they are a day or month or year
If InStr(1, Left(TestDateSerial, Cnt - 1), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we are actually looking at the first number and first seperator, but never ming
If InStr(1, Left(TestDateSerial, Cnt - 1), "3", vbBinaryCompare) <> 0 Then Let DMY = "m"
If InStr(1, Left(TestDateSerial, Cnt - 1), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Dim sShortDate As String ' the next line gives us a character string where the fist numbers are replaced by characters representing if they are a day or month or year
Let sShortDate = Evaluate("=REPT(""" & DMY & """," & Cnt1 & ")") & Sep1 ' ======= make first bit of output ==
' ===== xx & sep1 ******************************************
Dim Pos2 As Long ' ============================================================================================
Let Pos2 = Len(sShortDate) + 1 ' This should be the position where the second number section starts
Do While IsNumeric(C) = True
Let Cnt = Cnt + 1 ' we are counting the characters ( numbers ) in the second ( middle ) character ( number ) section
Let C = Mid(TestDateSerial, Cnt, 1)
Loop
Dim Cnt2 As Long: Let Cnt2 = Cnt - Pos2 ' this will be the count of the characters ( numbers ) in the second ( middle ) number section
' ========================== at first character in second seperator ========================================
Dim Sep2 As String
Do While IsNumeric(C) = False
Let Sep2 = Sep2 & C '
Let Cnt = Cnt + 1 ' we are counting through the characters making up the second seperator
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = False
' the Cnt C counting stops at the start of the last number section
' the next lines search the numbers in the second ( middle) number section to determine if they are a day or month or year
' at this point we have got the second seperator string, Sep2 and are at the start of the last number ===
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we are looking in the middle number section
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "3", vbBinaryCompare) <> 0 Then Let DMY = "m"
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Let sShortDate = sShortDate & Evaluate("=REPT(""" & DMY & """," & Cnt2 & ")") & Sep2 ' this adds to the sShortDate string the characters to indicate the type ( day month or year ) of the middle section numbers and the second seperator
' ==== xx & Sep1 & yy & Sep2 *******************************************
Dim Pos3 As Long: Let Pos3 = Len(sShortDate) + 1 ' this should be the start position of the last number section
Dim Cnt3 As Long '
Let Cnt3 = Len(TestDateSerial) - Pos3 + 1 ' this should be the number of characters ( numbers ) in the last number section
' we don't bother to loop through the last number section
' the next lines search the numbers in the third ( last ) number section to determine if they are a day or month or year
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we look from the start of the last number section, Pos3 , for a length of its count of its characters , Cnt3
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "3", vbBinaryCompare) <> 0 Then Let DMY = "m"
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Let sShortDate = sShortDate & Evaluate("=REPT(""" & DMY & """," & Cnt3 & ")") ' finally we add the characters representing the characters to indicate the type ( day month or year ) of the last section
' ===== xx & Sep1 & yy & Sep2 & zzz *************************************************************************
' =============================================================================================================
GoTo Rem2
Bed: ' Error handling code section for if the above coding errored
Let sShortDate = "Error getting sShortDate"
On Error GoTo -1
Rem2: ' Rem 2 Some other computer and user info
On Error Resume Next ' In case info below is somehow protected
Dim UsrNme As String: Let UsrNme = Application.UserName: Let UsrNme = Environ("username")
Dim CmprNme As String: Let CmprNme = Environ("computername")
Dim WOS As String: Let WOS = Environ("OS")
Dim VersXl As String: Let VersXl = " ( " & ExcelVersion & " ) "
On Error GoTo 0
Rem 3 Shift a space for some info, and some formating
With Worksheets("Dates")
.Range("A1:B15").Insert , shift:=xlShiftDown
.Range("A1:B15").Clear
.Columns("A").Font.Size = 12
.Columns("A").ColumnWidth = 16
.Columns("B").Font.Size = 8
.Columns("B").ColumnWidth = 190
End With
With Worksheets("Dates").Range("A1:B1000")
.Item(1).Value = " " & UsrNme & " " & Format(Now(), "dddd, dd, mmm, yyyy. ") & Format(Now(), "hh") & "hr " & Right(Format(Now(), "hh mm"), 2) & "min" & " " & VersXl
.Item(3).Value = sShortDate: .Item(4).Value = " <---- " & CmprNme & " Registry sShortDate"
.Item(5).Value = DateSerial(2021, 12, 1): .Item(6).Value = "DateSerial(2021, 12, 1) for 1st dec 2021 was assigned to .Value of virgin cell. The .Value of the cell is returned as " & .Item(5).Value & " The .Value2 is returned as " & .Item(5).Value2 & ""
.Item(7).NumberFormat = "m/d/yyyy"
.Item(7).Value = DateSerial(2021, 12, 1): .Item(8) = "DateSerial(2021, 12, 1) for 1st Dec 2021 was assigned to .Value of cell formated in Short Date, using .NumberFormat = ""m/d/yyyy"" The .Value of the cell is " & .Item(7).Value & " The .Value2 is " & .Item(7).Value2 & ""
.Item(7).NumberFormat = "m/d/yyyy"
.Item(9).NumberFormat = "@"
.Item(9).Value = DateSerial(2021, 12, 1): .Item(10) = "DateSerial(2021, 12, 1) for 1st Dec 2021 was assigned to .Value of cell formated in Text, using .NumberFormat = ""@"" The .Value of the cell is " & .Item(9).Value & " The .Value2 is " & .Item(9).Value2 & ""
.Item(9).NumberFormat = "@"
Dim DteSerial As String: Let DteSerial = DateSerial(2021, 12, 1)
.Item(11).Value = DteSerial: .Item(12).Value = "I have not done anything to the format of the cell, its a virgin cell, but I first put what came from DateSerial(2021, 12, 1) into a string variable, DteSerial , and then asigned that string variable to the cell .Value The .Value of the cell is " & .Item(11).Value & " The .Value2 is " & .Item(11).Value2 & ""
.Item(13).NumberFormat = "m/d/yyyy"
.Item(13).Value = DteSerial: .Item(14).Value = "The cell is formattted as short date format using .NumberFormat = ""m/d/yyyy"" I am assigning the filled variable Dteserial to it. The .Value of the cell is " & .Item(13).Value & " the .Value2 is " & .Item(13).Value2 & ""
.Item(13).NumberFormat = "m/d/yyyy"
' Say in a self cancelling meassage box what the DateSerial(2021, 12, 1) returns in VBA
Dim WndNumber As Long:
APIsinUserDLL_MsgBox hWnd:=WndNumber, Prompt:="Using DateSerial(2021, 12, 1) inside VBA will give" & vbCr & vbLf & vbCr & DateSerial(2021, 12, 1), Title:="This will close itself after a few seconds", uType:=4, wLanguageID:=0, Delay_ms:=4000 ' ' The error will occur if I do not have a pro open so the MsgBox line will error at ProWb.Name
DoEvents: DoEvents
.Item(17).Value2 = 44531: .Item(17).NumberFormat = "m/d/yyyy": .Item(18).Value = "a .Value2 of 44531(this is the Excel number for 1stDec,2021) was put in a virgin cell, which then was given the cell format of Short Date, using .NumberFormat = ""m/d/yyyy"" "
.Item(19).Value2 = 44531: .Item(19).NumberFormat = "m\/d\/yyyy": .Item(20).Value = "a .Value2 of 44531 was put in a virgin cell, which then was given the cell format of .NumberFormat = ""m\/d\/yyyy"" "
.Item(21).Value = Format("12 1 2021", "dd_mm_yyyy"): .Item(22).Value = "For a virgin cell I assigned like this .Item(21).Value = Format(""12 1 2021"", ""dd_mm_yyyy"") The .Value frtom the cell is " & .Item(21).Value & " and the .Value2 is " & .Item(21).Value2 & ""
.Item(23).Value = Format(#12/1/2021#, "dd_mm_yyyy"): .Item(24).Value = "For a virgin cell I tried to assign this .Item(23).Value = Format(#12 - 1 .2021#, ""dd_mm_yyyy"") m When I hit Enter I did not get any error, but that was changed to Format(#12/1/2021#, ""dd_mm_yyyy"") What seems to be happeming there is that Excel tries to coerce the string inside a # pair into the standard English American format. So it sees #12/1/2021# as December 1st, 2021 and gives me the date in the format I ask for. The .Value from the cell is " & .Item(23).Value & " and the .Value2 is " & .Item(23).Value2 & ""
.Item(25).Value = Format(#12/1/2021#, "m/d/yyyy"): .Item(26).Value = "For a virgin cell I assigned .Item(25).Value = Format(#12/1/2021#, ""m/d/yyyy"") The .Value from the cell is " & .Item(25).Value & " and the .Value2 is " & .Item(25).Value2 & ""
.Item(27).Value = Format(#12/1/2021#, "m\/d\/yyyy"): .Item(28).Value = "For a virgin cell I assigned .Item(27).Value = Format(#12/1/2021#, ""m\/d\/yyyy"") The .Value from the cell is " & .Item(27).Value & " and the .Value2 is " & .Item(27).Value2 & ""
End With
'______________________________________________________________________________________________________________
ThisWorkbook.Save
End Sub
' From Rory's A Tool
Public Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case CLng(Val(Application.Version))
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "Excel 2016 (Mac)"
Case Else: temp = "Unknown"
End Select
#Else
Select Case CLng(Val(Application.Version))
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case 16: temp = "Excel 2016, 2019 0r 365 (Windows)"
Case Else: temp = "Unknown"
End Select
#End If
#If Win64 Then
temp = temp & " 64 bit"
#Else
temp = temp & " 32 bit"
#End If
Let ExcelVersion = temp
End Function
Reply With Quote
Originally Posted by Broesel
Bookmarks