SnippetWare.com » System

Obtain the Regional Settings for the System

Zaur — Sun, 11 Oct 2009 12:59:38 +0000

Option Explicit
' Locale Class
' obtain the Regional Settings for the System.
' ensure that all displays etc are correct for the country of use
'
' Locale Constants
Private Const LOCALE_SDECIMAL As Long = &HE
Private Const LOCALE_SLONGDATE As Long = &H20
Private Const LOCALE_SSHORTDATE As Long = &H1F
Private Const LOCALE_SCURRENCY As Long = &H14
Private Const LOCALE_STHOUSAND As Long = &HF
Private Const LOCALE_SINTLSYMBOL As Long = &H15
Private Const LOCALE_STIMEFORMAT As Long = &H1003
Private Const LOCALE_SNEGATIVESIGN = &H51
Private Const LOCALE_SPOSITIVESIGN = &H50
Private Const LOCALE_SCOUNTRY As Long = &H6
Private Const LOCALE_SDAYNAME1 As Long = &H2A
Private Const LOCALE_SDAYNAME2 As Long = &H2B
Private Const LOCALE_SDAYNAME3 As Long = &H2C
Private Const LOCALE_SDAYNAME4 As Long = &H2D
Private Const LOCALE_SDAYNAME5 As Long = &H2E
Private Const LOCALE_SDAYNAME6 As Long = &H2F
Private Const LOCALE_SDAYNAME7 As Long = &H30
Private Const LOCALE_SENGCOUNTRY As Long = &H1002
Private Const LOCALE_SENGLANGUAGE As Long = &H1001
Private Const LOCALE_SLANGUAGE As Long = &H2
Private Const LOCALE_SMONTHNAME1 As Long = &H38
Private Const LOCALE_SMONTHNAME10 As Long = &H41
Private Const LOCALE_SMONTHNAME11 As Long = &H42
Private Const LOCALE_SMONTHNAME12 As Long = &H43
Private Const LOCALE_SMONTHNAME2 As Long = &H39
Private Const LOCALE_SMONTHNAME3 As Long = &H3A
Private Const LOCALE_SMONTHNAME4 As Long = &H3B
Private Const LOCALE_SMONTHNAME5 As Long = &H3C
Private Const LOCALE_SMONTHNAME6 As Long = &H3D
Private Const LOCALE_SMONTHNAME7 As Long = &H3E
Private Const LOCALE_SMONTHNAME8 As Long = &H3F
Private Const LOCALE_SMONTHNAME9 As Long = &H40
Private Const LOCALE_SABBREVCTRYNAME = &H7
Private Const LOCALE_SABBREVDAYNAME1 = &H31
Private Const LOCALE_SABBREVDAYNAME3 = &H33
Private Const LOCALE_SABBREVDAYNAME2 = &H32
Private Const LOCALE_SABBREVDAYNAME4 = &H34
Private Const LOCALE_SABBREVDAYNAME5 = &H35
Private Const LOCALE_SABBREVDAYNAME6 = &H36
Private Const LOCALE_SABBREVDAYNAME7 = &H37
Private Const LOCALE_SABBREVLANGNAME = &H3
Private Const LOCALE_SABBREVMONTHNAME1 = &H44
Private Const LOCALE_SABBREVMONTHNAME10 = &H4D
Private Const LOCALE_SABBREVMONTHNAME11 = &H4E
Private Const LOCALE_SABBREVMONTHNAME12 = &H4F
Private Const LOCALE_SABBREVMONTHNAME13 = &H100F
Private Const LOCALE_SABBREVMONTHNAME2 = &H45
Private Const LOCALE_SABBREVMONTHNAME3 = &H46
Private Const LOCALE_SABBREVMONTHNAME4 = &H47
Private Const LOCALE_SABBREVMONTHNAME5 = &H48
Private Const LOCALE_SABBREVMONTHNAME6 = &H49
Private Const LOCALE_SABBREVMONTHNAME7 = &H4A
Private Const LOCALE_SABBREVMONTHNAME8 = &H4B
Private Const LOCALE_SABBREVMONTHNAME9 = &H4C
Private Const LOCALE_SNATIVECTRYNAME = &H8
Private Const LOCALE_SNATIVELANGNAME = &H4
Private Const LOCALE_USER_DEFAULT As Long = &H400

' API Declarations for the Locale Methods
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal lLocale As Long, ByVal lLocaleType As Long, ByVal sLCData As String, ByVal lBufferLength As Long) As Long
Private Declare Function GetSystemDefaultLangID Lib "kernel32" () As Integer
Private Declare Function VerLanguageName Lib "kernel32" Alias "VerLanguageNameA" (ByVal wLang As Long, ByVal szLang As String, ByVal nSize As Long) As Long
'------------------
' Public Properties
'------------------
Public Property Get DateFormat() As String
    ' This function will return the Locale date format for the system. Note that the
    ' returned Year is always formatted to 'YYYY' regardless, to ensure Y2k compliance.
    On Error GoTo vbErrorHandler
    DateFormat = GetLocaleString(LOCALE_SSHORTDATE)
    ' Make sure we always have YYYY format for y2k
    If InStr(1, DateFormat, "YYYY", vbTextCompare) = 0 Then DateFormat = Replace(DateFormat, "YY", "YYYY")
