www.21code.com的系统控制中就有一个
解决方案 »
- vb怎么改变外部程序的SysListView32的选定行?
- 怎样提取access里的长二进制数据?
- 如何获取命令行参数?
- Richtextbox和Form的KeyPreview是否有冲突?
- 怎么样判断鼠标是否在窗体上?
- 请问怎么用VB控制串口发送10进制数据?为什么我发送字符“A”(ASCII码41H),单片机收到的是81H呢?
- 给我一点建议。
- 如何在VB中读取word中的任何表格单元格高和单元格宽呢?我经过多次调试,可以在VB中读取word中的任何表中的单元格高和单元格宽的方法.QQ:526009771 J85227115@126.COM
- 请问如何给一个Frame加上滚屏功能???
- 关于数据库的一些操作问题
- 关于类型不匹配的问题?
- 如何将二进制的四个字节转换成单精度浮点数?
On Error GoTo SysInfoErr
Dim rc As Long
Dim SysInfoPath As String
' Try To Get System Info Program Path\Name From Registry...
If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
' Try To Get System Info Program Path Only From Registry...
ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
' Validate Existance Of Known 32 Bit File Version
If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
' Error - File Can Not Be Found...
Else
GoTo SysInfoErr
End If
' Error - Registry Entry Can Not Be Found...
Else
GoTo SysInfoErr
End If
Call Shell(SysInfoPath, vbNormalFocus)
Exit Sub
SysInfoErr:
MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
Dim i As Long ' Loop Counter
Dim rc As Long ' Return Code
Dim hKey As Long ' Handle To An Open Registry Key
Dim hDepth As Long '
Dim KeyValType As Long ' Data Type Of A Registry Key
Dim tmpVal As String ' Tempory Storage For A Registry Key Value
Dim KeyValSize As Long ' Size Of Registry Key Variable
'------------------------------------------------------------
' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...
tmpVal = String$(1024, 0) ' Allocate Variable Space
KeyValSize = 1024 ' Mark Variable Size
'------------------------------------------------------------
' Retrieve Registry Key Value...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors
tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1)
'------------------------------------------------------------
' Determine Key Value Type For Conversion...
'------------------------------------------------------------
Select Case KeyValType ' Search Data Types...
Case REG_SZ ' String Registry Key Data Type
KeyVal = tmpVal ' Copy String Value
Case REG_DWORD ' Double Word Registry Key Data Type
For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char.
Next
KeyVal = Format$("&h" + KeyVal) ' Convert Double Word To String
End Select
GetKeyValue = True ' Return Success
rc = RegCloseKey(hKey) ' Close Registry Key
Exit Function ' Exit
GetKeyError: ' Cleanup After An Error Has Occured...
KeyVal = "" ' Set Return Val To Empty String
GetKeyValue = False ' Return Failure
rc = RegCloseKey(hKey) ' Close Registry Key
End Function
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6300
ClientLeft = 60
ClientTop = 345
ClientWidth = 8985
LinkTopic = "Form1"
ScaleHeight = 6300
ScaleWidth = 8985
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 375
Left = 3000
TabIndex = 1
Top = 5640
Width = 2655
End
Begin MSComctlLib.ListView ListView1
Height = 5295
Left = 120
TabIndex = 0
Top = 120
Width = 8655
_ExtentX = 15266
_ExtentY = 9340
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you can not publish
' or reproduce this code on any web site,
' on any online service, or distribute on
' any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'/* used for listview column auto-resizing
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Sub Form_Load() With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "Product"
.ColumnHeaders.Add , , "Manufacturer"
.View = lvwReport
.Sorted = False
End With
Command1.Caption = "BaseBoard Info"End Sub
Private Sub Command1_Click() ListView1.ListItems.Clear
Call wmiBaseBoardInfo
Call lvAutosizeControl(ListView1)
End Sub
Private Sub lvAutosizeControl(lv As ListView) Dim col2adjust As Long '/* Size each column based on the maximum of
'/* EITHER the columnheader text width, or,
'/* if the items below it are wider, the
'/* widest list item in the column
For col2adjust = 0 To lv.ColumnHeaders.Count - 1
Call SendMessage(lv.hwnd, _
LVM_SETCOLUMNWIDTH, _
col2adjust, _
ByVal LVSCW_AUTOSIZE_USEHEADER) Next
End Sub
Private Sub wmiBaseBoardInfo() Dim BaseBoardSet As SWbemObjectSet
Dim bb As SWbemObject
Dim itmx As ListItem
Set BaseBoardSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
InstancesOf("Win32_BaseBoard")
On Local Error Resume Next
For Each bb In BaseBoardSet
Set itmx = ListView1.ListItems.Add(, , "Manufacturer")
itmx.SubItems(1) = bb.Manufacturer
Set itmx = ListView1.ListItems.Add(, , "Caption")
itmx.SubItems(1) = bb.Caption
Set itmx = ListView1.ListItems.Add(, , "ConfigOptions")
itmx.SubItems(1) = bb.ConfigOptions
Set itmx = ListView1.ListItems.Add(, , "CreationClassName")
itmx.SubItems(1) = bb.CreationClassName
Set itmx = ListView1.ListItems.Add(, , "Depth")
itmx.SubItems(1) = bb.Depth
Set itmx = ListView1.ListItems.Add(, , "Description")
itmx.SubItems(1) = bb.Description
Set itmx = ListView1.ListItems.Add(, , "Height")
itmx.SubItems(1) = bb.Height
Set itmx = ListView1.ListItems.Add(, , "HostingBoard")
itmx.SubItems(1) = bb.HostingBoard
Set itmx = ListView1.ListItems.Add(, , "HotSwappable")
itmx.SubItems(1) = bb.HotSwappable
Set itmx = ListView1.ListItems.Add(, , "InstallDate")
itmx.SubItems(1) = bb.InstallDate
Set itmx = ListView1.ListItems.Add(, , "Model")
itmx.SubItems(1) = bb.Model
Set itmx = ListView1.ListItems.Add(, , "Name")
itmx.SubItems(1) = bb.Name
Set itmx = ListView1.ListItems.Add(, , "OtherIdentifyingInfo")
itmx.SubItems(1) = bb.OtherIdentifyingInfo
Set itmx = ListView1.ListItems.Add(, , "PartNumber")
itmx.SubItems(1) = bb.PartNumber
Set itmx = ListView1.ListItems.Add(, , "PoweredOn")
itmx.SubItems(1) = bb.PoweredOn
Set itmx = ListView1.ListItems.Add(, , "Product")
itmx.SubItems(1) = bb.Product
Set itmx = ListView1.ListItems.Add(, , "Removable")
itmx.SubItems(1) = bb.Removable
Set itmx = ListView1.ListItems.Add(, , "Replaceable")
itmx.SubItems(1) = bb.Replaceable
Set itmx = ListView1.ListItems.Add(, , "RequirementsDescription")
itmx.SubItems(1) = bb.RequirementsDescription
Set itmx = ListView1.ListItems.Add(, , "RequiresDaughterBoard")
itmx.SubItems(1) = bb.RequiresDaughterBoard
Set itmx = ListView1.ListItems.Add(, , "SerialNumber")
itmx.SubItems(1) = bb.SerialNumber
Set itmx = ListView1.ListItems.Add(, , "SKU")
itmx.SubItems(1) = bb.SKU
Set itmx = ListView1.ListItems.Add(, , "SlotLayout")
itmx.SubItems(1) = bb.SlotLayout
Set itmx = ListView1.ListItems.Add(, , "SpecialRequirements")
itmx.SubItems(1) = bb.SpecialRequirements
Set itmx = ListView1.ListItems.Add(, , "Status")
itmx.SubItems(1) = bb.Status
Set itmx = ListView1.ListItems.Add(, , "Tag")
itmx.SubItems(1) = bb.Tag
Set itmx = ListView1.ListItems.Add(, , "Version")
itmx.SubItems(1) = bb.Version
Set itmx = ListView1.ListItems.Add(, , "Weight")
itmx.SubItems(1) = bb.Weight
Set itmx = ListView1.ListItems.Add(, , "Width")
itmx.SubItems(1) = bb.Width
NextEnd Sub
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6375
ClientLeft = 60
ClientTop = 345
ClientWidth = 10095
LinkTopic = "Form1"
ScaleHeight = 6375
ScaleWidth = 10095
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 375
Left = 4200
TabIndex = 1
Top = 5880
Width = 1815
End
Begin MSComctlLib.ListView ListView1
Height = 5535
Left = 120
TabIndex = 0
Top = 120
Width = 9855
_ExtentX = 17383
_ExtentY = 9763
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you can not publish
' or reproduce this code on any web site,
' on any online service, or distribute on
' any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'/* used for listview column auto-resizing
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Sub Form_Load() With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.View = lvwReport
.Sorted = False
End With
Command1.Caption = "Disk Info"End Sub
Private Sub Command1_Click() ListView1.ListItems.Clear
Call wmiDiskDriveInfo
Call lvAutosizeControl(ListView1)
End Sub
Private Sub lvAutosizeControl(lv As ListView) Dim col2adjust As Long '/* Size each column based on the maximum of
'/* EITHER the columnheader text width, or,
'/* if the items below it are wider, the
'/* widest list item in the column
For col2adjust = 0 To lv.ColumnHeaders.Count - 1
Call SendMessage(lv.hwnd, _
LVM_SETCOLUMNWIDTH, _
col2adjust, _
ByVal LVSCW_AUTOSIZE_USEHEADER) Next
End Sub
Private Sub wmiDiskDriveInfo() Dim DiskDriveSet As SWbemObjectSet
Dim dd As SWbemObject
Dim thiscol As Long
Dim capcount As Long
Dim msg As String
Dim sflag As String 'used in err trap
Dim itmx As ListItem On Local Error GoTo diskinfo_error
'add a first column, and set lv initial parameters
With ListView1
.ListItems.Clear
.View = lvwReport
.Sorted = False
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "WMI Property"
'add class properties to column 1
'identification info
.ListItems.Add , , "ID: Description"
.ListItems.Add , , "ID: Index"
.ListItems.Add , , "ID: DeviceID"
.ListItems.Add , , "ID: Caption"
.ListItems.Add , , "ID: Manufacturer"
.ListItems.Add , , "ID: Model"
.ListItems.Add , , "ID: InterfaceType"
.ListItems.Add , , "ID: MediaLoaded"
.ListItems.Add , , "ID: MediaType"
'physical info
.ListItems.Add , , "Phyical: Status"
.ListItems.Add , , "Phyical: Size"
.ListItems.Add , , "Phyical: Partitions"
.ListItems.Add , , "Phyical: BytesPerSector"
.ListItems.Add , , "Phyical: SectorsPerTrack"
.ListItems.Add , , "Phyical: TotalCylinders"
.ListItems.Add , , "Phyical: TotalHeads"
.ListItems.Add , , "Phyical: TotalTracks"
.ListItems.Add , , "Phyical: TracksPerCylinder"
'capabilities of the device
.ListItems.Add , , "Disk Capabilities:"
End With Set DiskDriveSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
InstancesOf("Win32_DiskDrive")
'for each drive, fill in respective columns
For Each dd In DiskDriveSet
With ListView1
.ColumnHeaders.Add , , dd.Description & " " & dd.Index
capcount = 0
thiscol = (.ColumnHeaders.Count - 1)
'add identification info
.ListItems(1).SubItems(thiscol) = dd.Description
.ListItems(2).SubItems(thiscol) = dd.Index
.ListItems(3).SubItems(thiscol) = dd.DeviceID
.ListItems(4).SubItems(thiscol) = dd.Caption
.ListItems(5).SubItems(thiscol) = dd.Manufacturer
.ListItems(6).SubItems(thiscol) = dd.Model
.ListItems(7).SubItems(thiscol) = dd.InterfaceType
.ListItems(8).SubItems(thiscol) = dd.MediaLoaded
.ListItems(9).SubItems(thiscol) = dd.MediaType 'add physical info
.ListItems(10).SubItems(thiscol) = dd.Status
.ListItems(11).SubItems(thiscol) = FormatNumber(dd.Size, 0)
.ListItems(12).SubItems(thiscol) = dd.Partitions
.ListItems(13).SubItems(thiscol) = FormatNumber(dd.BytesPerSector, 0)
.ListItems(14).SubItems(thiscol) = FormatNumber(dd.SectorsPerTrack, 0)
.ListItems(15).SubItems(thiscol) = FormatNumber(dd.TotalCylinders, 0)
'note: the value for the TotalHeads property
'is obtained through extended functions of
'BIOS interrupt 13h. The value may be inaccurate
'if the drive uses a translation scheme to
'support high capacity disk sizes. Consult
'the manufacturer for accurate drive
'specifications
.ListItems(16).SubItems(thiscol) = FormatNumber(dd.TotalHeads, 0)
.ListItems(17).SubItems(thiscol) = FormatNumber(dd.TotalTracks, 0)
.ListItems(18).SubItems(thiscol) = FormatNumber(dd.TracksPerCylinder, 0)
'capabilities of the device
'because different drives may have different
'capabilites, the routine is coded such that
'when an insertion is attempted against a
'non-existant subitem index, the error trap
'will add the additional row. The sflag
'just assists in identifying the error
'occured because of the capactities loop.
sflag = "caploop"
Case 0: msg = "Unknown "
Case 1: msg = "Other "
Case 2: msg = "Sequential Access "
Case 3: msg = "Random Access "
Case 4: msg = "Supports Writing "
Case 5: msg = "Encryption "
Case 6: msg = "Compression "
Case 7: msg = "Supports Removable Media "
Case 8: msg = "Manual Cleaning "
Case 9: msg = "Automatic Cleaning "
Case 10: msg = "SMART Notification "
Case 11: msg = "Supports Dual Sided Media "
Case 12: msg = "Ejection Prior to Drive Dismount Not Required"
End Select
.ListItems(19 + capcount).SubItems(thiscol) = msg
Next
sflag = ""
End With
Next
diskinfo_exit: On Local Error GoTo 0
Exit Sub
diskinfo_error: 'if "index out of bounds" error
'and error occurred as result of
'adding drive capabilities, add
'a new blank listitem and resume
If Err.Number = 35600 And sflag = "caploop" Then
ListView1.ListItems.Add 19 + capcount, , ""
Resume
Else
Resume Next
End If
End Sub
'**********************************
'* 得到网卡地址
'* EthernetAddress(0)
'* 返回值:字符串
'**********************************
Public Function EthernetAddress(LanaNumber As Long) As String
Dim udtNCB As NCB
Dim bytResponse As Byte
Dim udtASTAT As ASTAT
Dim udtTempASTAT As ASTAT
Dim lngASTAT As Long
Dim strOut As String
Dim x As Integer
udtNCB.ncb_command = NCBRESET
bytResponse = Netbios(udtNCB)
udtNCB.ncb_command = NCBASTAT
udtNCB.ncb_lana_num = LanaNumber
udtNCB.ncb_callname = "* "
udtNCB.ncb_length = Len(udtASTAT)
lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
strOut = ""
If lngASTAT Then
udtNCB.ncb_buffer = lngASTAT
bytResponse = Netbios(udtNCB)
CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
With udtASTAT.adapt
For x = 0 To 5
strOut = strOut & Right$("00" & Hex$(.adapter_address(x)), 2)
Next x
End With
HeapFree GetProcessHeap(), 0, lngASTAT
End If
EthernetAddress = strOut
End Function
'得到IP地址
'屏幕调用 LocalIPAddress()Option ExplicitPublic Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Public Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Public Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Public Const ERROR_SUCCESS As Long = 0Public Type IP_ADDRESS_STRING
IpAddr(0 To 15) As Byte
End TypePublic Type IP_MASK_STRING
IpMask(0 To 15) As Byte
End TypePublic Type IP_ADDR_STRING
dwNext As Long
IpAddress As IP_ADDRESS_STRING
IpMask As IP_MASK_STRING
dwContext As Long
End TypePublic Type IP_ADAPTER_INFO
dwNext As Long
ComboIndex As Long '保留
sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3)) As Byte
sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
dwAddressLength As Long
sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1)) As Byte
dwIndex As Long
uType As Long
uDhcpEnabled As Long
CurrentIpAddress As Long
IpAddressList As IP_ADDR_STRING
GatewayList As IP_ADDR_STRING
DhcpServer As IP_ADDR_STRING
bHaveWins As Long
PrimaryWinsServer As IP_ADDR_STRING
SecondaryWinsServer As IP_ADDR_STRING
LeaseObtained As Long
LeaseExpires As Long
End TypePublic Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
(pTcpTable As Any, _
pdwSize As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dst As Any, _
src As Any, _
ByVal bcount As Long)
Function LocalIPAddress() As String
Dim cbRequired As Long
Dim buff() As Byte
Dim Adapter As IP_ADAPTER_INFO
Dim AdapterStr As IP_ADDR_STRING
Dim ptr1 As Long
Dim sIPAddr As String
Dim found As Boolean
Call GetAdaptersInfo(ByVal 0&, cbRequired)
If cbRequired > 0 Then
ReDim buff(0 To cbRequired - 1) As Byte
If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
'获取存放在buff()中的数据的指针
ptr1 = VarPtr(buff(0))
Do While (ptr1 <> 0)
'将第一个网卡的数据转换到IP_ADAPTER_INFO结构中
CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
With Adapter
'IpAddress.IpAddr成员给出了DHCP的IP地址
sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
If Len(sIPAddr) > 0 Then
found = True
Exit Do
End If
ptr1 = .dwNext
End With 'With Adapter
'不再有网卡时,ptr1的值为0
Loop 'Do While (ptr1 <> 0)
End If 'If GetAdaptersInfo
End If 'If cbRequired > 0
'返回结果字符串
LocalIPAddress = sIPAddr
End Function Function TrimNull(item As String)
Dim pos As Integer
pos = InStr(item, Chr$(0))
If pos Then
TrimNull = Left$(item, pos - 1)
Else: TrimNull = item
End If
End Function
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6135
ClientLeft = 60
ClientTop = 345
ClientWidth = 9045
LinkTopic = "Form1"
ScaleHeight = 6135
ScaleWidth = 9045
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 375
Left = 3720
TabIndex = 1
Top = 5640
Width = 1815
End
Begin MSComctlLib.ListView ListView1
Height = 5295
Left = 120
TabIndex = 0
Top = 120
Width = 8775
_ExtentX = 15478
_ExtentY = 9340
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you can not publish
' or reproduce this code on any web site,
' on any online service, or distribute on
' any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'listview column auto-resizing
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Sub Form_Load() With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "WMI Property"
.ColumnHeaders.Add , , "Value(s)"
.View = lvwReport
.Sorted = False
End With
Command1.Caption = "BIOS Info"End Sub
Private Sub Command1_Click() ListView1.ListItems.Clear
Call wmiBiosInfo
Call lvAutosizeControl(ListView1)
End Sub
Private Sub lvAutosizeControl(lv As ListView) Dim col2adjust As Long '/* Size each column based on the maximum of
'/* EITHER the columnheader text width, or,
'/* if the items below it are wider, the
'/* widest list item in the column
For col2adjust = 0 To lv.ColumnHeaders.Count - 1
Call SendMessage(lv.hwnd, _
LVM_SETCOLUMNWIDTH, _
col2adjust, _
ByVal LVSCW_AUTOSIZE_USEHEADER) Next
End Sub
Private Sub wmiBiosInfo()
Dim BiosSet As SWbemObjectSet
Dim bios As SWbemObject
Dim itmx As ListItem
Dim cnt As Long
Dim msg As String
Set BiosSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
InstancesOf("Win32_BIOS")
On Local Error Resume Next
For Each bios In BiosSet
Set itmx = ListView1.ListItems.Add(, , "PrimaryBIOS")
itmx.SubItems(1) = bios.PrimaryBIOS
Set itmx = ListView1.ListItems.Add(, , "Status")
itmx.SubItems(1) = bios.Status
For cnt = LBound(bios.BIOSVersion) To UBound(bios.BIOSVersion)
Set itmx = ListView1.ListItems.Add(, , IIf(cnt = 0, "BIOSVersion strings", ""))
itmx.SubItems(1) = bios.BIOSVersion(cnt)
Next
Set itmx = ListView1.ListItems.Add(, , "Caption")
itmx.SubItems(1) = bios.Caption
Set itmx = ListView1.ListItems.Add(, , "Description")
itmx.SubItems(1) = bios.Description
Set itmx = ListView1.ListItems.Add(, , "Name")
itmx.SubItems(1) = bios.Name Set itmx = ListView1.ListItems.Add(, , "Manufacturer")
itmx.SubItems(1) = bios.Manufacturer Set itmx = ListView1.ListItems.Add(, , "ReleaseDate")
itmx.SubItems(1) = bios.ReleaseDate Set itmx = ListView1.ListItems.Add(, , "SerialNumber")
itmx.SubItems(1) = bios.SerialNumber Set itmx = ListView1.ListItems.Add(, , "SMBIOSBIOSVersion")
itmx.SubItems(1) = bios.SMBIOSBIOSVersion
Set itmx = ListView1.ListItems.Add(, , "SMBIOSMajorVersion")
itmx.SubItems(1) = bios.SMBIOSMajorVersion
Set itmx = ListView1.ListItems.Add(, , "SMBIOSMinorVersion")
itmx.SubItems(1) = bios.SMBIOSMinorVersion Set itmx = ListView1.ListItems.Add(, , "SMBIOSPresent")
itmx.SubItems(1) = bios.SMBIOSPresent
Set itmx = ListView1.ListItems.Add(, , "SoftwareElementID")
itmx.SubItems(1) = bios.SoftwareElementID
Set itmx = ListView1.ListItems.Add(, , "SoftwareElementState")
Select Case bios.SoftwareElementState
Case 0: msg = "deployable"
Case 1: msg = "installable"
Case 2: msg = "executable"
Case 3: msg = "running"
End Select
itmx.SubItems(1) = msg
Set itmx = ListView1.ListItems.Add(, , "Version")
itmx.SubItems(1) = bios.Version Set itmx = ListView1.ListItems.Add(, , "InstallableLanguages")
itmx.SubItems(1) = bios.InstallableLanguages Set itmx = ListView1.ListItems.Add(, , "CurrentLanguage")
itmx.SubItems(1) = bios.CurrentLanguage
Set itmx = ListView1.ListItems.Add(, , IIf(cnt = 0, "ListOfLanguages", ""))
itmx.SubItems(1) = bios.ListOfLanguages(cnt)
Next cnt For cnt = LBound(bios.BiosCharacteristics) To UBound(bios.BiosCharacteristics)
Set itmx = ListView1.ListItems.Add(, , IIf(cnt = 0, "BIOS Characteristics", ""))
Select Case bios.BiosCharacteristics(cnt)
Case 0: msg = "reserved"
Case 1: msg = "reserved"
Case 2: msg = "unknown"
Case 3: msg = "BIOS characteristics not supported"
Case 4: msg = "ISA supported"
Case 5: msg = "MCA supported"
Case 6: msg = "EISA supported"
Case 7: msg = "PCI supported"
Case 8: msg = "PC Card (PCMCIA) supported"
Case 9: msg = "Plug and Play supported"
Case 10: msg = "APM is supported"
Case 11: msg = "BIOS upgradable (Flash)"
Case 12: msg = "BIOS shadowing allowed"
Case 13: msg = "VL-VESA supported"
Case 14: msg = "ESCD support available"
Case 15: msg = "Boot from CD supported"
Case 16: msg = "Selectable boot supported"
Case 17: msg = "BIOS ROM socketed"
Case 18: msg = "Boot from PC card (PCMCIA) supported"
Case 19: msg = "EDD (Enhanced Disk Drive) specification supported"
Case 20: msg = "Int 13h, Japanese Floppy for NEC 9800 1.2mb (3.5, 1k b/s, 360 RPM) supported"
Case 21: msg = "Int 13h, Japanese Floppy for Toshiba 1.2mb (3.5, 360 RPM) supported"
Case 22: msg = "Int 13h, 5.25 / 360 KB floppy services supported"
Case 23: msg = "Int 13h, 5.25 /1.2MB floppy services supported"
Case 24: msg = "Int 13h 3.5 / 720 KB floppy services supported"
Case 25: msg = "Int 13h, 3.5 / 2.88 MB floppy services supported"
Case 26: msg = "Int 5h, print screen service supported"
Case 27: msg = "Int 9h, 8042 keyboard services supported"
Case 28: msg = "Int 14h, serial services supported"
Case 29: msg = "Int 17h, printer services supported"
Case 30: msg = "Int 10h, CGA/Mono video aervices supported"
Case 31: msg = "NEC PC-98"
Case 32: msg = "ACPI supported"
Case 33: msg = "USB Legacy supported"
Case 34: msg = "AGP supported"
Case 35: msg = "I2O boot supported"
Case 36: msg = "LS-120 boot supported"
Case 37: msg = "ATAPI ZIP drive boot supported"
Case 38: msg = "1394 boot supported"
Case 39: msg = "Smart battery supported"
End Select
itmx.SubItems(1) = msg
Next 'For cnt
Next 'For Each biosEnd Sub
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6300
ClientLeft = 60
ClientTop = 345
ClientWidth = 10125
LinkTopic = "Form1"
ScaleHeight = 6300
ScaleWidth = 10125
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 495
Left = 4320
TabIndex = 1
Top = 5640
Width = 1695
End
Begin MSComctlLib.ListView ListView1
Height = 5295
Left = 120
TabIndex = 0
Top = 120
Width = 9855
_ExtentX = 17383
_ExtentY = 9340
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you can not publish
' or reproduce this code on any web site,
' on any online service, or distribute on
' any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'listview column auto-resizing
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Sub Form_Load() With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "Processor"
.ColumnHeaders.Add , , "BPS"
.ColumnHeaders.Add , , "Hres"
.ColumnHeaders.Add , , "Vres"
.ColumnHeaders.Add , , "Freq"
.ColumnHeaders.Add , , "Colours"
.ColumnHeaders.Add , , "rf min"
.ColumnHeaders.Add , , "rf max"
.ColumnHeaders.Add , , "Vmode"
.ColumnHeaders.Add , , "Mem"
.ColumnHeaders.Add , , "AdapterDACType"
.View = lvwReport
.Sorted = False
End With
Command1.Caption = "Video Controller Info"End Sub
Private Sub Command1_Click() ListView1.ListItems.Clear
Call wmiVideoControllerInfo
Call lvAutosizeControl(ListView1)
End Sub
Private Sub lvAutosizeControl(lv As ListView) Dim col2adjust As Long 'Size each column based on the maximum of
'wither the ColumnHeader text width, or,
'if the items below it are wider, the
'widest list item in the column
lv.Visible = False
For col2adjust = 0 To lv.ColumnHeaders.Count - 1
Call SendMessage(lv.hwnd, _
LVM_SETCOLUMNWIDTH, _
col2adjust, _
ByVal LVSCW_AUTOSIZE_USEHEADER) Next
lv.Visible = True
End Sub
Private Sub wmiVideoControllerInfo() Dim wmiObjSet As SWbemObjectSet
Dim obj As SWbemObject
Dim itmx As ListItem
Dim msg As String
Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
InstancesOf("Win32_VideoController")
On Local Error Resume Next
For Each obj In wmiObjSet
Set itmx = ListView1.ListItems.Add(, , obj.VideoProcessor)
itmx.SubItems(1) = obj.CurrentBitsPerPixel
itmx.SubItems(2) = obj.CurrentHorizontalResolution
itmx.SubItems(3) = obj.CurrentVerticalResolution
itmx.SubItems(4) = obj.CurrentRefreshRate
itmx.SubItems(5) = obj.CurrentNumberOfColors
itmx.SubItems(6) = obj.MinRefreshRate
itmx.SubItems(7) = obj.MaxRefreshRate Select Case obj.CurrentScanMode
Case 1: msg = "other"
Case 2: msg = "unknwn"
Case 3: msg = "intrlcd"
Case 4: msg = "nintrlcd"
End Select
itmx.SubItems(8) = msg
Select Case obj.VideoMemoryType
Case 1: msg = "other"
Case 2: msg = "unknown"
Case 3: msg = "VRAM"
Case 4: msg = "DRAM"
Case 5: msg = "SRAM"
Case 6: msg = "WRAM"
Case 7: msg = "EDO RAM"
Case 8: msg = "Burst Synchronous DRAM"
Case 9: msg = "Pipelined Burst SRAM"
Case 10: msg = "CDRAM"
Case 11: msg = "3DRAM"
Case 12: msg = "SDRAM"
Case 13: msg = "SGRAM"
End Select
itmx.SubItems(9) = msg
itmx.SubItems(9) = obj.AdapterDACType Next
End Sub
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 5985
ClientLeft = 60
ClientTop = 345
ClientWidth = 10350
LinkTopic = "Form1"
ScaleHeight = 5985
ScaleWidth = 10350
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 375
Left = 4200
TabIndex = 1
Top = 5400
Width = 2055
End
Begin MSComctlLib.ListView ListView1
Height = 5055
Left = 120
TabIndex = 0
Top = 120
Width = 10095
_ExtentX = 17806
_ExtentY = 8916
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you can not publish
' or reproduce this code on any web site,
' on any online service, or distribute on
' any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'listview column auto-resizing
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Sub Form_Load() With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "Device ID"
.ColumnHeaders.Add , , "Caption"
.ColumnHeaders.Add , , "Manu"
.ColumnHeaders.Add , , "Stat"
.ColumnHeaders.Add , , "Availability"
.View = lvwReport
.Sorted = False
End With
Command1.Caption = "Desktop Monitor Info"
End Sub
Private Sub Command1_Click() ListView1.ListItems.Clear
Call wmiDesktopMonitorInfo
Call lvAutosizeControl(ListView1)
End Sub
Private Sub lvAutosizeControl(lv As ListView) Dim col2adjust As Long 'Size each column based on the maximum of
'wither the ColumnHeader text width, or,
'if the items below it are wider, the
'widest list item in the column
lv.Visible = False
For col2adjust = 0 To lv.ColumnHeaders.Count - 1
Call SendMessage(lv.hwnd, _
LVM_SETCOLUMNWIDTH, _
col2adjust, _
ByVal LVSCW_AUTOSIZE_USEHEADER) Next
lv.Visible = True
End Sub
Private Sub wmiDesktopMonitorInfo() Dim dtmSet As SWbemObjectSet
Dim dtm As SWbemObject
Dim itmx As ListItem
Dim msg As String
Set dtmSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
InstancesOf("Win32_DesktopMonitor")
On Local Error Resume Next
For Each dtm In dtmSet
Set itmx = ListView1.ListItems.Add(, , dtm.DeviceID)
itmx.SubItems(1) = dtm.Caption
itmx.SubItems(2) = dtm.MonitorManufacturer
itmx.SubItems(3) = dtm.Status
Select Case dtm.Availability
Case 1: msg = "other"
Case 2: msg = "unknown "
Case 3: msg = "running/full power"
Case 4: msg = "warning "
Case 5: msg = "in test "
Case 6: msg = "not applicable "
Case 7: msg = "power off "
Case 8: msg = "off line "
Case 9: msg = "off duty "
Case 10: msg = "degraded "
Case 11: msg = "not installed "
Case 12: msg = "install error "
Case 13: msg = "power save - unknown "
Case 14: msg = "power save - low power mode "
Case 15: msg = "power save - standby "
Case 16: msg = "power cycle "
Case 17: msg = "power save - warning "
Case 18: msg = "paused "
Case 19: msg = "not ready "
Case 20: msg = "not configured "
Case 21: msg = "quiesced"
End Select
itmx.SubItems(4) = msg
Next
End Sub
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 5640
ClientLeft = 60
ClientTop = 345
ClientWidth = 10680
LinkTopic = "Form1"
ScaleHeight = 5640
ScaleWidth = 10680
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 375
Left = 4920
TabIndex = 1
Top = 5040
Width = 1455
End
Begin MSComctlLib.ListView ListView1
Height = 4455
Left = 240
TabIndex = 0
Top = 240
Width = 10095
_ExtentX = 17806
_ExtentY = 7858
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you can not publish
' or reproduce this code on any web site,
' on any online service, or distribute on
' any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Below used for listview column auto-resizing
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Sub Form_Load() With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.View = lvwReport
.Sorted = False
End With
Command1.Caption = "SystemSlot Info"End Sub
Private Sub Command1_Click() ListView1.ListItems.Clear
Call wmiSystemSlotInfo
Call lvAutosizeControl(ListView1)
End Sub
Private Sub lvAutosizeControl(lv As ListView) Dim col2adjust As Long 'Size each column based on the maximum of
'either the ColumnHeader text width, or,
'if the items below it are wider, the
'widest list item in the column
For col2adjust = 0 To lv.ColumnHeaders.Count - 1
Call SendMessage(lv.hwnd, _
LVM_SETCOLUMNWIDTH, _
col2adjust, _
ByVal LVSCW_AUTOSIZE_USEHEADER) Next
End Sub
Private Sub wmiSystemSlotInfo() Dim wmiObjSet As SWbemObjectSet
Dim obj As SWbemObject
Dim thiscol As Long
Dim capcount As Long
Dim msg As String
Dim cnt As Long
Dim sflag As String 'used in err trap
Dim itmx As ListItem On Local Error GoTo systemslot_error
'add first column and set initial parameters
With ListView1
.ListItems.Clear
.View = lvwReport
.Sorted = False
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "WMI Property"
.ListItems.Add , , "Number"
.ListItems.Add , , "Description"
.ListItems.Add , , "Tag"
.ListItems.Add , , "Status"
.ListItems.Add , , "ConnectorPinout"
.ListItems.Add , , "CurrentUsage"
.ListItems.Add , , "MaxDataWidth"
.ListItems.Add , , "PMESignal"
.ListItems.Add , , "Shared"
.ListItems.Add , , "SupportsHotPlug"
.ListItems.Add , , "VccMixedVoltageSupport"
.ListItems.Add , , "ConnectorType" End With Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
InstancesOf("Win32_SystemSlot")
'fill in respective columns for each object
For Each obj In wmiObjSet
With ListView1
.ColumnHeaders.Add , , obj.SlotDesignation
capcount = 0
thiscol = (.ColumnHeaders.Count - 1)
.ListItems(1).SubItems(thiscol) = IIf(obj.Number, obj.Number, "null")
.ListItems(2).SubItems(thiscol) = obj.Description
.ListItems(3).SubItems(thiscol) = obj.Tag
.ListItems(4).SubItems(thiscol) = obj.Status
.ListItems(5).SubItems(thiscol) = IIf(obj.ConnectorPinout, obj.ConnectorPinout, "null")
Select Case obj.CurrentUsage
Case 0: msg = "Reserved"
Case 1: msg = "Other"
Case 2: msg = "Unknown"
Case 3: msg = "Available"
Case 4: msg = "In use"
End Select
.ListItems(6).SubItems(thiscol) = msg
Select Case obj.MaxDataWidth
Case 0: msg = "8"
Case 1: msg = "16"
Case 2: msg = "32"
Case 3: msg = "64"
Case 4: msg = "128"
End Select
.ListItems(7).SubItems(thiscol) = msg
.ListItems(8).SubItems(thiscol) = obj.PMESignal
.ListItems(9).SubItems(thiscol) = obj.Shared
.ListItems(10).SubItems(thiscol) = obj.SupportsHotPlug
msg = ""
For cnt = LBound(obj.VccMixedVoltageSupport) To UBound(obj.VccMixedVoltageSupport)
Select Case obj.VccMixedVoltageSupport(cnt)
Case 0: msg = msg & "Unknown "
Case 1: msg = msg & "Other "
Case 2: msg = msg & "3.3v "
Case 3: msg = msg & "5v "
Case Else: msg = ""
End Select
Next
.ListItems(11).SubItems(thiscol) = msg
For capcount = LBound(obj.ConnectorType) To UBound(obj.ConnectorType)
Select Case obj.ConnectorType(capcount)
Case 0: msg = " Unknown"
Case 1: msg = " Other"
Case 2: msg = " Male"
Case 3: msg = " Female"
Case 4: msg = " Shielded"
Case 5: msg = " Unshielded"
Case 6: msg = " SCSI (A) High-Density (50 pins)"
Case 7: msg = " SCSI (A) Low-Density (50 pins)"
Case 8: msg = " SCSI (P) High-Density (68 pins)"
Case 9: msg = " SCSI SCA-I (80 pins)"
Case 10: msg = "SCSI SCA-II (80 pins)"
Case 11: msg = "SCSI Fibre Channel (DB-9, Copper)"
Case 12: msg = "SCSI Fibre Channel (Fibre)"
Case 13: msg = "SCSI Fibre Channel SCA-II (40 pins)"
Case 14: msg = "SCSI Fibre Channel SCA-II (20 pins)"
Case 15: msg = "SCSI Fibre Channel BNC"
Case 16: msg = "ATA 3-1/2 Inch (40 pins)"
Case 17: msg = "ATA 2-1/2 Inch (44 pins)"
Case 18: msg = "ATA-2"
Case 19: msg = "ATA-3"
Case 20: msg = "ATA/66"
Case 21: msg = "DB-9"
Case 22: msg = "DB-15"
Case 23: msg = "DB-25"
Case 24: msg = "DB-36"
Case 25: msg = "RS-232C"
Case 26: msg = "RS-422"
Case 27: msg = "RS-423"
Case 28: msg = "RS-485"
Case 29: msg = "RS-449"
Case 30: msg = "V.35"
Case 31: msg = "X.21"
Case 32: msg = "IEEE-488"
Case 33: msg = "AUI"
Case 34: msg = "UTP Category 3"
Case 35: msg = "UTP Category 4"
Case 36: msg = "UTP Category 5"
Case 37: msg = "BNC"
Case 38: msg = "RJ11"
Case 39: msg = "RJ45"
Case 40: msg = "Fiber MIC"
Case 41: msg = "Apple AUI"
Case 42: msg = "Apple GeoPort"
Case 43: msg = "PCI"
Case 44: msg = "ISA"
Case 45: msg = "EISA"
Case 46: msg = "VESA"
Case 47: msg = "PCMCIA"
Case 48: msg = "PCMCIA Type I"
Case 49: msg = "PCMCIA Type II"
Case 50: msg = "PCMCIA Type III"
Case 51: msg = "ZV Port"
Case 52: msg = "CardBus"
Case 53: msg = "USB"
Case 54: msg = "IEEE 1394"
Case 55: msg = "HIPPI"
Case 56: msg = "HSSDC (6 pins)"
Case 57: msg = "GBIC"
Case 58: msg = "DIN"
Case 59: msg = "Mini-DIN"
Case 60: msg = "Micro-DIN"
Case 61: msg = "PS/2"
Case 62: msg = "Infrared"
Case 63: msg = "HP-HIL"
Case 64: msg = "Access.bus"
Case 65: msg = "NuBus"
Case 66: msg = "Centronics"
Case 67: msg = "Mini-Centronics"
Case 68: msg = "Mini-Centronics Type-14"
Case 69: msg = "Mini-Centronics Type-20"
Case 70: msg = "Mini-Centronics Type-26"
Case 71: msg = "Bus Mouse"
Case 72: msg = "ADB"
Case 73: msg = "AGP"
Case 74: msg = "VME Bus"
Case 75: msg = "VME64"
Case 76: msg = "Proprietary"
Case 77: msg = "Proprietary Processor Card Slot"
Case 78: msg = "Proprietary Memory Card Slot"
Case 79: msg = "Proprietary I/O Riser Slot"
Case 80: msg = "PCI-66MHZ"
Case 81: msg = "AGP2X"
Case 82: msg = "AGP4X"
End Select
.ListItems(12 + capcount).SubItems(thiscol) = msg
Next
sflag = ""
End With
Next
systemslot_exit: On Local Error GoTo 0
Exit Sub
systemslot_error: If Err.Number = 35600 And sflag = "ConnectorType" Then
ListView1.ListItems.Add 12 + capcount, , ""
Resume
Else
Resume Next
End If
End Sub
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32Private Type NCB
ncb_command As Byte
ncb_retcode As Byte
ncb_lsn As Byte
ncb_num As Byte
ncb_buffer As Long
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte
ncb_sto As Byte
ncb_post As Long
ncb_lana_num As Byte
ncb_cmd_cplt As Byte
ncb_reserve(9) As Byte ' Reserved, must be 0
ncb_event As Long
End TypePrivate Type ADAPTER_STATUS
adapter_address(5) As Byte
rev_major As Byte
reserved0 As Byte
adapter_type As Byte
rev_minor As Byte
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End TypePrivate Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End TypePrivate Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End TypePrivate Declare Function Netbios Lib "netapi32.dll" (pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long'**********************************
'* 得到网卡地址
'* EthernetAddress(0)
'* 返回值:字符串
'**********************************
Public Function EthernetAddress(LanaNumber As Long) As String
Dim udtNCB As NCB
Dim bytResponse As Byte
Dim udtASTAT As ASTAT
Dim udtTempASTAT As ASTAT
Dim lngASTAT As Long
Dim strOut As String
Dim x As Integer
udtNCB.ncb_command = NCBRESET
bytResponse = Netbios(udtNCB)
udtNCB.ncb_command = NCBASTAT
udtNCB.ncb_lana_num = LanaNumber
udtNCB.ncb_callname = "* "
udtNCB.ncb_length = Len(udtASTAT)
lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
strOut = ""
If lngASTAT Then
udtNCB.ncb_buffer = lngASTAT
bytResponse = Netbios(udtNCB)
CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
With udtASTAT.adapt
For x = 0 To 5
strOut = strOut & Right$("00" & Hex$(.adapter_address(x)), 2)
Next x
End With
HeapFree GetProcessHeap(), 0, lngASTAT
End If
EthernetAddress = strOut
End Function
'得到IP地址
'屏幕调用 LocalIPAddress()Option ExplicitPublic Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Public Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Public Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Public Const ERROR_SUCCESS As Long = 0Public Type IP_ADDRESS_STRING
IpAddr(0 To 15) As Byte
End TypePublic Type IP_MASK_STRING
IpMask(0 To 15) As Byte
End TypePublic Type IP_ADDR_STRING
dwNext As Long
IpAddress As IP_ADDRESS_STRING
IpMask As IP_MASK_STRING
dwContext As Long
End TypePublic Type IP_ADAPTER_INFO
dwNext As Long
ComboIndex As Long '保留
sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3)) As Byte
sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
dwAddressLength As Long
sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1)) As Byte
dwIndex As Long
uType As Long
uDhcpEnabled As Long
CurrentIpAddress As Long
IpAddressList As IP_ADDR_STRING
GatewayList As IP_ADDR_STRING
DhcpServer As IP_ADDR_STRING
bHaveWins As Long
PrimaryWinsServer As IP_ADDR_STRING
SecondaryWinsServer As IP_ADDR_STRING
LeaseObtained As Long
LeaseExpires As Long
End TypePublic Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
(pTcpTable As Any, _
pdwSize As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dst As Any, _
src As Any, _
ByVal bcount As Long)
Function LocalIPAddress() As String
Dim cbRequired As Long
Dim buff() As Byte
Dim Adapter As IP_ADAPTER_INFO
Dim AdapterStr As IP_ADDR_STRING
Dim ptr1 As Long
Dim sIPAddr As String
Dim found As Boolean
Call GetAdaptersInfo(ByVal 0&, cbRequired)
If cbRequired > 0 Then
ReDim buff(0 To cbRequired - 1) As Byte
If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
'获取存放在buff()中的数据的指针
ptr1 = VarPtr(buff(0))
Do While (ptr1 <> 0)
'将第一个网卡的数据转换到IP_ADAPTER_INFO结构中
CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
With Adapter
'IpAddress.IpAddr成员给出了DHCP的IP地址
sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
If Len(sIPAddr) > 0 Then
found = True
Exit Do
End If
ptr1 = .dwNext
End With 'With Adapter
'不再有网卡时,ptr1的值为0
Loop 'Do While (ptr1 <> 0)
End If 'If GetAdaptersInfo
End If 'If cbRequired > 0
'返回结果字符串
LocalIPAddress = sIPAddr
End Function Function TrimNull(item As String)
Dim pos As Integer
pos = InStr(item, Chr$(0))
If pos Then
TrimNull = Left$(item, pos - 1)
Else: TrimNull = item
End If
End Function