syscotrlmodule.bas

适合乡镇供电所使用电费处理系统v3 软件

Attribute VB_Name = "SysCotrlModule"
Option Explicit

'帮助================================================
Declare Function WinHelp Lib "USER32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Any) As Long
Global Const HELP_QUIT = 2
Global Const HELP_INDEX = 3
Global Const HELP_HELPONHELP = 4
Global Const HELP_PARTIALKEY = &H105   '索引
Global Const HELP_CONTENTS = &H3       ' 3
'Global Const HELP_CONTEXTPOPUP = &H8   ' 8  弹出帮助
'===================================================

'---///////隐藏任务条///////
'Declare Function ShowWindow Lib "USER32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
'Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'Public Const SW_SHOW = 5
'Public Const SW_HIDE = 0

'--------示例--------------
'Private hwnd5 As Long
'hwnd5 = FindWindow("Shell_traywnd", "")
'Call ShowWindow(hwnd5, SW_HIDE) '隐藏任务栏
'Call ShowWindow(hwnd5, SW_SHOW) '显示任务栏
'---///////隐藏任务条///////

'///////////////获取win，system,temp路径

Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

'----//////////////系统信息//////////////////////////////----
Type SYSTEM_INFO
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved 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 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 GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)

Public Const PROCESSOR_INTEL_386 = 386
Public Const PROCESSOR_INTEL_486 = 486
Public Const PROCESSOR_INTEL_PENTIUM = 586
Public Const PROCESSOR_MIPS_R4000 = 4000
Public Const PROCESSOR_ALPHA_21064 = 21064
'---//////////////系统信息//////////////////////////////----

'系统控制面板
Public Sub ControlPanels(Filename As String)
  Dim rtn As Double
  On Error Resume Next
  rtn = Shell(Filename, 5)
End Sub

