Mengetahui Tanggal Berada Pada Posisi Minggu Ke Berapa?

Private Function GetDayInWeek(d As Date) As Integer
    Dim dt As Date, i As Integer
    For dt = CDate(Format$(d, "mm/yyyy")) To DateAdd("m", 1, d)
        If Weekday(dt) = 2 Then
            i = i + 1
            If dt > d Then Exit For
        End If
    Next
    GetDayInWeek = i
End Function

READ MORE - Mengetahui Tanggal Berada Pada Posisi Minggu Ke Berapa?

Konversi Masehi Ke Hijriyah Dan Sebaliknya

Private Sub Command2_Click()
    Dim c As Date
    c = CDate("21/12/1945")
    Calendar = vbCalHijri
    MsgBox c
    MsgBox Format(#8/17/1945#, "dddd")
End Sub

Private Sub Command3_Click()
    Dim c As Date
    Calendar = vbCalHijri
    c = CDate("1/1/1455")
    Calendar = vbCalGreg
    MsgBox c
    MsgBox Format(#8/17/1945#, "dddd")
End Sub

READ MORE - Konversi Masehi Ke Hijriyah Dan Sebaliknya

Memperoleh Jumlah Hari Dari Bulan Yang Ditentukan

Private Function DayCount(d As Date) As Integer
    DayCount = Day(DateSerial(Year(d), Month(d) + 1, 0))
End Function

Private Sub Command3_Click()
    MsgBox DayCount(#2/2/2008#)
End Sub

READ MORE - Memperoleh Jumlah Hari Dari Bulan Yang Ditentukan

Merubah Time Zone Secara Pemrograman

Option Explicit

Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Type REGTIMEZONEINFORMATION
    Bias As Long
    StandardBias As Long
    DaylightBias As Long
    StandardDate As SYSTEMTIME
    DaylightDate As SYSTEMTIME
End Type

Private Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(0 To 63) As Byte
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(0 To 63) As Byte
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Private Const TIME_ZONE_ID_INVALID = &HFFFFFFFF
Private Const TIME_ZONE_ID_UNKNOWN = 0
Private Const TIME_ZONE_ID_STANDARD = 1
Private Const TIME_ZONE_ID_DAYLIGHT = 2

Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Function SetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long

Private Const REG_SZ As Long = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD As Long = 4

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003

Private Const ERROR_SUCCESS = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_ARENA_TRASHED = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259

Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpszValueName As String, ByVal lpdwReserved As Long, lpdwType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Const SKEY_NT = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Time Zones"
Const SKEY_9X = "SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones"

Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, lpWideCharStr As Any, ByVal cchWideChar As Long) As Long

Private Const CP_ACP = 0
Private Const MB_PRECOMPOSED = &H1
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)
Dim SubKey As String

Private Sub Form_Load()
    Dim lRetVal As Long, lResult As Long, lCurIdx As Long
    Dim lDataLen As Long, lValueLen As Long, hKeyResult As Long
    Dim strvalue As String
    Dim osV As OSVERSIONINFO

    osV.dwOSVersionInfoSize = Len(osV)
    Call GetVersionEx(osV)
    If osV.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        SubKey = SKEY_NT
    Else
        SubKey = SKEY_9X
    End If

    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, KEY_ALL_ACCESS, hKeyResult)

    If lRetVal = ERROR_SUCCESS Then

        lCurIdx = 0
        lDataLen = 32
        lValueLen = 32

        Do
            strvalue = String(lValueLen, 0)
            lResult = RegEnumKey(hKeyResult, lCurIdx, strvalue, lDataLen)

            If lResult = ERROR_SUCCESS Then
                List1.AddItem Left(strvalue, lValueLen)
            End If

            lCurIdx = lCurIdx + 1

        Loop While lResult = ERROR_SUCCESS

        RegCloseKey hKeyResult
    Else
        List1.AddItem "Could not open registry key"
    End If
End Sub

Private Sub List1_DblClick()
    Dim TZ As TIME_ZONE_INFORMATION, oldTZ As TIME_ZONE_INFORMATION
    Dim rTZI As REGTIMEZONEINFORMATION
    Dim bytDLTName(32) As Byte, bytSTDName(32) As Byte
    Dim cbStr As Long, dwType As Long
    Dim lRetVal As Long, hKeyResult As Long, lngData As Long

    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey & "\" & List1.Text, 0, KEY_ALL_ACCESS, hKeyResult)

    If lRetVal = ERROR_SUCCESS Then
        lRetVal = RegQueryValueEx(hKeyResult, "TZI", 0&, ByVal 0&, rTZI, Len(rTZI))

        If lRetVal = ERROR_SUCCESS Then
            TZ.Bias = rTZI.Bias
            TZ.StandardBias = rTZI.StandardBias
            TZ.DaylightBias = rTZI.DaylightBias
            TZ.StandardDate = rTZI.StandardDate
            TZ.DaylightDate = rTZI.DaylightDate

            cbStr = 32
            dwType = REG_SZ

            lRetVal = RegQueryValueEx(hKeyResult, "Std", 0&, dwType, bytSTDName(0), cbStr)

            If lRetVal = ERROR_SUCCESS Then
                Call MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, bytSTDName(0), cbStr, TZ.StandardName(0), 32)
            Else
                RegCloseKey hKeyResult
                Exit Sub
            End If

            cbStr = 32
            dwType = REG_SZ

            lRetVal = RegQueryValueEx(hKeyResult, "Dlt", 0&, dwType, bytDLTName(0), cbStr)

            If lRetVal = ERROR_SUCCESS Then
                Call MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, bytDLTName(0), cbStr, TZ.DaylightName(0), 32)
            Else
                RegCloseKey hKeyResult
                Exit Sub
            End If

            lRetVal = GetTimeZoneInformation(oldTZ)

            If lRetVal = TIME_ZONE_ID_INVALID Then
                MsgBox "Error getting original TimeZone Info"
                RegCloseKey hKeyResult
                Exit Sub
            Else
                If TZ.DaylightDate.wMonth <> 0 And TZ.DaylightBias <> 0 Then
                    lRetVal = SetTimeZoneInformation(TZ)
                Else
                    Call CopyMemory(TZ.DaylightName(0), TZ.StandardName(0), 64)
                    TZ.DaylightBias = 0
                    lRetVal = SetTimeZoneInformation(TZ)
                End If
                MsgBox "Time Zone Changed, Click OK to restore"
                lRetVal = SetTimeZoneInformation(oldTZ)
            End If
        End If

        RegCloseKey hKeyResult
    End If
End Sub

READ MORE - Merubah Time Zone Secara Pemrograman