user.bas

功能强大的API

Attribute VB_Name = "User"
Option Explicit
Dim WinVersion As Integer, SoundAvailable As Integer
Global VisibleFrame As Frame
 
Global Const TWIPS = 1
Global Const PIXELS = 3
Global Const RES_INFO = 2
Global Const MINIMIZED = 1

Type MYVERSION
    lMajorVersion As Long
    lMinorVersion As Long
    lExtraInfo As Long
End Type

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

Type Rect
    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer
End Type

Public Type SystemInfo
    dwOemId As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
End Type

Public 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

Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SystemInfo)
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Declare Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Declare Function TrackPopupMenu Lib "User32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As Long, lpReserved As Any) As Long
Declare Function GetMenu Lib "User32" (ByVal hWnd As Long) As Long
Declare Function GetSubMenu Lib "User32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetDC Lib "User32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "User32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Declare Sub 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)
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Declare Function waveOutGetNumDevs Lib "winmm" () As Long
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

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

Global Const WF_CPU286 = &H2&
Global Const WF_CPU386 = &H4&
Global Const WF_CPU486 = &H8&
Global Const WF_STANDARD = &H10&
Global Const WF_ENHANCED = &H20&
Global Const WF_80x87 = &H400&

Global Const SM_MOUSEPRESENT = 19

Global Const GFSR_SYSTEMRESOURCES = &H0
Global Const GFSR_GDIRESOURCES = &H1
Global Const GFSR_USERRESOURCES = &H2

Global Const MF_POPUP = &H10
Global Const MF_BYPOSITION = &H400
Global Const MF_SEPARATOR = &H800

Global Const SRCCOPY = &HCC0020
Global Const SRCERASE = &H440328
Global Const SRCINVERT = &H660046
Global Const SRCAND = &H8800C6

Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2
Global Const SWP_NOACTIVATE = &H10
Global Const SWP_SHOWWINDOW = &H40

Public Tempstring As String


Function DeviceColors(hDC As Long) As Single
Const PLANES = 14
Const BITSPIXEL = 12
    DeviceColors = 2 ^ (GetDeviceCaps(hDC, PLANES) * GetDeviceCaps(hDC, BITSPIXEL))
End Function

Function GetSysIni(section, key)
Dim retVal As String, AppName As String, worked As Integer
    retVal = String$(255, 0)
    worked = GetPrivateProfileString(section, key, "", retVal, Len(retVal), "System.ini")
    If worked = 0 Then
        GetSysIni = "unknown"
    Else
        GetSysIni = Left(retVal, InStr(retVal, Chr(0)) - 1)
    End If
End Function

Function GetWinIni(section, key)
Dim retVal As String, AppName As String, worked As Integer
    retVal = String$(255, 0)
    worked = GetProfileString(section, key, "", retVal, Len(retVal))
    If worked = 0 Then
        GetWinIni = "unknown"
    Else
        GetWinIni = Left(retVal, InStr(retVal, Chr(0)) - 1)
    End If
End Function

Function SystemDirectory() As String
Dim WinPath As String
    WinPath = String(145, Chr(0))
    SystemDirectory = Left(WinPath, GetSystemDirectory(WinPath, InStr(WinPath, Chr(0)) - 1))
End Function

Function WindowsDirectory() As String
Dim WinPath As String
Dim temp
    WinPath = String(145, Chr(0))
    temp = GetWindowsDirectory(WinPath, 145)
    WindowsDirectory = Left(WinPath, InStr(WinPath, Chr(0)) - 1)
End Function

Function WindowsVersion() As MYVERSION
Dim myOS As OSVERSIONINFO, WinVer As MYVERSION
Dim lResult As Long

    myOS.dwOSVersionInfoSize = Len(myOS)
    
    lResult = GetVersionEx(myOS)

    WinVer.lMajorVersion = myOS.dwMajorVersion
    WinVer.lMinorVersion = myOS.dwMinorVersion
    WinVer.lExtraInfo = myOS.dwPlatformId
    
    WindowsVersion = WinVer

End Function


Function Capitalise(Passedstring As String) As String
Dim CharTemp
CharTemp = 0
If Len(Trim(Passedstring)) > 0 Then
    Passedstring = LCase(Trim(Passedstring))
    Passedstring = UCase(Left(Passedstring, 1)) & Right(Passedstring, Len(Passedstring) - 1)
    Do Until CharTemp = Len(Passedstring)
        CharTemp = CharTemp + 1
        If Left(Mid(Passedstring, CharTemp, 2), 1) = " " Then Passedstring = Left(Passedstring, CharTemp) & UCase(Mid(Passedstring, CharTemp + 1, 1)) & Right(Passedstring, Len(Passedstring) - (CharTemp + 1))
    Loop
    Capitalise = Passedstring
End If
End Function
Function IsItANumber(Word As String) As Boolean
Dim Charon As Integer
Charon = 1
Do Until Charon = Len(Word) + 1
    If Mid(Word, Charon, 1) <> "1" And Mid(Word, Charon, 1) <> "2" And Mid(Word, Charon, 1) <> "3" And Mid(Word, Charon, 1) <> "4" And Mid(Word, Charon, 1) <> "5" And Mid(Word, Charon, 1) <> "6" And Mid(Word, Charon, 1) <> "7" And Mid(Word, Charon, 1) <> "8" And Mid(Word, Charon, 1) <> "9" And Mid(Word, Charon, 1) <> "0" Then
        IsItANumber = False
        Exit Function
    Else
        IsItANumber = True
    End If
    Charon = Charon + 1
Loop
End Function

Function IniGet(FileName As String, KeyName As String, ValueName As String) As Variant
Dim FreeIniGetFile As Integer
FreeIniGetFile = FreeFile
If Dir(Trim(FileName)) <> "" Then
    Open Trim(FileName) For Input As FreeIniGetFile
    ValueName = UCase(ValueName + "=")
    
    Line Input #FreeIniGetFile, Tempstring
    If Trim(Tempstring) = "[" & KeyName & "]" Then
        While Not (EOF(FreeIniGetFile)) And UCase(Left(Tempstring, Len(ValueName))) <> ValueName
            Line Input #FreeIniGetFile, Tempstring
        Wend
    End If
    Close #FreeIniGetFile
    IniGet = Trim(Mid(Tempstring, Len(ValueName) + 1))
Else
    IniGet = Null
End If
End Function
Function TrimAll(Passedstring As String) As String
Do Until InStr(Passedstring, " ") = 0
    Passedstring = Left(Passedstring, InStr(Passedstring, " ") - 1) & Mid(Passedstring, InStr(Passedstring, " ") + 1, Len(Passedstring) - InStr(Passedstring, " "))
Loop
TrimAll = Passedstring
End Function