'创建目录
Public Function MakeDirectory(strPathName As String)
  Dim Length As Integer
  Dim DirLength As Integer
  Length = 4

  '添加 "\"
  If Right(strPathName, 1) <> "\" Then
    strPathName = strPathName + "\"
  End If

  While Not DirectoryExists(strPathName)
    DirLength = InStr(Length, strPathName, "\")

    If Not DirectoryExists(Left(strPathName, DirLength)) Then
      MkDir Left(strPathName, DirLength - 1)
    End If

    Length = DirLength + 1
  Wend

End Function

'判断目录是否存在
Public Function DirectoryExists(ByVal strPathName As String) As Boolean
  Dim DirectoryFound As String
  Const errPathNotFound As Integer = 76

  On Error GoTo 0
  DirectoryFound = Dir(strPathName, vbDirectory)
  If (Len(DirectoryFound) = 0 Or Err = errPathNotFound) Then
    DirectoryExists = False
  Else
    DirectoryExists = True
  End If

End Function


'创建多级目录
Public Function CreateDir(strDir As String) As Boolean
On Error Resume Next
    Dim bytMax As Byte
    Dim bytNdx As Byte
    Dim strDirLevel As String
    If Right(strDir, 1) <> "\" Then
            strDir = strDir & "\"
    End If
    bytMax = Len(strDir)
    For bytNdx = 4 To bytMax
        If (Mid(strDir, bytNdx, 1) = "\") Then
            strDirLevel = Left(strDir, bytNdx - 1)
            If Dir(strDirLevel, vbDirectory) = "" Then
                MkDir strDirLevel
            End If
        End If
    Next
    If Dir(strDir, vbDirectory) <> "" Then
        CreateDir = True
    Else
        CreateDir = False
    End If
End Function

'----//////////////系统硬件配置信息//////////////////////////////----

Public Function HardWareInfo(ByVal InfoID As Integer) As String
    Dim msg As String
    Dim NewLine As String
    Dim ret As Integer
    Dim ver_major As Integer
    Dim ver_minor As Integer
    Dim Build As Long
    NewLine = Chr(13) + Chr(10)
    Select Case InfoID
    Case 1
    '版本信息
    Dim verinfo As OSVERSIONINFO
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    ret = GetVersionEx(verinfo)
    If ret = 0 Then
        MsgBox "无法获取版本信息！"
        Exit Function
    End If
    Build = verinfo.dwBuildNumber
    
    Select Case verinfo.dwPlatformId
        Case 0
            msg = msg + "Windows 32s "
        Case 1
            If Build = 73010104 Then
               msg = msg + "Windows Me "
            End If
            If Build = 67766446 Then
               msg = msg + "Windows 98 "
            End If
        Case 2
            Select Case Build
                   Case Is >= 2195
                   msg = msg + "Windows NT "
                   Case Is >= 2600
                   msg = msg + "Windows XP "
            End Select
    End Select
    
    ver_major = verinfo.dwMajorVersion
    ver_minor = verinfo.dwMinorVersion
    msg = msg & ver_major & "." & ver_minor
    msg = msg & " (Build " & Build & ")"    ' & NewLine & NewLine
    
    'CPU信息
    Case 2
    Dim sysinfo As SYSTEM_INFO
    GetSystemInfo sysinfo
    msg = msg + "CPU: "
    Select Case sysinfo.dwProcessorType
        Case PROCESSOR_INTEL_386
            msg = msg + "Intel 386"
        Case PROCESSOR_INTEL_486
            msg = msg + "Intel 486"
        Case PROCESSOR_INTEL_PENTIUM
            msg = msg + "Intel 奔腾或赛扬及以上"
        Case PROCESSOR_MIPS_R4000
            msg = msg + "MIPS R4000"
        Case PROCESSOR_ALPHA_21064
            msg = msg + "DEC Alpha 21064"
        Case Else
            msg = msg + "(未知)"
    End Select
    
    msg = msg
    
    Case 3
    '内存信息
    Dim memsts As MEMORYSTATUS
    Dim memory As Long
    GlobalMemoryStatus memsts
    memory = memsts.dwTotalPhys
    msg = msg + "总物理内存: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + "|"
    memory = memsts.dwAvailPhys
    msg = msg + "可用物理内存: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + "|"
    memory = memsts.dwTotalVirtual
    msg = msg + "总虚拟内存: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + "|"
    memory = memsts.dwAvailVirtual
    msg = msg + "可用虚拟内存: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K"
    End Select
    
    HardWareInfo = msg
End Function

'获取win,system,temp路径
Public Function GetWinSysTmpPath(ByVal WinPH As Integer) As String
    Dim WinPath As String, SysPath As String
    Dim tempPath As String
    Dim len5 As Long
    Select Case WinPH
           Case 0
                '取得Windows 的目录
                WinPath = String(255, 0)
                len5 = GetWindowsDirectory(WinPath, 256)
                WinPath = Left(WinPath, InStr(1, WinPath, Chr(0)) - 1)
                GetWinSysTmpPath = WinPath
            Case 1
                '取得Windows System的目录
                SysPath = String(255, 0)
                len5 = GetSystemDirectory(SysPath, 256)
                SysPath = Left(SysPath, InStr(1, SysPath, Chr(0)) - 1)
                GetWinSysTmpPath = SysPath
            Case 2
                '取得Temp的Directory
                tempPath = String(255, 0)
                len5 = GetTempPath(256, tempPath)
                tempPath = Left(tempPath, len5)
                GetWinSysTmpPath = tempPath
            
    End Select
End Function

'///////////////////获取计算机用户名,计算机名/////////////
'说明：参数1 返回当前登录用户名
'     参数2 返回当前登录计算机名
'///////////////////////////////////////////////////////
Public Function GetUser(NC As Integer) As String
    Dim Bufstr As String
    Dim sBufSize As Long
    Dim sStatus As Long
    
    Select Case NC
           Case 1   '用户名
            Bufstr = Space$(50)
            
            If GetUserName(Bufstr, 50) > 0 Then
                GetUser = Bufstr
                GetUser = RTrim(GetUser)
                'UserName = StripTerminator(UserName)
            Else
                GetUser = ""
            End If
           Case 2    '计算机名
            sBufSize = 255
            Bufstr = String$(sBufSize, " ")
            sStatus = GetComputerName(Bufstr, sBufSize)
            GetUser = ""
            If sStatus <> 0 Then
               GetUser = Left(Bufstr, sBufSize)
            End If
           Case Else
                MsgBox "参数不正确!", vbCritical
                Exit Function
         End Select

End Function


'帮助===========================================
Sub HelpFunction(lhWnd As Long, HelpCmd As Integer, HelpKey As String)
    Dim lRtn As Long
    If HelpCmd = HELP_PARTIALKEY Then
       lRtn = WinHelp(lhWnd, App.HelpFile, HelpCmd, HelpKey)
    Else
       lRtn = WinHelp(lhWnd, App.HelpFile, HelpCmd, 0&)
    End If
End Sub
'===============================================

'获取文件扩展名
Function GetExtension(Filename As String)
    Dim PthPos As Integer, ExtPos As Integer, i As Integer, j As Integer
    For i = Len(Filename) To 1 Step -1
        If Mid(Filename, i, 1) = "." Then
           ExtPos = i
           For j = Len(Filename) To 1 Step -1
               If Mid(Filename, j, 1) = "\" Then
                  PthPos = j
                  Exit For
               End If
           Next j
           Exit For
        End If
    Next i
    If PthPos > ExtPos Then
       Exit Function
    Else
       If ExtPos = 0 Then Exit Function
       GetExtension = Mid(Filename, ExtPos + 1, Len(Filename) - ExtPos)
    End If
End Function

'检测是否可执行文件
Function WinExe(ByVal Exe As String) As Boolean
    Dim fh As Integer
    Dim t As String * 1
    fh = FreeFile
    Open Exe For Binary As #fh
    Get fh, 25, t
    Close #fh
    WinExe = (Asc(t) = &H40&)
End Function