VBA中调用API实现局域网连接的常用操作.doc

VBA中调用API实现局域网连接的常用操作如果常用到局域网内的其它机器上的文件，而且文件夹路径固定，又不想每次都打开该路径，可用VBA连接读取文件，这里完成“创建映射”、“断开映射”、“是否已创建映射”、“取映射路径”、“生成一个本地未用的盘符符号”、“取得本地盘符数组”等6个函数，基本上可满足平时文件操作的需要了这里使用API来实现以下代码可直接粘到EXCEL的VBA模块里面 Const NO_ERROR = 0 Const CONNECT_UPDATE_PROFILE = &H1 Const RESOURCETYPE_DISK = &H1 Const RESOURCETYPE_PRINT = &H2 Const RESOURCETYPE_ANY = &H0 Const RESOURCE_CONNECTED = &H1 Const RESOURCE_REMEMBERED = &H3 Const RESOURCE_GLOBALNET = &H2 Const RESOURCEDISPLAYTYPE_DOMAIN = &H1 Const RESOURCEDISPLAYTYPE_GENERIC = &H0 Const RESOURCEDISPLAYTYPE_SERVER = &H2 Const RESOURCEDISPLAYTYPE_SHARE = &H3 Const RESOURCEUSAGE_CONNECTABLE = &H1 Const RESOURCEUSAGE_CONTAINER = &H2Private Type NETRESOURCE dwScope As Long dwType As Long dwDisplayType As Long dwUsage As Long lpLocalName As String lpRemoteName As String lpComment As String lpProvider As StringEnd TypePrivate Declare Function WNetAddConnection2 Lib mpr.dll Alias WNetAddConnection2A (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As LongPrivate Declare Function WNetCancelConnection2 Lib mpr.dll Alias WNetCancelConnection2A (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As LongPrivate Declare Function WNetGetConnection Lib mpr.dll Alias WNetGetConnectionA (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As LongFunction 创建映射(网络路径 As String, 用户名 As String, 密码 As String, 本地盘符 As String) As Boolean Dim NetR As NETRESOURCE Dim ErrInfo As Long Dim pf As String Dim lj As String pf = 本地盘符 If Right(本地盘符, 1) : Then pf = pf & : End If lj = 网络路径 If Right(lj, 1) = Then lj = Left(lj, Len(lj) - 1) End If NetR.dwScope = &H2 NetR.dwType = &H1 NetR.dwDisplayType = &H3 NetR.dwUsage = &H1 NetR.lpLocalName = pf NetR.lpRemoteName = lj ErrInfo = WNetAddConnection2(NetR, 密码, 用户名, &H1) If ErrInfo = 0 Then 创建映射 = True Else 创建映射 = False End If End FunctionFunction 断开映射(本地盘符 As String) As Boolean Dim ErrInfo As Long Dim strLocalName As String strLocalName = 本地盘符 If Right(strLocalName, 1) : Then strLocalName = strLocalName & : End If ErrInfo = WNetCancelConnection2(strLocalName, &H1, False) If ErrInfo = 0 Then 断开映射 = True Else 断开映射 = False End IfEnd FunctionFunction 是否已创建映射(盘符 As String) As Boolean Dim lj As String Dim LocalName As String Dim NetName As String Dim LenNetName As Long Dim jg As Long LocalName = 盘符 If Right(LocalName, 1) : Then LocalName = LocalName & : End If NetName = String$(255, Chr$(32) LenNetName = Len(NetName) jg = WNetGetConnection(LocalName, NetName, LenNetName) If jg = 0 Then 是否已创建映射 = True Else 是否已创建映射 = False End If End FunctionFunction 取映射路径(本地盘符 As String) As String Dim lj As String Dim LocalName As String Dim NetName As String Dim LenNetName As Long Dim jg As Long LocalName = 本地盘符 If Right(LocalName, 1) : Then LocalName = LocalName & : End If NetName = String$(255, Chr$(32) LenNetName = Len(NetName) jg = WNetGetConnection(LocalName, NetName, LenNetName) If jg = 0 Then 取映射路径 = NetName Else 取映射路径 = 未映射 End IfEnd FunctionFunction 生成盘符() As String Dim yypf() As String Dim zf(26) As String Dim pfs As Integer Dim js As Integer Dim jc As Integer Dim bz As Boolean Dim pf As String For js = 1 To 26 zf(js) = Chr(js + 64) Next yypf = 取已用驱动器列表() pfs = UBound(yypf) For js = 1 To 26 bz = False For jc = 1 To pfs If StrComp(zf(js), yypf(jc), vbTextCompare) = 0 Then bz = True Exit For End If Next If bz = False Then pf = zf(js) Exit For End If Next Erase zf Erase yypf 生成盘符 = pfEnd FunctionFunction 取已用驱动器列表() As String() Dim fso As Object Dim d As Object Dim dc As Object Dim s As String Dim pf() As String Dim js As Integer Set fso = CreateObject(Scripting.FileSystemObje