Exit Property
vbErrorHandler:
    Err.Raise Err.Number, "CGLocaleInfo GetDateFormat", Err.Description
End Property

Public Property Get TimeFormat() As String
    'This function returns the locale's defined Time Format.
    TimeFormat = Left(GetLocaleString(LOCALE_STIMEFORMAT), 
Exit Property
vbErrorHandler:
    Err.Raise Err.Number, "CGLocaleInfo GetTimeFormat", Err.Description
End Property

Public Property Get NumberFormat() As String
' This function returns the Locales defined Decimal Number format
    On Error GoTo vbErrorHandler
    NumberFormat = "##" & ThousandSpecifier & "##0" & DecimalSpecifier & "00"
Exit Property
vbErrorHandler:
    NumberFormat = "##,##,0.00" 'Set a Default
End Property

Public Property Get ThousandSpecifier() As String
    'This function returns the correct Thousand Specifier for the system Locale
    ThousandSpecifier = GetLocaleString(LOCALE_STHOUSAND)
End Property

Public Property Get DecimalSpecifier() As String
    'This function returns the correct Decimal Specifier for the system Locale
    DecimalSpecifier = GetLocaleString(LOCALE_SDECIMAL)

End Property

Public Property Get CurrencySpecifier() As String
    'This function returns the correct Currency Specifier for the system Locale
    CurrencySpecifier = GetLocaleString(LOCALE_SCURRENCY)
End Property

Public Property Get SysLanguageID() As Long
    'Returns the System Language ID for the machine
    SysLanguageID = GetSystemDefaultLangID
End Property

Public Property Get SysLanguageName() As String
    'Returns the System Language Name eg : English (United Kingdom)
    Dim lLangID As Long
    Dim sBuffer As String
    Dim lBuffSize As Long
    Dim lRet As Long

    On Error GoTo vbErrorHandler

    lLangID = GetSystemDefaultLangID
    'Setup a buffer to receive the settings
    lBuffSize = 50
    sBuffer = String$(lBuffSize, vbNullChar)
    lRet = VerLanguageName(lLangID, sBuffer, lBuffSize)
    If lRet > 0 Then
        SysLanguageName = Left$(sBuffer, lRet)
    End If
Exit Property
vbErrorHandler:
    Err.Raise Err.Number, "CGLocaleInfo GetSysLanguageName", Err.Description
End Property

Public Property Get Country() As String
    'Returns the Country Name eg. 'United Kingdom'
    Country = GetLocaleString(LOCALE_SENGCOUNTRY)
End Property

Public Property Get LanguageName() As String
    'Returns the Native Language Name eg. 'English'
    LanguageName = GetLocaleString(LOCALE_SNATIVELANGNAME)
End Property

Public Property Get NativeCountryName() As String
    NativeCountryName = GetLocaleString(LOCALE_SNATIVECTRYNAME)
End Property

Public Property Get PositiveSign() As String
    'Returns the symbol used for the positive sign eg. +
    PositiveSign = GetLocaleString(LOCALE_SPOSITIVESIGN)
End Property

Public Property Get NegativeSign() As String
' Returns the symbol used for the negative sign eg. -
    NegativeSign = GetLocaleString(LOCALE_SNEGATIVESIGN)
End Property

'-----------------
' Public Functions
'-----------------
Public Function DayName(ByVal iDayNum As Integer, Optional Short As Boolean = False) As String
    DayName = IIf(Short, GetLocaleString(LOCALE_SABBREVDAYNAME1 + iDayNum - 1), GetLocaleString(LOCALE_SDAYNAME1 + iDayNum - 1))
End Function

Public Function MonthName(ByVal iMonthNum As Integer, Optional Short As Boolean = False) As String
    MonthName = IIf(Short, GetLocaleString(LOCALE_SABBREVMONTHNAME1 - 1 + iMonthNum), GetLocaleString(LOCALE_SMONTHNAME1 + iMonthNum - 1))
End Function

'------------------
' Private Functions
'------------------
Private Function GetLocaleString(ByVal lLocaleNum As Long) As String
    'Generic routine to get the locale string from the Operating system.
    Dim lBuffSize As String
    Dim sBuffer As String
    Dim lRet As Long

    lBuffSize = 256
    sBuffer = String$(lBuffSize, vbNullChar)

    'Get the information from the registry
    lRet = GetLocaleInfo(LOCALE_USER_DEFAULT, lLocaleNum, sBuffer, lBuffSize)
    'If lRet > 0 then success - lret is the size of the string returned
    If lRet > 0 Then
        GetLocaleString = Left$(sBuffer, lRet - 1)
    End If
End Function

Retrieve various System / Windows Info

Zaur — Sun, 11 Oct 2009 12:59:06 +0000

Option Explicit

'Windows System Information Constants
Private Const SQL_SUCCESS As Long = 0
Private Const SQL_FETCH_NEXT = 1
Private Const SQL_FETCH_FIRST_SYSTEM = 32

Private Const SECS_PER_DAY As Long = 86000
Private Const MINS_PER_DAY As Long = 1400

'Enumerated Types
Public Enum ControlPanelTypes
    cplSystem = 1
    cplInternet = 2
    cplModem = 3
    cplSoftware = 4
    cplHardware = 5
    cplSounds = 6
    cplNetwork = 7
    cplMouse = 8
    cplKeyboard = 9
    cplDateTime = 10
    cplRegional = 11
    cplPassword = 12
    cplDisplay = 13
End Enum

Public Enum DIR_TYPE
    dirWINDOWS
    dirSYSTEM
    dirTEMP
End Enum

Public Enum DRIVE_TYPE
    DRIVE_DOESNT_EXIST = 1
    DRIVE_REMOVABLE = 2
    DRIVE_FIXED = 3
    DRIVE_REMOTE = 4
    DRIVE_CDROM = 5
    DRIVE_RAMDISK = 6
End Enum

Public Enum enStockIcons
    IDI_APPLICATION = 32512&
    IDI_ASTERISK = 32516&
    IDI_EXCLAMATION = 32515&
    IDI_HAND = 32513&   'This is the STOP icon
    IDI_QUESTION = 32514&
End Enum

Public Enum OS_VERSION
    OS_WINDOWS_UNKNOWN
    OS_WINDOWS_3X
    OS_WINDOWS_95
    OS_WINDOWS_98
    OS_WINDOWS_NT3X
    OS_WINDOWS_NT40
    OS_WINDOWS_2000
End Enum

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

Private Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type

Public Enum ShutdownType
    Logoff = 0
    ByeBye = 1
    Reboot = 2
End Enum

Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2

Private Const BITSPIXEL = 12
Private Const PLANES = 14

' API Declarations for the Locale Methods
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
'API Functions
Private Declare Function DrawIconApi Lib "user32" Alias "DrawIcon" (ByVal HDC As Long, ByVal x As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal HDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFOEX) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpSFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function LoadIconApi Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function SQLAllocEnv Lib "odbc32.dll" (phenv As Long) As Integer
Private Declare Function SQLDataSources Lib "odbc32.dll" (ByVal hEnv As Long, ByVal fDirection As Integer, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN As Integer, ByVal szDescription As String, ByVal cbDescriptionMax As Integer, pcbDescription As Integer) As Integer
Private Declare Function SQLFreeEnv Lib "odbc32.dll" (ByVal hEnv As Long) As Integer
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long

Private pUdtOSVersion As OSVERSIONINFOEX
Private pUdtMemStatus As MEMORYSTATUS

Private plMajorVersion  As Long
Private plMinorVersion As Long
Private plPlatformID As Long

Private psComputerName As String
Private plLastDllError As Long

'-----------------
'Public Properties
'-----------------
Public Property Get Name() As String
    Dim sBuffer As String
    Dim lAns As Long

    plLastDllError = 0
    sBuffer = Space$(255)
    lAns = GetComputerName(sBuffer, 255)
    If lAns <> 0 Then
        'read from beginning of string to null-terminator
        Name = Left$(sBuffer, InStr(sBuffer, Chr(0)) - 1)
    Else
        plLastDllError = Err.LastDllError
    End If
End Property

Public Property Get CurrentUser() As String
    Dim l As Long
    Dim sUser As String

    plLastDllError = 0
    sUser = Space(255)
    l = GetUserName(sUser, 255)
    'strip null terminator
    If l <> 0 Then
        CurrentUser = Left(sUser, InStr(sUser, Chr(0)) - 1)
    Else
        plLastDllError = Err.LastDllError
    End If
End Property

Public Property Get MaxScreenColors() As Double
    'Returns the maximum number of colors supported
    'by the system - e.g.,  256, 16,777,216
    Dim lngBits As Long
    Dim lngPlanes As Long
    Dim lwndHandle As Long
    Dim dblAns As Double
    plLastDllError = 0
    lwndHandle = Form1.HDC
    'bits per pixel
    lngBits = GetDeviceCaps(lwndHandle, BITSPIXEL)
    'number of color planes
    lngPlanes = GetDeviceCaps(lwndHandle, PLANES)
    'maximum colors available
    MaxScreenColors = (2 ^ (lngBits * lngPlanes))
    plLastDllError = Err.LastDllError
End Property

Public Property Get OSVersion() As OS_VERSION
    On Error GoTo ErrorHandler

    plLastDllError = 0
    Select Case plMajorVersion
        Case 5: OSVersion = OS_WINDOWS_2000 'UNTESTED
        Case 4
            If plPlatformID = VER_PLATFORM_WIN32_NT Then
                OSVersion = OS_WINDOWS_NT40
            Else
                OSVersion = IIf(plMinorVersion = 0, OS_WINDOWS_95, OS_WINDOWS_98)
            End If
        Case 3
            If plPlatformID = VER_PLATFORM_WIN32s Then
                OSVersion = OS_WINDOWS_3X
            ElseIf plPlatformID = VER_PLATFORM_WIN32_NT Then
                OSVersion = OS_WINDOWS_NT40
            End If
        Case Else:  OSVersion = OS_WINDOWS_UNKNOWN
    End Select
Exit Property
ErrorHandler:
    OSVersion = OS_WINDOWS_UNKNOWN
    plLastDllError = Err.LastDllError
End Property

Public Property Get ScreenPixelWidth() As Integer
    plLastDllError = 0
    ScreenPixelWidth = Screen.Width \ Screen.TwipsPerPixelX
End Property

Public Property Get ScreenPixelHeight() As Integer
    plLastDllError = 0
    ScreenPixelHeight = Screen.Height \ Screen.TwipsPerPixelY
End Property

Public Property Get ScreenResolution() As String
    plLastDllError = 0
    ScreenResolution = ScreenPixelWidth & "x" & ScreenPixelHeight
End Property

Public Property Get SystemErrorCode() As Long
    SystemErrorCode = plLastDllError
End Property

Public Property Get SoundCard() As Boolean
     SoundCard = waveOutGetNumDevs > 0
End Property
'----------------
'Public Functions
'----------------
Public Function AboutBox(Optional hWndA As Long = -1, Optional Copyright As String, Optional ProductInfo As String, Optional Icon As Long = 0)
    If Len(Copyright) = 0 Then Copyright = Common.Version() & "#" & App.ProductName
    If Len(ProductInfo) = 0 Then
        If Len(App.LegalTrademarks) > 0 And Len(App.CompanyName) > 0 Then
            ProductInfo = App.LegalTrademarks
            ProductInfo = ProductInfo & " are legal trademarks of "
            ProductInfo = ProductInfo & App.CompanyName
        Else
            ProductInfo = ProjectName
            ProductInfo = ProductInfo & " is a legal trademark of "
            ProductInfo = ProductInfo & IIf(Len(App.CompanyName) > 0, App.CompanyName, "FailSafe Systems")
        End If
    End If
    Call ShellAbout(hWndA, Copyright, ProductInfo, Icon)
End Function

Public Function APIFunctionPresent(ByVal FunctionName As String, ByVal DLLName As String) As Boolean
    'USAGE: Dim bAvail as boolean
    '       bAvail = APIFunctionPresent("GetDiskFreeSpaceExA", "kernel32")
    Dim lHandle As Long
    Dim lAddr  As Long
    lHandle = LoadLibrary(DLLName)
    If lHandle <> 0 Then
        lAddr = GetProcAddress(lHandle, FunctionName)
        FreeLibrary lHandle
    End If
    APIFunctionPresent = (lAddr <> 0)
End Function

Public Sub CascadeWindows()
' TODO:
'    Dim objShell As New Shell32.Shell
'    objShell.CascadeWindows
'    Set objShell = Nothing
End Sub

Public Function ControlPanel(Setting As ControlPanelTypes) As Long
    Dim lPanel As String
    Select Case Setting
        Case cplSoftware:   lPanel = "appwiz.cpl,,1"
        Case cplHardware:   lPanel = "sysdm.cpl @1"
        Case cplInternet:   lPanel = "inetcpl.cpl,,0"
        Case cplKeyboard:   lPanel = "main.cpl @1"
        Case cplModem:      lPanel = "modem.cpl"
        Case cplMouse:      lPanel = "main.cpl @0"
        Case cplNetwork:    lPanel = "netcpl.cpl"
        Case cplSounds:     lPanel = "mmsys.cpl @1"
        Case cplSystem:     lPanel = "sysdm.cpl,,0"
        Case cplDisplay:    lPanel = "desk.cpl,,0"
        Case cplPassword:   lPanel = "password.cpl"
        Case cplRegional:   lPanel = "intl.cpl,,0"
        Case cplDateTime:   lPanel = "timedate.cpl"
    End Select
    If Len(lPanel) > 0 Then ControlPanel = Shell("rundll32.exe shell32.dll,Control_RunDLL " & lPanel, 5)
    plLastDllError = Err.LastDllError
End Function

Public Function Directory(WhichDir As DIR_TYPE) As String
    Dim Temp As String
    Dim Ret As Long
    Const MAX_LENGTH = 255

    Temp = String$(MAX_LENGTH, 0)
    Select Case WhichDir
        Case dirWINDOWS:    Ret = GetWindowsDirectory(Temp, MAX_LENGTH)
        Case dirSYSTEM:     Ret = GetSystemDirectory(Temp, MAX_LENGTH)
        Case dirTEMP:       Ret = GetTempPath(Len(Temp), Temp)
        Case Else:          Ret = 0: Temp = ""
    End Select
    Directory = PathCheck(Left$(Temp, Ret))
End Function

Public Function DriveMBFree(Optional Drive As String = "C:\") As Double
    'some time in the future disk may be to large to calculate
    'like this so resume next on any errors
    On Error Resume Next

    Dim lAns As Long
    Dim lSectorsPerCluster As Long
    Dim lBytesPerSector As Long

    Dim lFreeClusters As Long
    Dim lTotalClusters As Long
    Dim lBytesPerCluster As Long
    Dim lFreeBytes As Double

    'fix bad parameter values
    If Len(Drive) = 1 Then Drive = Drive & ":\"
    If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"

    lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
    lBytesPerCluster = lSectorsPerCluster * lBytesPerSector

    DriveMBFree = ((lBytesPerCluster / 1024) / 1024) * lFreeClusters
    DriveMBFree = Format(DriveMBFree, "###,###,##0.00")
End Function

Public Function DriveMBSize(Optional Drive As String = "C:\") As Double
    'some time in the future disk may be to large to calculate
    'like this so resume next on any errors
    On Error Resume Next

    Dim lAns As Long
    Dim lSectorsPerCluster As Long
    Dim lBytesPerSector As Long

    Dim lFreeClusters As Long
    Dim lTotalClusters As Long
    Dim lBytesPerCluster As Long
    Dim lTotalBytes As Double

    'fix bad parameter values
    If Len(Drive) = 1 Then Drive = Drive & ":\"
    If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"

    lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
    lBytesPerCluster = lSectorsPerCluster * lBytesPerSector

    DriveMBSize = ((lBytesPerCluster / 1024) / 1024) * lTotalClusters
    DriveMBSize = Format(DriveMBSize, "###,###,##0.00")
End Function

Public Function DriveName(Optional Drive As String = "C:\")
    Dim sBuffer As String

    plLastDllError = 0
    sBuffer = Space$(255)
    'fix bad parameter values
    If Len(Drive) = 1 Then Drive = Drive & ":\"
    If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"
    If GetVolumeInformation(Drive, sBuffer, Len(sBuffer), 0, 0, 0, Space$(255), 255) = 0 Then
        plLastDllError = Err.LastDllError
    Else
        DriveName = Left$(sBuffer, InStr(sBuffer, Chr$(0)) - 1)
    End If
End Function

Public Function DriveType(Drive As String) As DRIVE_TYPE
    'fix bad parameter values
    DriveType = DRIVE_DOESNT_EXIST
    plLastDllError = 0
    Drive = IIf(Len(Drive) = 1, Drive & ":", Drive)
    If Len(Drive) = 1 Then Drive = Drive & ":\"
    If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"
    Drive = PathCheck(Drive)
    DriveType = GetDriveType(Drive)
    plLastDllError = Err.LastDllError
End Function

Public Sub DSNs(DSNArray() As String)
    'POPULATES DSNARRAY WITH ALL DSNs installed on the system,
    'in the form of "DSN | DRIVER"
    'USAGE:
    'Dim asDSNArray() As String
    'Dim iCtr As Integer
    'SystemDSNs asDSNArray
    'For iCtr = 0 To UBound(asDSNArray)
    '     Debug.Print asDSNArray(iCtr)
    'Next
    Dim iRet As Integer
    Dim sDSN As String
    Dim sDriver As String
    Dim iDSNLen As Integer
    Dim iDriverLen As Integer
    ReDim DSNArray(0) As String
    Dim lEnvHandle As Long

    iRet = SQLAllocEnv(lEnvHandle)
    sDSN = Space(1024)
    sDriver = Space(1024)
    iRet = SQLDataSources(lEnvHandle, SQL_FETCH_FIRST_SYSTEM, sDSN, 1024, iDSNLen, sDriver, 1024, iDriverLen)

    If iRet = SQL_SUCCESS Then
        sDSN = Mid(sDSN, 1, iDSNLen)
        sDriver = Mid(sDriver, 1, iDriverLen)
        DSNArray(0) = sDSN & " | " & sDriver
        Do Until iRet <> SQL_SUCCESS
            sDSN = Space(1024)
            sDriver = Space(1024)
            iRet = SQLDataSources(lEnvHandle, SQL_FETCH_NEXT, sDSN, 1024, iDSNLen, sDriver, 1024, iDriverLen)
            If Trim(sDSN) <> "" Then
                sDSN = Mid(sDSN, 1, iDSNLen)
                sDriver = Mid(sDriver, 1, iDriverLen)
                ReDim Preserve DSNArray(UBound(DSNArray) + 1)
                DSNArray(UBound(DSNArray)) = sDSN & " | " & sDriver
            End If
       Loop
    End If
    iRet = SQLFreeEnv(lEnvHandle)
End Sub

Public Function IsConnectedToInternet(Optional ConnectMode As Integer) As Boolean
    Dim flags As Long
    IsConnectedToInternet = InternetGetConnectedState(flags, 0) ' this ASPI function does it all
    ConnectMode = flags                                         ' return the flag through the optional argument
End Function

Public Function MemoryAvailable() As Double
    'Return Value in Megabytes
     MemoryAvailable = MemoryAvailablePhysical + MemoryPageFile
End Function

Public Function MemoryAvailablePhysical() As Double
    'Return Value in Megabytes
    Dim dblAns As Double
    plLastDllError = 0
    GlobalMemoryStatus pUdtMemStatus
    dblAns = pUdtMemStatus.dwAvailPhys
    MemoryAvailablePhysical = BytesToMegabytes(dblAns)
    plLastDllError = Err.LastDllError
End Function

Public Function MemoryInTotal() As Double
    'Return Value in Megabytes
    MemoryInTotal = MemoryPageFileSize + MemoryTotalPhysical
End Function

Public Function MemoryPageFile() As Double
    'Return Value in Megabytes
    Dim dblAns As Double

    plLastDllError = 0
    GlobalMemoryStatus pUdtMemStatus
    dblAns = pUdtMemStatus.dwAvailPageFile
    MemoryPageFile = BytesToMegabytes(dblAns)
    plLastDllError = Err.LastDllError
End Function

Public Function MemoryPageFileSize() As Double
    'Return Value in Megabytes
    Dim dblAns As Double

    plLastDllError = 0
    GlobalMemoryStatus pUdtMemStatus
    dblAns = pUdtMemStatus.dwTotalPageFile
    MemoryPageFileSize = BytesToMegabytes(dblAns)
    plLastDllError = Err.LastDllError
End Function

Public Function MemoryPercentFree() As Double
    MemoryPercentFree = Format(MemoryAvailable / MemoryInTotal * 100, "0#")
End Function

Public Function MemoryTotalPhysical() As Double
    'Return Value in Megabytes
    Dim dblAns As Double
    plLastDllError = 0
    GlobalMemoryStatus pUdtMemStatus
    dblAns = pUdtMemStatus.dwTotalPhys
    MemoryTotalPhysical = BytesToMegabytes(dblAns)
    plLastDllError = Err.LastDllError
End Function

Public Function Running(Optional InSeconds As Boolean = False) As Double
    Running = SECS_PER_DAY * (GetTickCount / 1000 / 60 / 60 / 24)
    Running = IIf(InSeconds, Round(Running, 2), Round(Running / 3600, 2))
End Function

Public Function ShutDown(ExitType As ShutdownType) As Long
    ShutDown = ExitWindowsEx(ExitType, 0&)
End Function

Public Function Started() As Date
    Dim dTicks     As Double
    'Store the number of days the systems has been running
    dTicks = GetTickCount / 1000 / 60 / 60 / 24
    Started = Now() - dTicks
End Function

'-----------------
'Private Functions
'-----------------
Private Function BytesToMegabytes(bytes As Double) As Double
  Dim dblAns As Double
  dblAns = (bytes / 1024) / 1024
  BytesToMegabytes = Format(dblAns, "###,###,##0.00")
End Function

Private Function FreeBytesOnDisk(Drive As String) As Long
    On Error Resume Next
    plLastDllError = 0

    Dim lAns As Long
    Dim lSectorsPerCluster As Long
    Dim lBytesPerSector As Long

    Dim lFreeClusters As Long
    Dim lTotalClusters As Long
    Dim lBytesPerCluster As Long
    Dim lFreeBytes As Double

    lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
    lBytesPerCluster = lSectorsPerCluster * lBytesPerSector
    lFreeBytes = lBytesPerCluster * lFreeClusters
    FreeBytesOnDisk = lFreeBytes
    plLastDllError = Err.LastDllError
End Function

Private Function PathCheck(ByVal PathName As String, Optional AltDelimiter As String = "") As String
    If Len(PathName) = 0 Then Exit Function
    Dim Delimiter As String
    Delimiter = IIf(InStr(PathName, "/"), "/", "\")
    PathCheck = IIf(Right$(PathName, 1) = Delimiter, PathName, PathName & Delimiter)
    PathCheck = IIf(Len(AltDelimiter) = 0, PathCheck, Replace(PathCheck, Delimiter, AltDelimiter))
End Function

Private Function TotalBytesOnDisk(Drive As String) As Double
    On Error Resume Next
    plLastDllError = 0
    Dim lAns As Long
    Dim lSectorsPerCluster As Long
    Dim lBytesPerSector As Long

    Dim lFreeClusters As Long
    Dim lTotalClusters As Long
    Dim lBytesPerCluster As Long
    Dim lTotalBytes As Double

    lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
    lBytesPerCluster = lSectorsPerCluster * lBytesPerSector
    'dblAns = (Bytes / 1024) / 1024
    TotalBytesOnDisk = lBytesPerCluster * lTotalClusters
    If TotalBytesOnDisk = 0 Then
        TotalBytesOnDisk = ((lBytesPerCluster / 1024) / 1024) * lTotalClusters
    End If
    plLastDllError = Err.LastDllError
End Function

Public Function LoadSystemIcon(ByVal StockIcon As enStockIcons) As Long
    On Error Resume Next
    LoadSystemIcon = LoadIconApi(0, StockIcon)
End Function

Public Sub DrawIcon(ByVal HDC As Long, ByVal xPos As Long, ByVal yPos As Long, ByVal Icon As Long)
    Dim lRet As Long
    lRet = DrawIconApi(HDC, xPos, yPos, Icon)
    If (Err.LastDllError > 0) Or (lRet = 0) Then Debug.Print "DrawIcon failed"
End Sub
'use:

'---------------------
' Class Initialization
'---------------------
Private Sub Class_Initialize()
    pUdtOSVersion.dwOSVersionInfoSize = Len(pUdtOSVersion)
    GetVersionEx pUdtOSVersion
    plMajorVersion = pUdtOSVersion.dwMajorVersion
    plMinorVersion = pUdtOSVersion.dwMinorVersion
    plPlatformID = pUdtOSVersion.dwPlatformId
End Sub

Private Sub Class_Terminate()
    '
End Sub

Display Windows Accessability Properties Dialog

Zaur — Sun, 11 Oct 2009 12:58:44 +0000

' -------
' Code
' -------

Sub AccessabilityDialog_Keyboard()
    ' Launch Accessability Properties Dialog (Keyboard Tab)

    Dim dblReturn As Double
    dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1", 1)
End Sub

' ================================================================= '

Sub AccessabilityDialog_Sound()
    ' Launch Accessability Properties Dialog (Sound Tab)

    Dim dblReturn As Double
    dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2", 1)
End Sub

' ================================================================= '

Sub AccessabilityDialog_Display()
    ' Launch Accessability Properties Dialog (Display Tab)

    Dim dblReturn As Double
    dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3", 1)
End Sub

' ================================================================= '

Sub AccessabilityDialog_Mouse()
    ' Launch Accessability Properties Dialog (Mouse Tab)

    Dim dblReturn As Double
    dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4", 1)
End Sub

' ================================================================= '

Sub AccessabilityDialog_General()
    ' Launch Accessability Properties Dialog (General Tab)

    Dim dblReturn As Double
    dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5", 1)
End Sub

Detect Windows NT

Zaur — Sun, 11 Oct 2009 12:58:13 +0000

'-----------------------------------------------------------
' FUNCTION: IsWindowsNT
'
' Returns true if this program is running under Windows NT
'-----------------------------------------------------------
'
Function IsWindowsNT() As Boolean
    Const dwMaskNT = &H2&
    IsWindowsNT = (GetWinPlatform() And dwMaskNT)
End Function

'-----------------------------------------------------------
' FUNCTION: IsWindowsNT4WithoutSP2
'
' Determines if the user is running under Windows NT 4.0
' but without Service Pack 2 (SP2).  If running under any
' other platform, returns False.
'
' IN: [none]
'
' Returns: True if and only if running under Windows NT 4.0
' without at least Service Pack 2 installed.
'-----------------------------------------------------------
'
Function IsWindowsNT4WithoutSP2() As Boolean
    IsWindowsNT4WithoutSP2 = False

    If Not IsWindowsNT() Then
        Exit Function
    End If

    Dim osvi As OSVERSIONINFO
    Dim strCSDVersion As String
    osvi.dwOSVersionInfoSize = Len(osvi)
    If GetVersionEx(osvi) = 0 Then
        Exit Function
    End If
    strCSDVersion = StripTerminator(osvi.szCSDVersion)

    'Is this Windows NT 4.0?
    Const NT4MajorVersion = 4
    Const NT4MinorVersion = 0
    If (osvi.dwMajorVersion <> NT4MajorVersion) Or (osvi.dwMinorVersion <> NT4MinorVersion) Then
        'No.  Return False.
        Exit Function
    End If

    'If no service pack is installed, or if Service Pack 1 is
    'installed, then return True.
    Const strSP1 = "SERVICE PACK 1"
    If strCSDVersion = "" Then
        IsWindowsNT4WithoutSP2 = True 'No service pack installed
    ElseIf strCSDVersion = strSP1 Then
        IsWindowsNT4WithoutSP2 = True 'Only SP1 installed
    End If
End Function

Detect Windows 95

Zaur — Sun, 11 Oct 2009 12:57:52 +0000

'-----------------------------------------------------------
' FUNCTION: IsWindows95
'
' Returns true if this program is running under Windows 95
'   or successor
'-----------------------------------------------------------
'
Function IsWindows95() As Boolean
    Const dwMask95 = &H1&
    IsWindows95 = (GetWinPlatform() And dwMask95)
End Function

Get the current windows platform

Zaur — Sun, 11 Oct 2009 12:57:18 +0000

'----------------------------------------------------------
' FUNCTION: GetWinPlatform
' Get the current windows platform.
' ---------------------------------------------------------
Public Function GetWinPlatform() As Long
    Dim osvi As OSVERSIONINFO
    Dim strCSDVersion As String

    osvi.dwOSVersionInfoSize = Len(osvi)

    If GetVersionEx(osvi) = 0 Then
        Exit Function
    End If

    GetWinPlatform = osvi.dwPlatformId
End Function

Disable / Enable Ctrl + Alt + Del, Alt + Tab, And Ctrl + Esc

Zaur — Sun, 11 Oct 2009 12:56:55 +0000

Option Explicit

' ----------------------------
' Constants & API Declarations
' ----------------------------

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Const SPI_SCREENSAVERRUNNING = 97

' ---------------
' Function
' ---------------

Sub Change_TaskView(Enable As Boolean)
    Dim eTask As Integer
    Dim junk As Boolean

    eTask = SystemParametersInfo(SPI_SCREENSAVERRUNNING, Not Enable, junk, 0)
End Sub

Create File Association

Zaur — Sun, 11 Oct 2009 12:56:22 +0000

' ---------------
' How to use :
'
' Call CreateAssociation() to create file association
' ---------------

Option Explicit

'// Windows Registry Messages
Private Const REG_SZ As Long = 1
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

'// Windows Error Messages
Private Const ERROR_NONE = 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_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259

'// Windows Security Messages
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0

'// Windows Registry API calls
Private Declare Function RegCloseKey Lib "advapi32.dll" _
 (ByVal hKey As Long) As Long

Private Declare Function RegCreateKeyEx _
  Lib "advapi32.dll" Alias "RegCreateKeyExA" _
 (ByVal hKey As Long, _
  ByVal lpSubKey As String, _
  ByVal Reserved As Long, _
  ByVal lpClass As String, _
  ByVal dwOptions As Long, _
  ByVal samDesired As Long, _
  ByVal lpSecurityAttributes As Long, _
  phkResult As Long, _
  lpdwDisposition As Long) As Long

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 RegSetValueExString _
  Lib "advapi32.dll" Alias "RegSetValueExA" _
 (ByVal hKey As Long, _
  ByVal lpValueName As String, _
  ByVal Reserved As Long, _
  ByVal dwType As Long, _
  ByVal lpValue As String, _
  ByVal cbData As Long) As Long

Private Declare Function RegSetValueExLong _
  Lib "advapi32.dll" Alias "RegSetValueExA" _
 (ByVal hKey As Long, _
  ByVal lpValueName As String, _
  ByVal Reserved As Long, _
  ByVal dwType As Long, _
  lpValue As Long, _
  ByVal cbData As Long) As Long

Public Sub CreateAssociation(fileEx As String, Discription As String)
  Dim sPath As String

  CreateNewKey fileEx, HKEY_CLASSES_ROOT
  SetKeyValue fileEx, "", Discription, REG_SZ
  CreateNewKey Discription & "\shell\Open in CyberCrypt\command", HKEY_CLASSES_ROOT
  CreateNewKey Discription & "\DefaultIcon", HKEY_CLASSES_ROOT
  SetKeyValue Discription & "\DefaultIcon", "", App.Path & "\" & App.EXEName & ".exe,0", REG_SZ
  SetKeyValue Discription, "", "CyberCrypt file", REG_SZ
  sPath = App.Path & "\" & App.EXEName & ".exe %1"

  SetKeyValue Discription & "\shell\Open in CyberCrypt\command", "", sPath, REG_SZ
End Sub

Private Function SetValueEx(ByVal hKey As Long, _
 sValueName As String, lType As Long, _
 vValue As Variant) As Long

  Dim nValue As Long
  Dim sValue As String

  Select Case lType
    Case REG_SZ
      sValue = vValue & Chr$(0)
      SetValueEx = RegSetValueExString(hKey, _
        sValueName, 0&, lType, sValue, Len(sValue))

    Case REG_DWORD
      nValue = vValue
      SetValueEx = RegSetValueExLong(hKey, sValueName, _
        0&, lType, nValue, 4)

  End Select
End Function

Private Sub CreateNewKey(sNewKeyName As String, _
  lPredefinedKey As Long)

  '// handle to the new key
  Dim hKey As Long

  '// result of the RegCreateKeyEx function
  Dim r As Long

  r = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, _
    vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, r)

  Call RegCloseKey(hKey)
End Sub

Private Sub SetKeyValue(sKeyName As String, sValueName As String, _
vValueSetting As Variant, lValueType As Long)

  '// result of the SetValueEx function
  Dim r As Long

  '// handle of opened key
  Dim hKey As Long

  '// open the specified key
  r = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, _
    KEY_ALL_ACCESS, hKey)

  r = SetValueEx(hKey, sValueName, lValueType, vValueSetting)

  Call RegCloseKey(hKey)
End Sub

Shut down System

Zaur — Sun, 11 Oct 2009 12:55:56 +0000

Option Explicit

' ----------------------------
' Constants & API Declarations
' ----------------------------

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

Private Const EWX_SHUTDOWN = 1

' ---------------
' Function
' ---------------

Private sub Shutdown()
        Dim ret As Integer
        Dim pOld As Boolean

        ret = SystemParametersInfo(97, False, pOld, 0)
End Sub

Close all windows and logon as a different user

Zaur — Sun, 11 Oct 2009 12:55:25 +0000

Option Explicit

' ---------------
' Declarations
' ---------------

Private Const EWX_LogOff As Long = 0
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long

' ---------------
' Function
' ---------------

' close all programs and log on as a different user
Sub CloseWindows()
    Dim lngResult As Long
    lngResult = ExitWindowsEx(EWX_LogOff, 0&)
End Sub