home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / device_inf2048792192007.psc / Form1.frm < prev    next >
Text File  |  2007-02-19  |  6KB  |  161 lines
  1. VERSION 5.00
  2. Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
  3. Begin VB.Form Form1 
  4.    BorderStyle     =   1  'Fest Einfach
  5.    Caption         =   "Device Information"
  6.    ClientHeight    =   3600
  7.    ClientLeft      =   45
  8.    ClientTop       =   330
  9.    ClientWidth     =   6540
  10.    BeginProperty Font 
  11.       Name            =   "Tahoma"
  12.       Size            =   8.25
  13.       Charset         =   0
  14.       Weight          =   400
  15.       Underline       =   0   'False
  16.       Italic          =   0   'False
  17.       Strikethrough   =   0   'False
  18.    EndProperty
  19.    LinkTopic       =   "Form1"
  20.    MaxButton       =   0   'False
  21.    MinButton       =   0   'False
  22.    ScaleHeight     =   3600
  23.    ScaleWidth      =   6540
  24.    StartUpPosition =   3  'Windows-Standard
  25.    Begin VB.CommandButton cmdEject 
  26.       Caption         =   "safe eject"
  27.       Height          =   390
  28.       Left            =   5100
  29.       TabIndex        =   1
  30.       Top             =   3150
  31.       Width           =   1290
  32.    End
  33.    Begin MSComctlLib.ListView lvwDrives 
  34.       Height          =   3015
  35.       Left            =   75
  36.       TabIndex        =   0
  37.       Top             =   75
  38.       Width           =   6390
  39.       _ExtentX        =   11271
  40.       _ExtentY        =   5318
  41.       View            =   3
  42.       LabelEdit       =   1
  43.       LabelWrap       =   -1  'True
  44.       HideSelection   =   0   'False
  45.       FullRowSelect   =   -1  'True
  46.       _Version        =   393217
  47.       ForeColor       =   -2147483640
  48.       BackColor       =   -2147483643
  49.       BorderStyle     =   1
  50.       Appearance      =   1
  51.       BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
  52.          Name            =   "Tahoma"
  53.          Size            =   8.25
  54.          Charset         =   0
  55.          Weight          =   400
  56.          Underline       =   0   'False
  57.          Italic          =   0   'False
  58.          Strikethrough   =   0   'False
  59.       EndProperty
  60.       NumItems        =   4
  61.       BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
  62.          Text            =   "Drive"
  63.          Object.Width           =   1041
  64.       EndProperty
  65.       BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
  66.          SubItemIndex    =   1
  67.          Text            =   "Bus Type"
  68.          Object.Width           =   1481
  69.       EndProperty
  70.       BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
  71.          SubItemIndex    =   2
  72.          Text            =   "Removable"
  73.          Object.Width           =   1834
  74.       EndProperty
  75.       BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
  76.          SubItemIndex    =   3
  77.          Text            =   "Name"
  78.          Object.Width           =   5186
  79.       EndProperty
  80.    End
  81. End
  82. Attribute VB_Name = "Form1"
  83. Attribute VB_GlobalNameSpace = False
  84. Attribute VB_Creatable = False
  85. Attribute VB_PredeclaredId = True
  86. Attribute VB_Exposed = False
  87. Option Explicit
  88.  
  89. Implements iSubclass
  90.  
  91. Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
  92. Alias "GetLogicalDriveStringsA" ( _
  93.     ByVal nBufferLength As Long, _
  94.     ByVal lpBuffer As String _
  95. ) As Long
  96.  
  97. Private m_clsSubcls As cSubclass
  98.  
  99. Private Sub cmdEject_Click()
  100.     If EjectDevice(lvwDrives.SelectedItem.Tag) Then
  101.         MsgBox "Successfully ejected the device from the system!", vbInformation
  102.     Else
  103.         MsgBox "Could not eject " & lvwDrives.SelectedItem.Tag & "!", vbExclamation
  104.     End If
  105. End Sub
  106.  
  107. Private Sub Form_Load()
  108.     Set m_clsSubcls = New cSubclass
  109.     
  110.     m_clsSubcls.Subclass Me.hwnd, Me
  111.     m_clsSubcls.AddMsg Me.hwnd, WM_DEVICECHANGE
  112.     
  113.     RefreshDriveList
  114. End Sub
  115.  
  116. Private Sub Form_Unload(Cancel As Integer)
  117.     m_clsSubcls.Terminate
  118. End Sub
  119.  
  120. Private Sub RefreshDriveList()
  121.     Dim strDriveBuffer  As String
  122.     Dim strDrives()     As String
  123.     Dim i               As Long
  124.     Dim udtInfo         As DEVICE_INFORMATION
  125.     
  126.     strDriveBuffer = Space(240)
  127.     strDriveBuffer = Left$(strDriveBuffer, GetLogicalDriveStrings(Len(strDriveBuffer), strDriveBuffer))
  128.     strDrives = Split(strDriveBuffer, Chr$(0))
  129.  
  130.     lvwDrives.ListItems.Clear
  131.  
  132.     For i = 0 To UBound(strDrives) - 1
  133.         With lvwDrives.ListItems.Add(Text:=strDrives(i))
  134.             udtInfo = GetDevInfo(strDrives(i))
  135.             
  136.             If udtInfo.Valid Then
  137.                 Select Case udtInfo.BusType
  138.                     Case BusTypeUsb:        .SubItems(1) = "USB"
  139.                     Case BusType1394:       .SubItems(1) = "1394"
  140.                     Case BusTypeAta:        .SubItems(1) = "ATA"
  141.                     Case BusTypeAtapi:      .SubItems(1) = "ATAPI"
  142.                     Case BusTypeFibre:      .SubItems(1) = "Fibre"
  143.                     Case BusTypeRAID:       .SubItems(1) = "RAID"
  144.                     Case BusTypeScsi:       .SubItems(1) = "SCSI"
  145.                     Case BusTypeSsa:        .SubItems(1) = "SSA"
  146.                     Case BusTypeUnknown:    .SubItems(1) = "Unknown"
  147.                 End Select
  148.                 
  149.                 .SubItems(2) = IIf(udtInfo.Removable, "yes", "no")
  150.                 .SubItems(3) = Trim$(udtInfo.VendorID & " " & udtInfo.ProductID & " " & udtInfo.ProductRevision)
  151.                 
  152.                 .Tag = strDrives(i)
  153.             End If
  154.         End With
  155.     Next
  156. End Sub
  157.  
  158. Private Sub iSubclass_WndProc(ByVal bBefore As Boolean, bHandled As Boolean, lReturn As Long, ByVal lng_hWnd As Long, ByVal uMsg As eMsg, ByVal wParam As Long, ByVal lParam As Long, lParamUser As Long)
  159.     If uMsg = WM_DEVICECHANGE Then RefreshDriveList
  160. End Sub
  161.