'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
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
这个是你要的'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
'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
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
' (-> 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
'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
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
'
'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
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