试试,98下好用,2000没试过:Public Enum EShareType STYPE_DISKTREE = 0 'Disk drive STYPE_PRINTQ = 1 'Print queue STYPE_DEVICE = 2 'Communication device STYPE_IPC = 3 'Interprocess Communication (IPC) STYPE_SPECIAL = &H80000000 End Enum Private Type SHARE_INFO_50 'Used for Windows '95 only shi50_netname(0 To 12) As Byte 'LM20_NNLEN + 1 shi50_type As Byte 'EShareType shi50_flags As Integer shi50_re As Long shi50_Path As Long shi50_rw_password(0 To 8) As Byte 'SHPWLEN + 1 shi50_ro_password(0 To 8) As Byte 'SHPWLEN + 1 End Type Private Const SHI50F_RDONLY = &H1 Private Const SHI50F_FULL = &H2 Private Const SHI50F_DEPENDSON = SHI50F_RDONLY + SHI50F_FULL Private Const SHI50F_ACCESSMASK = SHI50F_RDONLY + SHI50F_FULL Private Const SHI50F_PERSIST = &H100 'Keep share after a reboot Private Const SHI50F_SYSTEM = &H200 'System share (hidden) Private Declare Function NetShareAdd95 Lib "svrapi" Alias "NetShareAdd" _ (ByVal ServerName As String, _ ByVal Level As Integer, _ ByVal buf As Long, _ ByVal cbBuffer As Integer) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)Private Sub StrToByte(strInput As String, ByVal lpByteArray As Long) Dim lpszInput() As Byte lpszInput = StrConv(strInput, vbFromUnicode) & vbNullChar CopyMemory ByVal lpByteArray, lpszInput(0), UBound(lpszInput) End SubPublic Sub ShareResource(ServerName As String, Path As String, ShareName As String, Re As String) Dim si50 As SHARE_INFO_50 Dim iErrParam As Integer Dim lpszPath() As Byte Dim lpszRe() As Byte Dim lReturnValue As LongShareName = UCase(ShareName) Path = UCase(Path) lpszPath = StrConv(Path, vbFromUnicode) & vbNullChar lpszRe = StrConv(Re, vbFromUnicode) & vbNullChar With si50 StrToByte ShareName, VarPtr(.shi50_netname(0)) .shi50_type = 0 .shi50_re = VarPtr(lpszRe(0)) .shi50_Path = VarPtr(lpszPath(0)) 'Note: I hardcoded it for no password. 'Add one to the input parameters if you'd 'like for this function to support it... StrToByte "", VarPtr(.shi50_ro_password(0)) StrToByte "", VarPtr(.shi50_rw_password(0)) .shi50_flags = SHI50F_RDONLY + SHI50F_PERSIST End With lReturnValue = NetShareAdd95(ServerName, 50, ByVal VarPtr(si50), LenB(si50)) Select Case lReturnValue Case 0 'Yay Case 2102 'NERR_NERR_NetNotStarted Err.Raise lReturnValue, "ShareResource", "Networking has not been started on this computer." Case 2114 'NERR_ServerNotStarted Err.Raise lReturnValue, "ShareResource", "The server has not been started on this computer." Case 2310 'NERR_NetNameNotFound Err.Raise lReturnValue, "ShareResource", "The computer " & ServerName & " was not found." Case 124 'ERROR_INVALID_LEVEL Err.Raise lReturnValue, "ShareResource", "Invalid level for server_info structure." Case 2123 'NERR_BufTooSmall Err.Raise lReturnValue, "ShareResource", "The buffer size specified for the server_info structure was too small." Case 2127 'NERR_RemoteErr Err.Raise lReturnValue, "ShareResource", "There has been an error on the remote computer." Case 2351 'NERR_InvalidComputer Err.Raise lReturnValue, "ShareResource", "Invalid server name. If the server is a Windows '9X machine, check to make sure file sharing is enabled." Case 234 'ERROR_MORE_DATA Err.Raise lReturnValue, "ShareResource", "More data is available." Case 87 'ERROR_INVALID_PARAMETER Err.Raise lReturnValue, "ShareResource", "An invalid parameter has been passed to NetShareAdd." Case 2118 Case Else 'Some other error Err.Raise lReturnValue, "ShareResource", "Unable to create share." End Select End Sub
注:程序中,要用代码实现,将只读权限给指定的用户
STYPE_DISKTREE = 0 'Disk drive
STYPE_PRINTQ = 1 'Print queue
STYPE_DEVICE = 2 'Communication device
STYPE_IPC = 3 'Interprocess Communication (IPC)
STYPE_SPECIAL = &H80000000
End Enum
Private Type SHARE_INFO_50 'Used for Windows '95 only
shi50_netname(0 To 12) As Byte 'LM20_NNLEN + 1
shi50_type As Byte 'EShareType
shi50_flags As Integer
shi50_re As Long
shi50_Path As Long
shi50_rw_password(0 To 8) As Byte 'SHPWLEN + 1
shi50_ro_password(0 To 8) As Byte 'SHPWLEN + 1
End Type
Private Const SHI50F_RDONLY = &H1
Private Const SHI50F_FULL = &H2
Private Const SHI50F_DEPENDSON = SHI50F_RDONLY + SHI50F_FULL
Private Const SHI50F_ACCESSMASK = SHI50F_RDONLY + SHI50F_FULL
Private Const SHI50F_PERSIST = &H100 'Keep share after a reboot
Private Const SHI50F_SYSTEM = &H200 'System share (hidden)
Private Declare Function NetShareAdd95 Lib "svrapi" Alias "NetShareAdd" _
(ByVal ServerName As String, _
ByVal Level As Integer, _
ByVal buf As Long, _
ByVal cbBuffer As Integer) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)Private Sub StrToByte(strInput As String, ByVal lpByteArray As Long)
Dim lpszInput() As Byte
lpszInput = StrConv(strInput, vbFromUnicode) & vbNullChar
CopyMemory ByVal lpByteArray, lpszInput(0), UBound(lpszInput)
End SubPublic Sub ShareResource(ServerName As String, Path As String, ShareName As String, Re As String)
Dim si50 As SHARE_INFO_50
Dim iErrParam As Integer
Dim lpszPath() As Byte
Dim lpszRe() As Byte
Dim lReturnValue As LongShareName = UCase(ShareName)
Path = UCase(Path)
lpszPath = StrConv(Path, vbFromUnicode) & vbNullChar
lpszRe = StrConv(Re, vbFromUnicode) & vbNullChar
With si50
StrToByte ShareName, VarPtr(.shi50_netname(0))
.shi50_type = 0
.shi50_re = VarPtr(lpszRe(0))
.shi50_Path = VarPtr(lpszPath(0))
'Note: I hardcoded it for no password.
'Add one to the input parameters if you'd
'like for this function to support it...
StrToByte "", VarPtr(.shi50_ro_password(0))
StrToByte "", VarPtr(.shi50_rw_password(0))
.shi50_flags = SHI50F_RDONLY + SHI50F_PERSIST
End With
lReturnValue = NetShareAdd95(ServerName, 50, ByVal VarPtr(si50), LenB(si50))
Select Case lReturnValue
Case 0 'Yay
Case 2102 'NERR_NERR_NetNotStarted
Err.Raise lReturnValue, "ShareResource", "Networking has not been started on this computer."
Case 2114 'NERR_ServerNotStarted
Err.Raise lReturnValue, "ShareResource", "The server has not been started on this computer."
Case 2310 'NERR_NetNameNotFound
Err.Raise lReturnValue, "ShareResource", "The computer " & ServerName & " was not found."
Case 124 'ERROR_INVALID_LEVEL
Err.Raise lReturnValue, "ShareResource", "Invalid level for server_info structure."
Case 2123 'NERR_BufTooSmall
Err.Raise lReturnValue, "ShareResource", "The buffer size specified for the server_info structure was too small."
Case 2127 'NERR_RemoteErr
Err.Raise lReturnValue, "ShareResource", "There has been an error on the remote computer."
Case 2351 'NERR_InvalidComputer
Err.Raise lReturnValue, "ShareResource", "Invalid server name. If the server is a Windows '9X machine, check to make sure file sharing is enabled."
Case 234 'ERROR_MORE_DATA
Err.Raise lReturnValue, "ShareResource", "More data is available."
Case 87 'ERROR_INVALID_PARAMETER
Err.Raise lReturnValue, "ShareResource", "An invalid parameter has been passed to NetShareAdd."
Case 2118
Case Else 'Some other error
Err.Raise lReturnValue, "ShareResource", "Unable to create share."
End Select
End Sub