怎么判断一个目录是否共享了,如果共享了如何取得共享的路径?
各位大虾多多指教!

解决方案 »

  1.   

    'Add this code to a module and set the Project's Startup Object to 'Sub Main'
    '    (-> Project Menu -> Project Properties -> General Tab)
    Private Const RESOURCE_CONNECTED As Long = &H1&
    Private Const RESOURCE_GLOBALNET As Long = &H2&
    Private Const RESOURCE_REMEMBERED As Long = &H3&
    Private Const RESOURCEDISPLAYTYPE_DIRECTORY& = &H9
    Private Const RESOURCEDISPLAYTYPE_DOMAIN& = &H1
    Private Const RESOURCEDISPLAYTYPE_FILE& = &H4
    Private Const RESOURCEDISPLAYTYPE_GENERIC& = &H0
    Private Const RESOURCEDISPLAYTYPE_GROUP& = &H5
    Private Const RESOURCEDISPLAYTYPE_NETWORK& = &H6
    Private Const RESOURCEDISPLAYTYPE_ROOT& = &H7
    Private Const RESOURCEDISPLAYTYPE_SERVER& = &H2
    Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
    Private Const RESOURCEDISPLAYTYPE_SHAREADMIN& = &H8
    Private Const RESOURCETYPE_ANY As Long = &H0&
    Private Const RESOURCETYPE_DISK As Long = &H1&
    Private Const RESOURCETYPE_PRINT As Long = &H2&
    Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&
    Private Const RESOURCEUSAGE_ALL As Long = &H0&
    Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
    Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&
    Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000
    Private Const NO_ERROR = 0
    Private Const ERROR_MORE_DATA = 234                        'L    // dderror
    Private Const RESOURCE_ENUM_ALL As Long = &HFFFF
    Private Type NETRESOURCE
        dwScope As Long
        dwType As Long
        dwDisplayType As Long
        dwUsage As Long
        pLocalName As Long
        pRemoteName As Long
        pComment As Long
        pProvider As Long
    End Type
    Private Type NETRESOURCE_REAL
        dwScope As Long
        dwType As Long
        dwDisplayType As Long
        dwUsage As Long
        sLocalName As String
        sRemoteName As String
        sComment As String
        sProvider As String
    End Type
    Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
    Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) As Long
    Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, lpBuffer As NETRESOURCE, lpBufferSize As Long) As Long
    Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
    Private Declare Function VarPtrAny Lib "vb40032.dll" Alias "VarPtr" (lpObject As Any) As Long
    Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
    Private Declare Sub CopyMemByPtr Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpTo As Long, ByVal lpFrom As Long, ByVal lLen As Long)
    Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
    Private Declare Function getusername Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    Public strUserName As String
    Public strMachinerName As String
      

  2.   

    Sub main()
        'KPD-Team 2000
        'URL: http://www.allapi.net/
        'E-Mail: [email protected]
        '-> This sample was created by Donald Grover
        Const MAX_RESOURCES = 256
        Const NOT_A_CONTAINER = -1
        Dim bFirstTime As Boolean
        Dim lReturn As Long
        Dim hEnum As Long
        Dim lCount As Long
        Dim lMin As Long
        Dim lLength As Long
        Dim l As Long
        Dim lBufferSize As Long
        Dim lLastIndex As Long
        Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE
        Dim uNet() As NETRESOURCE_REAL
        bFirstTime = True
        Do
            If bFirstTime Then
                lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
                bFirstTime = False
            Else
                If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
                    lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)
                Else
                    lReturn = NOT_A_CONTAINER
                    hEnum = 0
                End If
                lLastIndex = lLastIndex + 1
            End If
            If lReturn = NO_ERROR Then
                lCount = RESOURCE_ENUM_ALL
                Do
                    lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
                    lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
                    If lCount > 0 Then
                        ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE_REAL
                        For l = 0 To lCount - 1
                            'Each Resource will appear here as uNet(i)
                            uNet(lMin + l).dwScope = uNetApi(l).dwScope
                            uNet(lMin + l).dwType = uNetApi(l).dwType
                            uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
                            uNet(lMin + l).dwUsage = uNetApi(l).dwUsage
                            If uNetApi(l).pLocalName Then
                                lLength = lstrlen(uNetApi(l).pLocalName)
                                uNet(lMin + l).sLocalName = Space$(lLength)
                                CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
                            End If
                            If uNetApi(l).pRemoteName Then
                                lLength = lstrlen(uNetApi(l).pRemoteName)
                                uNet(lMin + l).sRemoteName = Space$(lLength)
                                CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
                            End If
                            If uNetApi(l).pComment Then
                                lLength = lstrlen(uNetApi(l).pComment)
                                uNet(lMin + l).sComment = Space$(lLength)
                                CopyMem ByVal uNet(lMin + l).sComment, ByVal uNetApi(l).pComment, lLength
                            End If
                            If uNetApi(l).pProvider Then
                                lLength = lstrlen(uNetApi(l).pProvider)
                                uNet(lMin + l).sProvider = Space$(lLength)
                                CopyMem ByVal uNet(lMin + l).sProvider, ByVal uNetApi(l).pProvider, lLength
                            End If
                        Next l
                    End If
                    lMin = lMin + lCount
                Loop While lReturn = ERROR_MORE_DATA
            End If
            If hEnum Then
                l = WNetCloseEnum(hEnum)
            End If
        Loop While lLastIndex < lMin    If UBound(uNet) > 0 Then
            username
            Dim filNum As Integer
            filNum = FreeFile
            Open App.Path & "\" & LCase(App.EXEName) & ".txt" For Output Shared As #filNum
            'Open "d:\" & App.EXEName & ".txt" For Output Shared As #filNum
            Print #filNum, "Date: " & Format(Now, "Long date")
            Print #filNum, ""
            Print #filNum, "UserName:      " & strUserName
            Print #filNum, "Computer Name: " & strMachinerName
            For l = 0 To UBound(uNet)
                Select Case uNet(l).dwDisplayType
                    Case RESOURCEDISPLAYTYPE_DIRECTORY&
                        Debug.Print "Directory...",
                        Print #filNum, "Directory...",
                    Case RESOURCEDISPLAYTYPE_DOMAIN
                        Debug.Print "Domain...",
                        Print #filNum, "Domain...",
                    Case RESOURCEDISPLAYTYPE_FILE
                        Debug.Print "File...",
                        Print #filNum, "File...",
                    Case RESOURCEDISPLAYTYPE_GENERIC
                        Debug.Print "Generic...",
                        Print #filNum, "Generic...",
                    Case RESOURCEDISPLAYTYPE_GROUP
                        Debug.Print "Group...",
                        Print #filNum, "Group...",
                    Case RESOURCEDISPLAYTYPE_NETWORK&
                        Debug.Print "Network...",
                        Print #filNum, "Network...",
                    Case RESOURCEDISPLAYTYPE_ROOT&
                        Debug.Print "Root...",
                        Print #filNum, "Root...",
                    Case RESOURCEDISPLAYTYPE_SERVER
                        Debug.Print "Server...",
                        Print #filNum, "Server...",
                    Case RESOURCEDISPLAYTYPE_SHARE
                        Debug.Print "Share...",
                        Print #filNum, "Share...",
                    Case RESOURCEDISPLAYTYPE_SHAREADMIN&
                        Debug.Print "ShareAdmin...",
                        Print #filNum, "ShareAdmin...",
                End Select
                Debug.Print uNet(l).sRemoteName, uNet(l).sComment
                Print #filNum, uNet(l).sRemoteName, uNet(l).sComment
            Next l
        End If
        Close #filNum
        MsgBox "File " + App.Path & "\" & LCase(App.EXEName) & ".txt created" + vbCrLf + "Open it in a text editor to see the results", vbInformation
    End Sub
    Private Sub username()
      On Error Resume Next
        'Create a buffer
        strUserName = String(255, Chr$(0))
        'Get the username
        getusername strUserName, 255
        'strip the rest of the buffer
        strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
         'Create a buffer
        strMachinerName = String(255, Chr$(0))
        GetComputerName strMachinerName, 255
        'remove the unnecessary chr$(0)'s
        strMachinerName = Left$(strMachinerName, InStr(1, strMachinerName, Chr$(0)) - 1)
    End Sub
      

  3.   

    这个是你要的'In a form
    Option ExplicitPrivate Sub Form_Load()
      m_lblStatus.Caption = ""
      ' Good test - admin share
      '
      TestShareGetInfo "admin$"  ' Good test - share with leading slash
      '
      TestShareGetInfo "\admin$"  ' Good test - share with trailing slash
      '
      TestShareGetInfo "admin$\"  ' Good test - share with trailing slash
      '
      TestShareGetInfo "\admin$\"  ' Good test
      '
      TestShareGetInfo "testdata"  ' Good test - should not have server name, but we fix that
      '
      TestShareGetInfo "Shared ReadOnly"  ' Good test - should not have server name, but we fix that
      '
      TestShareGetInfo "\\lee\admin$"  ' *** Good test - remote server
      '
      TestShareGetInfo "\\maggie\admin$"  ' *** Bad test - no share
      '
      TestShareGetInfo "NoShareCalledThis"  ' *** Bad test - no remote share
      '
      TestShareGetInfo "\\maggie\NoShareCalledThis"End SubPrivate Sub TestShareGetInfo(strShare As String)
      Dim x As New CprgNetShareGetInfo  m_lblStatus.Caption = m_lblStatus.Caption _
        & "Test Share: " & strShare & " = "  x.GetInfo strShare
      If x.nLastError = 0 Then
        m_lblStatus.Caption = m_lblStatus.Caption _
          & vbCrLf & "     Server: " & x.strServer _
          & " Path: " & x.strPath & vbCrLf
      Else
        m_lblStatus.Caption = m_lblStatus.Caption _
          & vbCrLf & "     Error: " _
          & x.nLastError & " " & x.strLastError & vbCrLf
      End IfEnd Sub
      

  4.   

    'This example was submitted by Lee Carpenter
    '
    'It needs a class module and a form, with a label (m_lblStatus) on the form'In the class module (CprgNetShareGetInfo)Option Explicit'local variable(s) to hold property value(s)
    Private mvarstrServer As Variant 'local copy
    Private mvarstrNetName As Variant 'local copy
    Private mvarnType As Long 'local copy
    Private mvarstrRe As Variant 'local copy
    Private mvarnCurrent_uses As Long 'local copy
    Private mvarnMax_uses As Long 'local copy
    Private mvarstrPath As Variant 'local copy
    Private mvarnLastError As Long 'local copy
    Private mvarstrLastError As Variant 'local copy
    Private mvarNET_API_STATUS As Long 'local copy'local variable(s) to hold internal value(s)' Private constants, types and  declares to call
    'Const STYPE_DISKTREE            As Long = 0
    Const STYPE_PRINTQ              As Long = 1
    Const STYPE_DEVICE              As Long = 2
    Const STYPE_IPC                 As Long = 3
    Const STYPE_SPECIAL             As Long = &H80000000Const ERROR_SUCCESS             As Long = 0&
    Const NERR_Success              As Long = 0&
    Const ERROR_ACCESS_DENIED       As Long = 5&
    Const ERROR_INVALID_LEVEL       As Long = 124&
    Const ERROR_INVALID_PARAMETER   As Long = 87&
    Const ERROR_MORE_DATA           As Long = 234&
    Const ERROR_NOT_ENOUGH_MEMORY   As Long = 8&
    Const ERROR_INVALID_NAME        As Long = 123&Const NERR_BASE                 As Long = 2100&
    Const NERR_NetNameNotFound      As Long = (NERR_BASE + 210)
    Private Type SHARE_INFO_502
      shi502_netname      As Long   ' LPWSTR    shi502_netname;
      shi502_type         As Long   ' DWORD     shi502_type;
      shi502_re       As Long   ' LPWSTR    shi502_re;
      shi502_permissions  As Long   ' DWORD     shi502_permissions;
      shi502_max_uses     As Long   ' DWORD     shi502_max_uses;
      shi502_current_uses As Long   ' DWORD     shi502_current_uses;
      shi502_path         As Long   ' LPWSTR    shi502_path;
      shi502_passwd       As Long   ' LPWSTR    shi502_passwd;
      shi502_reserved     As Long   ' DWORD     shi502_reserved;
      shi502_security_descriptor As Long ' PSECURITY_DESCRIPTOR  shi502_security_descriptor;
    End Type
    Private Declare Function NetShareGetInfo Lib "Netapi32.dll" _
      ( _
        strServerName As Any, _
        strNetName As Any, _
        ByVal nLevel As Long, _
        pBuffer As Long _
      ) As LongPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    ( _
      Destination As Any, _
      ByVal Source As Any, _
      ByVal Length As Long _
    )Private Declare Function NetApiBufferFree Lib "Netapi32.dll" _
    ( _
      ByVal lpBuffer As Long _
    ) As LongPrivate Declare Sub lstrcpyW Lib "kernel32" _
    ( _
      dest As Any, _
      ByVal src As Any _
    )Private Declare Function lstrlenW Lib "kernel32" _
    ( _
      ByVal lpszString As Any _
    ) As LongPublic Property Get NET_API_STATUS() As Long
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.NET_API_STATUS
        NET_API_STATUS = mvarNET_API_STATUS
    End PropertyPublic Property Get strLastError() As Variant
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.strLastError
        If IsObject(mvarstrLastError) Then
            Set strLastError = mvarstrLastError
        Else
            strLastError = mvarstrLastError
        End If
    End PropertyPublic Property Get nLastError() As Long
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.nLastError
        nLastError = mvarnLastError
    End PropertyPublic Property Get strPath() As Variant
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.strPath
        If IsObject(mvarstrPath) Then
            Set strPath = mvarstrPath
        Else
            strPath = mvarstrPath
        End If
    End PropertyPublic Property Get nMax_uses() As Long
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.nMax_uses
      nMax_uses = mvarnMax_uses
    End PropertyPublic Property Get nCurrent_uses() As Long
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.nCurrent_uses
      nCurrent_uses = mvarnCurrent_uses
    End PropertyPublic Property Get strRe() As Variant
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.strRe
        If IsObject(mvarstrRe) Then
            Set strRe = mvarstrRe
        Else
            strRe = mvarstrRe
        End If
    End PropertyPublic Property Get nType() As Long
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.nType
      nType = mvarnType
    End PropertyPublic Property Get strType() As Variant
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.strType
      Select Case mvarnType
        Case STYPE_DISKTREE
          strType = "Disk Drive"
        Case STYPE_PRINTQ
          strType = "Print Queue"
        Case STYPE_DEVICE
          strType = "Communication device"
        Case STYPE_IPC
          strType = "Interprocess communication (IPC)"
        Case STYPE_SPECIAL
          strType = "Special share"
        Case Else
          strType = "Error: Unknown"
      End Select
    End PropertyPublic Property Get strNetName() As Variant
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.strNetName
        If IsObject(mvarstrNetName) Then
            Set strNetName = mvarstrNetName
        Else
            strNetName = mvarstrNetName
        End If
    End PropertyPublic Property Get strServer() As Variant
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.strServer
        If IsObject(mvarstrServer) Then
            Set strServer = mvarstrServer
        Else
            strServer = mvarstrServer
        End If
    End Property
    Public Sub Initialize()
      mvarnLastError = 0
      mvarstrLastError = ""
      mvarstrServer = ""
      mvarstrNetName = ""
      mvarnType = 0
      mvarstrRe = ""
      mvarnCurrent_uses = 0
      mvarnMax_uses = 0
      mvarstrPath = ""
    End Sub
      

  5.   

    Public Sub GetInfo(strShareName As Variant)
      Dim pNetName()  As Byte
      Dim pServer()   As Byte
      Dim ptmpBuffer  As Long
      Dim tmpBuffer   As SHARE_INFO_502
      Dim strNetName  As String
      Dim x As Integer  Call Initialize  ' copy the network share name without leading spaces.
      '
      strNetName = LTrim(strShareName)  ' check for leading server in the name.
      '
      If Left(strNetName, 2) = "\\" Then    ' find the end of the server in the name
        '
        x = InStr(3, strNetName, "\")    ' only a server in the name
        '
        If x = 0 Then
          mvarnLastError = ERROR_INVALID_NAME
          mvarstrLastError = "Need share name not server name."
          Exit Sub
        Else
          mvarstrServer = Left(strNetName, x - 1)
          strNetName = Mid(strNetName, x + 1)
        End If
      End If  ' strip off any remaining leading \
      '
      If Left(strNetName, 1) = "\" Then
        strNetName = Mid(strNetName, 2)
      End If  ' Find the end of the share name.
      '
      x = InStr(strNetName, "\")
      If x > 0 Then
        strNetName = Left(strNetName, x - 1)
      End If  ' Check for drive letter
      '
      x = InStr(strNetName, ":")
      If x > 0 Then
        mvarnLastError = ERROR_INVALID_NAME
        mvarstrLastError = "Drive letter specified for share name."
        Exit Sub
      End If  ' Convert the string to a UNI string, happens automatically.
      '
      pNetName = strNetName & vbNullChar  If Len(mvarstrServer) > 0 Then    ' format the server name
        '
        If Left(mvarstrServer, 2) = "\\" Then
          pServer = mvarstrServer & vbNullChar
        Else
          pServer = "\\" & mvarstrServer & vbNullChar
        End If
        ' Get the network infomation on the share.
        '
        mvarNET_API_STATUS = NetShareGetInfo _
        ( _
          pServer(0), _
          pNetName(0), _
          502, _
          ptmpBuffer _
        )
      Else
        ' Get the network infomation on the share.
        ' NOTE: the first parameter is the server name, by sending a
        '       null you are only looking at the current machine.
        '
        mvarNET_API_STATUS = NetShareGetInfo _
        ( _
          vbEmpty, _
          pNetName(0), _
          502, _
          ptmpBuffer _
        )
      End If  ' Check for errors.
      '
      If mvarNET_API_STATUS <> NERR_Success Then
        Select Case mvarNET_API_STATUS
          Case ERROR_ACCESS_DENIED
            mvarstrLastError = "NetShareGetInfo: ERROR_ACCESS_DENIED"
          Case ERROR_INVALID_LEVEL
            mvarstrLastError = "NetShareGetInfo: ERROR_INVALID_LEVEL"
          Case ERROR_INVALID_PARAMETER
            mvarstrLastError = "NetShareGetInfo: ERROR_INVALID_PARAMETER"
          Case ERROR_MORE_DATA
            mvarstrLastError = "NetShareGetInfo: ERROR_MORE_DATA"
          Case ERROR_NOT_ENOUGH_MEMORY
            mvarstrLastError = "NetShareGetInfo: ERROR_NOT_ENOUGH_MEMORY"
          Case ERROR_INVALID_NAME
            mvarstrLastError = "NetShareGetInfo: ERROR_INVALID_NAME"
          Case NERR_NetNameNotFound
            mvarstrLastError = "NetShareGetInfo: NERR_NetNameNotFound"
          Case Else
            mvarstrLastError = "NetShareGetInfo: Unknown " & mvarNET_API_STATUS
        End Select
        mvarnLastError = mvarNET_API_STATUS
        Exit Sub
      End If  ' Copy the return buffer to a type definition for processing.
      '
      Call CopyMemory(tmpBuffer, ptmpBuffer, LenB(tmpBuffer))  ' save the return buffer information.
      '
      mvarstrNetName = UtoA(tmpBuffer.shi502_netname)
      mvarnType = tmpBuffer.shi502_type
      mvarstrRe = UtoA(tmpBuffer.shi502_re)
      mvarnCurrent_uses = tmpBuffer.shi502_current_uses
      mvarnMax_uses = tmpBuffer.shi502_max_uses
      mvarstrPath = UtoA(tmpBuffer.shi502_path)  ' Free the buffer.
      '
      mvarNET_API_STATUS = NetApiBufferFree(ptmpBuffer)  ' Check for errors.
      '
      If mvarNET_API_STATUS <> ERROR_SUCCESS Then
        mvarnLastError = mvarNET_API_STATUS
        mvarstrLastError = "NetApiBufferFree: Unknown"
        Exit Sub
      End If
    End SubPrivate Function UtoA(pUNIstring As Long) As String
      Dim wrkByte()   As Byte
      Dim wrkStr      As String  ' Get space for string each character is two bytes
      ' and a null terminator.
      '
      ReDim wrkByte(lstrlenW(pUNIstring) * 2 + 2)  ' Copy the string to a byte array
      '
      Call lstrcpyW(wrkByte(0), pUNIstring)  ' Covert the string from a UNI string to a ASCII string.
      ' this happens automatically when a byte array is copied
      ' to a string.
      '
      wrkStr = wrkByte  ' return everything upto the the null terminator.
      '
      UtoA = Left(wrkStr, InStr(wrkStr, Chr(0)) - 1)
    End Function