syscotrlmodule.bas

adsl拨号工具 有很多功能 不错啊 大家试试

            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 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

'窗口是否置前
Sub FormStayOnTop(varForm As Form, OnTop As Boolean)

    Dim Handle As Long
    Dim wFlags As Long
    Dim PosFlag As Long
    
    Const Swp_Nosize = &H1
    Const SWP_Nomove = &H2
    Const Swp_NoActivate = &H10
    Const Swp_ShowWindow = &H40
    Const Hwnd_TopMost = -1
    Const Hwnd_NoTopMost = -2
    
    Handle = varForm.hwnd
    
    wFlags = SWP_Nomove Or Swp_Nosize Or Swp_ShowWindow Or Swp_NoActivate

    Select Case OnTop
         Case True
            PosFlag = Hwnd_TopMost
         Case False
            PosFlag = Hwnd_NoTopMost
    End Select

    SetWindowPos Handle, PosFlag, 0, 0, 0, 0, wFlags

End Sub

'打印对话框
Public Sub ShowPrinter(frmOwner As Form, Optional PrintFlags As Long)
    '-> Code by Donald Grover
    Dim PrintDlg As PRINTDLG_TYPE
    Dim DevMode As DEVMODE_TYPE
    Dim DevName As DEVNAMES_TYPE

    Dim lpDevMode As Long, lpDevName As Long
    Dim bReturn As Integer
    Dim objPrinter As Printer, NewPrinterName As String

    ' Use PrintDialog to get the handle to a memory
    ' block with a DevMode and DevName structures

    PrintDlg.lStructSize = Len(PrintDlg)
    PrintDlg.hwndOwner = frmOwner.hwnd

    PrintDlg.flags = PrintFlags
    On Error Resume Next
    'Set the current orientation and duplex setting
    DevMode.dmDeviceName = Printer.DeviceName
    DevMode.dmSize = Len(DevMode)
    DevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX
    DevMode.dmPaperWidth = Printer.Width
    DevMode.dmOrientation = Printer.Orientation
    DevMode.dmPaperSize = Printer.PaperSize
    DevMode.dmDuplex = Printer.Duplex
    On Error GoTo 0

    'Allocate memory for the initialization hDevMode structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevMode))
    lpDevMode = GlobalLock(PrintDlg.hDevMode)
    If lpDevMode > 0 Then
        CopyMemory ByVal lpDevMode, DevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
    End If

    'Set the current driver, device, and port name strings
    With DevName
        .wDriverOffset = 8
        .wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
        .wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
        .wDefault = 0
    End With

    With Printer
        DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
    End With

    'Allocate memory for the initial hDevName structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
    lpDevName = GlobalLock(PrintDlg.hDevNames)
    If lpDevName > 0 Then
        CopyMemory ByVal lpDevName, DevName, Len(DevName)
        bReturn = GlobalUnlock(lpDevName)
    End If

    'Call the print dialog up and let the user make changes
    If PrintDialog(PrintDlg) <> 0 Then

        'First get the DevName structure.
        lpDevName = GlobalLock(PrintDlg.hDevNames)
        CopyMemory DevName, ByVal lpDevName, 45
        bReturn = GlobalUnlock(lpDevName)
        GlobalFree PrintDlg.hDevNames

        'Next get the DevMode structure and set the printer
        'properties appropriately
        lpDevMode = GlobalLock(PrintDlg.hDevMode)
        CopyMemory DevMode, ByVal lpDevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
        GlobalFree PrintDlg.hDevMode
        NewPrinterName = UCase$(Left(DevMode.dmDeviceName, InStr(DevMode.dmDeviceName, Chr$(0)) - 1))
        If Printer.DeviceName <> NewPrinterName Then
            For Each objPrinter In Printers
                If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                    Set Printer = objPrinter
                    'set printer toolbar name at this point
                End If
            Next
        End If

        On Error Resume Next
        'Set printer object properties according to selections made
        'by user
        Printer.Copies = DevMode.dmCopies
        Printer.Duplex = DevMode.dmDuplex
        Printer.Orientation = DevMode.dmOrientation
        Printer.PaperSize = DevMode.dmPaperSize
        Printer.PrintQuality = DevMode.dmPrintQuality
        Printer.ColorMode = DevMode.dmColor
        Printer.PaperBin = DevMode.dmDefaultSource
        On Error GoTo 0
    End If
End Sub