syscotrlmodule.bas

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

Attribute VB_Name = "SysCotrlModule"
'****************************************************************************
'人人为我，我为人人
'枕善居汉出品
'发布日期：05/08/15
'描  述：拨号上网管理器
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
Option Explicit
'读取计算机名称
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'关于
Public 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
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'帮助================================================
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  弹出帮助
'===================================================

'///////////////获取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

'打印
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const DM_ORIENTATION = &H1&
Const DM_DUPLEX = &H1000&
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40

Private Type PRINTDLG_TYPE
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    hDC As Long
    flags As Long
    nFromPage As Integer
    nToPage As Integer
    nMinPage As Integer
    nMaxPage As Integer
    nCopies As Integer
    hInstance As Long
    lCustData As Long
    lpfnPrintHook As Long
    lpfnSetupHook As Long
    lpPrintTemplateName As String
    lpSetupTemplateName As String
    hPrintTemplate As Long
    hSetupTemplate As Long
End Type

Private Type DEVNAMES_TYPE
    wDriverOffset As Integer
    wDeviceOffset As Integer
    wOutputOffset As Integer
    wDefault As Integer
    extra As String * 100
End Type
Private Type DEVMODE_TYPE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function PrintDialog Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG_TYPE) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'---
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
'---//////////////系统信息//////////////////////////////----
'窗口置前
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)

' 高级声音支持 API
Declare Function sndPlaySound Lib "WINMM.DLL" Alias "sndPlaySoundA" _
        (lpszSoundName As Any, ByVal uFlags As Long) As Long

Global Const SND_ASYNC = &H1     ' 异步播放
Global Const SND_NODEFAULT = &H2 ' 不使用缺省声音
Global Const SND_MEMORY = &H4    ' lpszSoundName 指向一个内存文件
Global SoundBuffer() As Byte

'播放资源中的声音
Sub BeginPlaySound(ByVal ResourceId As Integer)
    SoundBuffer = LoadResData(ResourceId, "POPSOUND")
    sndPlaySound SoundBuffer(0), SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY
End Sub

Sub EndPlaySound()
    sndPlaySound ByVal vbNullString, 0&
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