mnetfolder.bas

公司订单管理系统,这对于方便公司管理床单

Attribute VB_Name = "mNetFolder"
Option Explicit

Private Const NOERROR As Long = 0
Private Const MAX_PATH As Long = 260
Private Const CSIDL_NETWORK As Long = &H12
Private Const CSIDL_PRINTERS As Long = &H4

'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 editbox to the dialog: SHELL 5.0 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 5.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 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 SHGetPathFromIDList Lib "shell32.dll" _
   Alias "SHGetPathFromIDListA" _
  (ByVal pidl As Long, _
   ByVal pszPath As String) As Long

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 Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long


Public Function GetBrowseNetworkShare(hwndOwner As Long, _
                                      bNewDialog As Boolean, _
                                      bNoNewFolder As Boolean) As String

  'returns only a valid share on a
  'network server or workstation
   Dim bi As BROWSEINFO
   Dim pidl As Long
   Dim spath As String
   
  'obtain the pidl to the special folder 'network'
   If SHGetSpecialFolderLocation(hwndOwner, _
                                 CSIDL_NETWORK, _
                                 pidl) = NOERROR Then
        
     'fill in the required members, limiting the
     'Browse to the network by specifying the
     'returned pidl as pidlRoot
      With bi
         .hOwner = hwndOwner
         .pidlRoot = pidl
         .pszDisplayName = Space$(MAX_PATH)
         .lpszTitle = "Select a network computer or share."
         .ulFlags = BIF_RETURNONLYFSDIRS
         If bNewDialog Then .ulFlags = .ulFlags Or BIF_NEWDIALOGSTYLE
         If bNoNewFolder Then .ulFlags = .ulFlags 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 get the share path
            GetBrowseNetworkShare = TrimNull(spath)
               
         Else
               
           'a server selected...follow same principle
           'as in GetBrowseNetworkWorkstation
            GetBrowseNetworkShare = "\\" & bi.pszDisplayName

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

End Function


Public Function GetBrowseNetworkWorkstation(hwndOwner As Long, _
                                            bNewDialog As Boolean, _
                                            bNoNewFolder As Boolean) As String

  'returns only a valid network server or
  'workstation (does not display the shares)
   Dim bi As BROWSEINFO
   Dim pidl As Long
   Dim spath As String
   
   If SHGetSpecialFolderLocation(hwndOwner, _
                                 CSIDL_NETWORK, _
                                 pidl) = NOERROR Then
   
     'fill in the required members
      With bi
         .hOwner = hwndOwner
         .pidlRoot = pidl
         .pszDisplayName = Space$(MAX_PATH)
         .lpszTitle = "Select a network computer."
         .ulFlags = BIF_BROWSEFORCOMPUTER
         If bNewDialog Then .ulFlags = .ulFlags Or BIF_NEWDIALOGSTYLE
         If bNoNewFolder Then .ulFlags = .ulFlags Or BIF_NONEWFOLDERBUTTON
      End With
         
      pidl = SHBrowseForFolder(bi)
      
      If pidl <> 0 Then
               
        'a machine is selected. Although a valid pidl
        'is returned, SHGetPathFromIDList only return
        'paths to valid file system objects, of which
        'a networked machine is not. However, the
        'BROWSEINFO displayname member does contain
        'the selected item, which we return
         GetBrowseNetworkWorkstation = "\\" & bi.pszDisplayName
            
         Call CoTaskMemFree(pidl)
            
      End If  'If pidl
   End If  'If SHGetSpecialFolderLocation
   
End Function

         
Private Function TrimNull(startstr As String) As String

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