Public Const NOERROR As Long = 0
Public Const CSIDL_DRIVES As Long = &H11
Public Const DRIVE_CDROM As Long = 5
Public Const MAX_PATH As Long = 260

Public Declare Function GetDriveType Lib "kernel32" _
   Alias "GetDriveTypeA" _
  (ByVal nDrive As String) As Long

Private Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long
    
'messages from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILED As Long = 3

'messages to browser
Private Const WM_USER = &H400
Private Const BFFM_SETSTATUSTEXT  As Long = (WM_USER + 100)
Private Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Private Const BFFM_SETSELECTION As Long = (WM_USER + 102)

Public Declare Function SHGetPathFromIDList Lib "shell32" _
     Alias "SHGetPathFromIDListA" _
     (ByVal pidl As Long, ByVal pszPath As String) As Long
     
Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long
  

Public Function BrowseDriveCallbackProc(ByVal hwnd As Long, _
                                        ByVal uMsg As Long, _
                                        ByVal lParam As Long, _
                                        ByVal lpData As Long) As Long
   Dim spath As String
   Dim bFlag As Long

   Select Case uMsg
      
      Case BFFM_INITIALIZED
        'disable selection of the root item
        'on startup
         Call SendMessage(hwnd, BFFM_ENABLEOK, 0, ByVal 0&)
         
        'although not used in creating the screen shot, 
        'above, we can change the caption of the dialog
        'from the usual Browse For Folders, which is now
        'misleading, to something more applicable
         Call SetWindowText(hwnd, "Browse for CD/DVD Drive") 
      
      Case BFFM_SELCHANGED
         
        'a buffer for SHGetPathFromIDList
         spath = Space$(MAX_PATH)
         
        'lparam contains the PIDL of the
        'selected item, which can be resolved
        'to a file system path with SHGetPathFromIDList
         If SHGetPathFromIDList(lParam, spath) Then

           'if drive type is CD set True othewise False
            bFlag = (GetDriveType(spath) = DRIVE_CDROM)
            Call SendMessage(hwnd, BFFM_ENABLEOK, 0, ByVal bFlag)
         
         End If
      
      Case Else

   End Select

End Function


Public Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
   
End Function


Public Function FARPROC(pfn As Long) As Long
  
  'A dummy procedure that receives and returns
  'the value of the AddressOf operator.
 
  'This workaround is needed as you can't 
  'assign AddressOf directly to a member of a 
  'user-defined type, but you can assign it 
  'to another long and use that instead! 
  FARPROC = pfn

End Function

'For finding a folder to start document searching
Private Const BIF_RETURNONLYFSDIRS As Long = &H1

'For starting the Find Computer
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2

'Top of the dialog has 2 lines of text for
'BROWSEINFO.lpszTitle and one line if this flag is set.
'Passing the message BFFM_SETSTATUSTEXTA to the hwnd
'can set the rest of the text.  This is not used with
'BIF_USENEWUI and BROWSEINFO.lpszTitle gets all three
'lines of text.
Private Const BIF_STATUSTEXT As Long = &H4

Private Const BIF_RETURNFSANCESTORS As Long = &H8

'Add an edit box to the dialog: SHELL 4.71 or later only!
Private Const BIF_EDITBOX As Long = &H10

'insist on valid result (or CANCEL)
Private Const BIF_VALIDATE As Long = &H20

'Use the new dialog layout with the ability 
'to resize: SHELL 5.0 or later only!
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_USENEWUI As Long = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)

'Allow URLs to be displayed or entered 
'(Requires BIF_USENEWUI): SHELL 5.0 or later only!
Private Const BIF_BROWSEINCLUDEURLS As Long = &H80

'Add a UA hint to the dialog, in place of the
'edit box. May not be combined with BIF_EDITBOX: SHELL 6.0 or later only!
Private Const BIF_UAHINT As Long = &H100

'Do not add the "New Folder" button to the dialog.
'Only applicable with BIF_NEWDIALOGSTYLE: SHELL 6.0 or later only!
Private Const BIF_NONEWFOLDERBUTTON As Long = &H200

'Browsing for Computers
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000

'Browsing for Printers
Private Const BIF_BROWSEFORPRINTER As Long = &H2000

'Browsing for Everything
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000

'sharable resources on remote systems displayed  
'(remote shares, requires BIF_USENEWUI): SHELL 5.0 or later only!
Private Const BIF_SHAREABLE As Long = &H8000&

Private Type BROWSEINFO    'bi
   hOwner As Long
   pidlRoot As Long
   pszDisplayName As String   'return display name of item selected
   lpszTitle As String        'text to go in the banner over the tree
   ulFlags As Long            'flags that control the return stuff
   lpfn As Long
   lParam As Long             'extra info passed back in callbacks
   iImage As Long             'output var: where to return the Image index
End Type

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
   Alias "SHBrowseForFolderA" _
  (lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHGetSpecialFolderLocation _
   Lib "shell32.dll" _
  (ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   pidl As Long) As Long
   
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)


Private Sub Form_Load()
   
   Command1.Caption = "Select only CD ROMs"
   Check1.Caption = "Use New UI"
   Text1.Text = ""
   Text2.Text = ""
   
End Sub


Private Sub Command1_Click()

   Dim bNewDialog As Boolean
   
   bNewDialog = Check1.Value = vbChecked
   
   Text1.Text = GetBrowseCdrom(Me.hwnd, bNewDialog)

End Sub

  
Private Function GetBrowseCdrom(hwndOwner As Long, _
                                bNewDialog As Boolean) As String

  'return only a valid local CD or DVD
   Dim bi As BROWSEINFO
   Dim pidl As Long
   Dim spath As String
   
  'obtain the pidl to the special folder 'drives'
   If SHGetSpecialFolderLocation(hwndOwner, _
                                 CSIDL_DRIVES, _
                                 pidl) = NOERROR Then
        
     'fill in the required members, limiting the
     'Browse to the local file system by specifying
     'the returned pidl as pidlRoot
      With bi
         .hOwner = hwndOwner
         .pidlRoot = pidl
         .pszDisplayName = Space$(MAX_PATH) 'return value-param name is misleading!
         .lpszTitle = "Select any CD-ROM or DVD (reader or writer)" 'message, not dialog title!
         .lpfn = FARPROC(AddressOf BrowseDriveCallbackProc)
         .ulFlags = BIF_RETURNONLYFSDIRS Or _
                    BIF_VALIDATE
        
        'if the shell version is 5.0 or greater 
        'the new UI style can be applied. If the 
        'shell version is 6.0 or later, using 
        'BIF_NEWDIALOGSTYLE will display a New Folder 
        'button by default. Since we're returning CD/DVDs, 
        'we add the 'no new folder' flag if the new UI 
        'is chosen.
         If bNewDialog Then .ulFlags = .ulFlags Or _
                                        BIF_NEWDIALOGSTYLE Or _
                                        BIF_NONEWFOLDERBUTTON
                                       
      End With
      
     'show the browse dialog and return
     'the PIDL for the selected folder
      pidl = SHBrowseForFolder(bi)
         
      If pidl <> 0 Then
         
        'got a PIDL .. is it valid?
         spath = Space$(MAX_PATH)
         If SHGetPathFromIDList(ByVal pidl, ByVal spath) Then
               
           'valid, so return the drive
            GetBrowseCdrom = TrimNull(spath)
           
           'but first, just for this demo info,
           'set Text2 to show the displayname
           'returned from the call
            Text2.Text = bi.pszDisplayName

         End If 'If SHGetPathFromIDList
         
         Call CoTaskMemFree(pidl)
         
      End If 'If pidl
   End If 'If SHGetSpecialFolderLocation

End Function