# Enum 语句应用方案

## 知识概述

当一个变量有两个或两个以上的值时，就可以通过使用 Enum 语句定义这个变量为枚举型数据类型，在这个变量中各成员的值都可以称为枚举值。

Enum 语句语法：

[Public | Private] Enum <枚举数据名称>

<成员 1> [= <表达式>]

<成员 2> [= <表达式>]

……

<成员 n> [= <表达式>]

End Enum

枚举型数据语法中各参数的说明如表 1 所示。

表 1 参数说明

参数 | 描述
Public | 可选的。表示该 Enum 类型在整个工程中都是可见的。Enum 类型的默认情况是 Public
Private | 可选的。表示该 Enum 类型只在所声明的模块中是可见的
枚举数据名称 | 必需的。该 Enum 类型的名称。枚举数据名称必须是一个合法的 Visual Basic 标识符，在定义该 Enum 类型的变量或参数时用该名称来指定类型
成员 | 必需的。用于指定该 Enum 类型的组成元素名称的合法 Visual Basic 标识符
表达式 | 可选的。元素的值（为 Long 类型）。可以是别的 Enum 类型。如果没有指定表达式，则所赋给的值或者是 0（如果该元素是第一个成员），或者比其直接前驱的值大 1

示例

枚举变量就是指用 Enum 类型定义的变量。变量和参数都可以定义为 Enum 类型。Enum 类型中的元素被初始化为 Enum 语句中指定的常数值。所赋给的值可以包括正数和负数，并且在运行时不能改变。下面的示例演示用 Enum 语句定义一个命名常数的集合。

程序运行结果如图 1 所示。

图 1 Enum 语句运行结果

完整程序代码如下：

Option Explicit

Public Enum InterfaceColors

icMistyRose = &HE1E4FF

icSlateGray = &H908070

icDodgerBlue = &HFF901E

icDeepSkyBlue = &HFFBF00

icSpringGreen = &H7FFF00

icForestGreen = &H228B22

icGoldenrod = &H20A5DA

icFirebrick = &H2222B2

End Enum

Private Sub Command1_Click()

Debug.Print InterfaceColors.icMistyRose

Debug.Print InterfaceColors.icSlateGray

Debug.Print InterfaceColors.icDodgerBlue

Debug.Print InterfaceColors.icDeepSkyBlue

Debug.Print InterfaceColors.icSpringGreen

Debug.Print InterfaceColors.icForestGreen

Debug.Print InterfaceColors.icGoldenrod

Debug.Print InterfaceColors.icFirebrick

End Sub

注意：具有相同名字的 Public Enum 类型不能既在标准模块中定义，又在类模块中定义，因为它们共享相同的命名空间。若不同的类型库中有两个Enum类型的名字相同，但成员不同，则对这种类型的变量的引用，将取决于哪一个类型库具有更高的引用优先级。不能在With块中使用Enum类型作为目标。

## 应用一：在立即窗口中显示按钮值

将“Week”枚举数据类型的值分别设置为“1～7”，实现单击“1”～“7”按钮访问“Week”枚举数据类型中相应的数值，并将该值输出在立即窗口中的功能。如图 1 所示。

图 1 枚举型数据类型

#### 程序代码如下

Enum Week

a = 1

b = 2

c = 3

d = 4

e = 5

f = 6

g = 7

End Enum

Private Sub Command1_Click()

Debug.Print Week.a

End Sub

Private Sub Command7_Click()

Debug.Print Week.g

End Sub

#### 程序完整代码

Option Explicit

Enum Week

a = 1

b = 2

c = 3

d = 4

e = 5

f = 6

g = 7

End Enum

Private Sub Command1_Click()

Debug.Print Week.a

End Sub

Private Sub Command2_Click()

Debug.Print Week.b

End Sub

Private Sub Command3_Click()

Debug.Print Week.c

End Sub

Private Sub Command4_Click()

Debug.Print Week.d

End Sub

Private Sub Command5_Click()

Debug.Print Week.e

End Sub

Private Sub Command6_Click()

Debug.Print Week.f

End Sub

Private Sub Command7_Click()

Debug.Print Week.g

End Sub

## 应用二：发送电子邮件附件

### 实例说明

本实例实现如何在应用程序中向指定的邮箱地址中发送电子邮件附件，如图 1 所示。在窗体的文本框中输入 SMTP 主机、收发电子邮件的地址、邮件附件的名称等信息后，单击“添加附件”按钮，在弹出的对话框中选择要添加的附件，此时，所选择的附件的路径即显示在邮件附件列表中，单击“发送信息”按钮，发送邮件附件。

图 1 发送电子邮件附件

### 思路与技术

通过用户自定义的 UUEncodeFile 函数实现发送电子邮件附件的功能，该函数保存到模块中，利用 For 循环调用 UUEncodeFile 函数可以实现邮件附件列表中所有的附件信息。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，命名为 frmSendMail，BorderStyle 属性设置为 1-Fixed Single。

（2）在窗体上添加 4 个 Label 控件和 4 个 TextBox 控件。

（3）在窗体上添加 3 个 CommandButton 控件，将其 Caption 属性分别设置为“新信息”、“发送信息”和“关闭”，名称分别命名为 CmdNew、CmdSend 和 CmdClose。

（4）在窗体上添加一个 Frame 控件，将控件的 Caption 属性设置为“邮件列表”。

（5）在 Frame 控件上添加一个 ListBox 控件，名称设置为 lstAttachments。

（6）在 Frame 控件上添加两个 CommandButton 控件，Caption 属性分别设置为“添加附件”和“删除附件”。

（7） 在“部件”对话框中添加 Microsoft Winsock Control 6.0 控件，在窗体上添加一个 Winsock 控件，名称取默认值。

（8）在工程中添加一个模块，命名为 MUUEncode。

表 1 frmSendMain 窗体中控件部分属性设置

控件名 | 属性 | 值
CommandButton | Name Caption | cmdAddFile 添加附件
CommandButton | Name Caption | cmdClose 退出
CommandButton | Name Caption | cmdNew 编写邮件
CommandButton | Name Caption | cmdRemove 删除附件
CommandButton | Name Caption | cmdSend 发送邮件
CommonDialog | Name | ComDialog
Frame | Name Caption | Frame1 邮件附件
Label | Name Caption | Label1 SMTP 服务器
Label | Name Caption | Label2 发送邮件地址
Label | Name Caption | Label3 接收邮件的地址
Label | Name Caption | Label4 邮件主题
ListBox | Name | lstAttachments
TextBox | Name | txtHost
TextBox | Name | txtMessage
TextBox | Name | txtRecipient
TextBox | Name | txtSender
TextBox | Name | txtSubject
Winsock | Name | Winsock1

（9）为 frmSendMail 窗体添加如下代码。

Private Enum SMTP_State

MAIL_CONNECT

MAIL_HELO

MAIL_FROM

MAIL_RCPTTO

MAIL_DATA

MAIL_DOT

MAIL_QUIT

End Enum

Private m_State As SMTP_State

Private m_strEncodedFiles As String

Public Function UUEncodeFile(strFilePath As String) As String

Dim intFile As Integer

Dim intTempFile As Integer

Dim lFileSize As Long

Dim strFileName As String

Dim strFileData As String

Dim lEncodedLines As Long

Dim strTempLine As String

Dim i As Long

Dim j As Integer

Dim strResult As String

strFileName = Mid$(strFilePath, InStrRev(strFilePath, "\") + 1)

strResult = "begin 664 " + strFileName + vbLf

lFileSize = FileLen(strFilePath)

lEncodedLines = lFileSize \ 45 + 1

strFileData = Space(45)

intFile = FreeFile

Open strFilePath For Binary As intFile

For i = 1 To lEncodedLines

If i = lEncodedLines Then strFileData = Space(lFileSize Mod 45)

Get intFile, , strFileData

strTempLine = Chr(Len(strFileData) + 32)

If i = lEncodedLines And (Len(strFileData) Mod 3) Then strFileData = strFileData + Space(3 - (Len(strFileData) Mod 3))

For j = 1 To Len(strFileData) Step 3

strTempLine = strTempLine + Chr(Asc(Mid(strFileData, j, 1)) \ 4 + 32)

strTempLine = strTempLine + Chr((Asc(Mid(strFileData, j, 1)) Mod 4) * 16 _

+ Asc(Mid(strFileData, j + 1, 1)) \ 16 + 32)

strTempLine = strTempLine + Chr((Asc(Mid(strFileData, j + 1, 1)) Mod 16) * 4 _

+ Asc(Mid(strFileData, j + 2, 1)) \ 64 + 32)

strTempLine = strTempLine + Chr(Asc(Mid(strFileData, j + 2, 1)) Mod 64 + 32)

Next j

strTempLine = Replace(strTempLine, " ", "`")

strResult = strResult + strTempLine + vbLf

strTempLine = ""

Next i

Close intFile

strResult = strResult & "`" & vbLf + "end" + vbLf

UUEncodeFile = strResult

End Function

Private Sub cmdAddFile_Click()

ComDialog.ShowOpen

If Len(ComDialog.FileName) > 0 Then lstAttachments.AddItem ComDialog.FileName

End Sub

Private Sub cmdNew_Click()

txtRecipient = ""

txtSubject = ""

txtMessage = ""

End Sub

Private Sub cmdRemove_Click()

On Error Resume Next

lstAttachments.RemoveItem lstAttachments.ListIndex

End Sub

Private Sub cmdSend_Click()

Dim i As Integer

For i = 0 To lstAttachments.ListCount - 1

lstAttachments.ListIndex = i

m_strEncodedFiles = m_strEncodedFiles & UUEncodeFile(lstAttachments.Text) & vbCrLf

Next i

Winsock1.Connect Trim$(txtHost), 25

m_State = MAIL_CONNECT

End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

Dim strServerResponse As String

Dim strResponseCode As String

Dim strDataToSend As String

Winsock1.GetData strServerResponse

strResponseCode = Left(strServerResponse, 3)

If strResponseCode = "250" Or _

strResponseCode = "220" Or _

strResponseCode = "354" Then

Select Case m_State

Case MAIL_CONNECT

m_State = MAIL_HELO

strDataToSend = Trim$(txtSender)

strDataToSend = Left$(strDataToSend, InStr(1, strDataToSend, "@") - 1)

Winsock1.SendData "HELO " & strDataToSend & vbCrLf

Case MAIL_HELO

m_State = MAIL_FROM

Winsock1.SendData "MAIL FROM:" & Trim$(txtSender) & vbCrLf

Case MAIL_FROM

m_State = MAIL_RCPTTO

Winsock1.SendData "RCPT TO:" & Trim$(txtRecipient) & vbCrLf

Case MAIL_RCPTTO

m_State = MAIL_DATA

Winsock1.SendData "DATA" & vbCrLf

Case MAIL_DATA

m_State = MAIL_DOT

Winsock1.SendData "Subject:" & txtSubject & vbLf & vbCrLf

Dim varLines As Variant

Dim varLine As Variant

Dim strMessage As String

strMessage = txtMessage & vbCrLf & vbCrLf & m_strEncodedFiles

m_strEncodedFiles = ""

varLines = Split(strMessage, vbCrLf)

strMessage = ""

For Each varLine In varLines

Winsock1.SendData CStr(varLine) & vbLf

Debug.Print CStr(varLine)

Next

Winsock1.SendData "." & vbCrLf

Case MAIL_DOT

m_State = MAIL_QUIT

Winsock1.SendData "QUIT" & vbCrLf

Case MAIL_QUIT

End Select

Else

Winsock1.Close

End If

End Sub

Private Sub cmdClose_Click()

End

End Sub

## 应用三：隐藏/显示窗体标题栏

一些图形化的窗体，有时需要隐藏窗体标题栏。本实例将实现隐藏/显示窗体标题栏的功能，如图 1 所示。

图 1 没有标题栏的窗体

完整程序代码如下：

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Const GWL_STYLE = (-16)

Private Const WS_CAPTION = &HC00000

Private Const WS_MAXIMIZEBOX = &H10000

Private Const WS_MINIMIZEBOX = &H20000

Private Const WS_SYSMENU = &H80000

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Enum ESetWindowPosStyles

SWP_SHOWWINDOW = &H40

SWP_HIDEWINDOW = &H80

SWP_FRAMECHANGED = &H20

SWP_NOACTIVATE = &H10

SWP_NOCOPYBITS = &H100

SWP_NOMOVE = &H2

SWP_NOOWNERZORDER = &H200

SWP_NOREDRAW = &H8

SWP_NOREPOSITION = SWP_NOOWNERZORDER

SWP_NOSIZE = &H1

SWP_NOZORDER = &H4

SWP_DRAWFRAME = SWP_FRAMECHANGED

HWND_NOTOPMOST = -2

End Enum

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Private Sub Form_Load()

Dim lStyle As Long

Dim tr As RECT

GetWindowRect Me.hwnd, tr

lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)

lStyle = lStyle And Not WS_SYSMENU

lStyle = lStyle And Not WS_MAXIMIZEBOX

lStyle = lStyle And Not WS_MINIMIZEBOX

lStyle = lStyle And Not WS_CAPTION

SetWindowLong Me.hwnd, GWL_STYLE, lStyle

SetWindowPos Me.hwnd, 0, tr.Left, tr.Top, tr.Right - tr.Left, tr.Bottom - tr.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED

Me.Refresh

End Sub

Private Sub Form_Click()

End

End Sub

## 应用四：获得 Win98 的注册码

### 实例说明

在安装 Win98 时会提示用户输入注册码。那么在安装 win98 后，怎样用程序来获得 Win98 的注册码呢？运行程序，单击“确定”按钮，即可获得 Win98 的注册码。效果如图 1 所示。

图 1 效果图

### 思路与技术

在注册表“HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion"下获取"ProductKey"的值，然后用 RegQueryValueEx 函数来读取 Key 的特定名称的值。下面是 API 函数声明及参数：

函数声明 ：

Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long

参数：

l hkey 参数，打开键的句柄。

l LpValueName 参数，键值。

l LpReserved 参数，保留参数，调用时设置为 0 即可。

l LpType 参数，返回读取的数据类型。LpData 参数，返回读取的数据。

l LpcbData 参数，传入 lpData 数据的长度，若成功读取数据，则返回所读取的数据的长度。

返回值：

函数返回值为 0,表示成功；否则表示失败。

说明：

① 这一函数除了可读取指定名称的值之外，也可以读取默认键值。如果要读取default value,只需要将参数lpValueName设置为空字符串即可。

②lpType 的可能取值

Enum ValueType

REG_NONE = 0

REG_SZ = 1 ：字符串

REG_EXPAND_SZ = 2 ：可展开式字符串

REG_BINARY = 3 ：Binary 数据

REG_DWORD = 4 ：长整数

REG_DWORD_BIG_ENDIAN = 5 ：BIG_ENDIAN 长整数

REG_MULTI_SZ = 7 ：多重字符串

End Enum

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认名为 Form1。

（2）在 Form1 窗体中放置一个 Label 控件、一个 Text 控件、两个 Command 控件。

（3）程序代码：

Option Explicit

Const HKEY_LOCAL_MACHINE = &H80000002

Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _

(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA"_

(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _

lpType As Long, lpData As Any, lpcbData As Long) As Long

Private Sub Command1_Click() ‘获取 win98 注册码

Dim hKey As Long, ret As Long, lenData As Long, typeData As Long

Dim Name As String

Dim s As String

Name = "ProductKey"

ret=RegOpenKey(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\_

CurrentVersion", hKey) ‘打开注册表指定项

If ret = 0 Then

ret = RegQueryValueEx(hKey, Name, 0, typeData, ByVal vbNullString, lenData)

End If

ret = RegQueryValueEx(hKey, Name, 0, typeData, ByVal vbNullString, lenData) ‘打开注册表指定项

s = String(lenData, Chr(0))

RegQueryValueEx hKey, Name, 0, typeData, ByVal s, lenData

s = Left(s, Len(s) - 1)

Text1.Text = s ‘显示注册码

End Sub

Private Sub Command2_Click()

End

End Sub

## 应用五：获得网上共享资源

### 实例说明

在有局域网的单位中，如果能将一些资源共享，不但能提高资源的有效利用，还能提高工作效率，节省资源。但资源共享后，如果不能有效管理和利用，也不能高效、合理地使用网上资源。本例可以列举局域网上的共享资源，以便局域网方便查看网上资源。运行效果如图 1 所示。

图 1 获得网上共享资源

### 思路与技术

本例中结合使用 WNetOpenEnum 函数和 WNetEnumResource 函数来枚举局域网上的资源。当检索到某个服务器上有共享的文件夹信息，则利用 FSO 对象对其进行操作。

FSO（FileSystemObject）对象模型提供了一个基于对象的工具来处理文件夹和文件。这使得处理文件夹和文件除了使用 VB 提供的函数或使用 Windows API 函数以外，有多了一种方法。

FSO 对象模型包含在 Scripting 类型库（Scrrun.dll）中。该对象并不是 VB 的内置对象，需通过选择“工程”→“引用”菜单项，打开“引用”对话框。在“引用”对话框中选择 Microsoft Scripting Runtime 复选框，将其引用。

FSO 对象模型的对象及其描述如下：

（1）Drive 对象。允许收集关于系统所用的驱动器的信息。如，驱动器有多少可用空间、其共享名是多少。

（2）Folder 对象。允许创建、删除或移动文件夹，并向系统查询文件夹的名称和路径等。

（3）Files 对象。允许创建、删除或移动文件夹，并向系统查询文件的名称和路径等。

（4）FileSystemObject 对象。FSO 对象模型的主要对象，提供一整套用于创建、删除、收集相关信息以及通常的操作驱动器、文件夹和文件的方法。与本对象相关联的很多方法都和其他对象中的方法相同。

（5）TextStream 对象。允许读和写文件。

注意：

本例中在获取的服务器中的共享资源时，应具有被获取的服务器具有访问权限，否则不能获取其目录下的共享资源。

### 开发步骤

（1）新建一个标准工程，创建一个新窗体，默认名为 Form1。

（2）在窗体上添加一个 TreeView 控件和一个 ImageList 控件。由于这两个控件属于 ActiveX 控件，因此在使用之前必须将其添加到工具箱。添加方法如下：

选择 VB 菜单的“工程”→“部件”，然后选取 Microsoft Windows Common Controls 6.0（SP6），单击“确定”按钮之后即可将 TreeView 控件和 ImageList 控件添加到工具箱当中。将两个控件相连。设置 Image 控件的 Picture 属性。

（3）在工程中新建两个类模块，分别命名为 NetResource 和 NetResources。

表 1 Form1 窗体中控件部分属性设置

控件名 | 属性 | 值
ImageList | Name | ImageList1
TreeView | Name | TreeView1

（4）为 Form1 窗体添加如下代码。

Option Explicit

Private NetRoot As NetResource

Private Sub NodeExpand(Node As MSComctlLib.Node)

'文件夹和网络路径要区别处理

Dim FSO As Scripting.FileSystemObject

Dim NWFolder As Scripting.Folder

Dim FilX As Scripting.File, DirX As Scripting.Folder

Dim tNod As Node, isFSFolder As Boolean

'移除 fake 节点，显示“＋”图标

TreeView1.Nodes.Remove Node.Key + "_FAKE"

'判断该节点是一个共享文件夹还是一个网路路径，如果为共享文件夹，则利用 FSO 对象获得相关的文件和文件夹信息

If Node.SelectedImage = "share" Then

On Error Resume Next

Set FSO = New FileSystemObject

Set NWFolder = FSO.GetFolder(Node.Key)

If Err <> 0 Then isFSFolder = False Else isFSFolder = True

On Error GoTo 0

End If

If Node.SelectedImage = "folder" Or (Node.SelectedImage = "share" And isFSFolder = True) Then

'这个节点是经由网络 UNC 路径的一个文件系统文件夹

'利用 FileSystemObject 对象获得网络文件和目录

Set FSO = New Scripting.FileSystemObject

Set NWFolder = FSO.GetFolder(Node.Key) ' 节点的 Key 中保存的是 UNC 路径目录

'列举该文件夹中的文件

For Each FilX In NWFolder.Files

TreeView1.Nodes.Add Node.Key, tvwChild, Node.Key + "\" + FilX.Name, FilX.Name, "file", "file"

Next

' Enumerate the folders

'列举文件夹

For Each DirX In NWFolder.SubFolders

Set tNod = TreeView1.Nodes.Add(Node.Key, tvwChild, Node.Key + "\" + DirX.Name, DirX.Name, "folder", "folder")

TreeView1.Nodes.Add tNod.Key, tvwChild, tNod.Key + "_FAKE", "FAKE", "folder", "folder"

tNod.Tag = "N"

Next

Node.Tag = "Y"

Else

'遍历整个属性结构，以便于在 NetRoot 下面加载 NetResource 对象

Dim pS As String, kPath() As String, nX As NetResource, i As Integer, tX As NetResource

Set tNod = Node ' 展开节点

Do While Not tNod.Parent Is Nothing ' 利用父节点的关系继续执行，每次保存节点的 Key 到字符变量 pS

pS = tNod.Key + "|" + pS

Set tNod = tNod.Parent

Loop

'字符变量 pS 现在的形式是"<Node Key>|<Node Key>|<Node Key>"

'利用 Split 函数将信息保存到数组中

kPath = Split(pS, "|")

Set nX = NetRoot

'循环遍历这个数组，当用户单击 NetResource 对象，找出 NetRoot 的相应的子节点

'遍历树型结构显示从 NetRoot 到用户单击的 NetResource 对象的相应的子节点

For i = 0 To UBound(kPath) - 1

Set nX = nX.Children(kPath(i))

Next

'现在我们知道节点和相应的 NetResource 都可以枚举出子节点和添加节点

For Each tX In nX.Children

Set tNod = TreeView1.Nodes.Add(nX.RemoteName, tvwChild, tX.RemoteName, tX.ShortName, LCase(tX.ResourceTypeName), LCase(tX.ResourceTypeName))

tNod.Tag = "N"

'给除了打印机以外所有的节点添加 fake 节点，（你可以确定一个打印机永远都没有子节点）

If tX.ResourceType <> Printer Then TreeView1.Nodes.Add tX.RemoteName, tvwChild, tX.RemoteName + "_FAKE", "FAKE", "server", "server"

Next

TreeView1.Refresh '刷新数据

Node.Tag = "Y" ' 设置 Tag 标志为“Y”，用于指示该节点时展开还是合上。

End If

End Sub

Private Sub Form_Load()

Dim nX As NetResource, nodX As Node

TreeView1.ImageList = ImageList1

Set NetRoot = New NetResource '创建一个 NewResource 对象，默认为网络的根

Set nodX = TreeView1.Nodes.Add(, , "_ROOT", "整个网络", "root", "root") '在 TreeView 中添加一个节点

nodX.Tag = "Y" '设置展开标志为“Y”

'展开“整个网络”下面的第一层对象

For Each nX In NetRoot.Children

Set nodX = TreeView1.Nodes.Add("_ROOT", tvwChild, nX.RemoteName, nX.ShortName, LCase(nX.ResourceTypeName), LCase(nX.ResourceTypeName))

nodX.Tag = "N" ' 下面的节点不展开，将其展开标志设置为“N”

TreeView1.Nodes.Add nodX.Key, tvwChild, nodX.Key + "_FAKE", "FAKE", "server", "server" '创建一个 Fake 节点，这样 TreeView 将显示“＋”标志

nodX.EnsureVisible

Next

'在本层中不能列举出打印机，所以这里不列举

End Sub

Private Sub Form_Resize()

TreeView1.Width = Me.ScaleWidth

TreeView1.Height = Me.ScaleHeight

End Sub

Private Sub TreeView1_Expand(ByVal Node As MSComctlLib.Node)

If Node.Tag = "N" Then NodeExpand Node

End Sub

（5）为 NetResource 类模块添加如下代码。

Public Enum NetResourceTypes '枚举 NerResource 可能的类型

Generic = 0

Domain = 1

Server = 2

share = 3

File = 4

Group = 5

Network = 6

Root = 7

ShareAdmin = 8

Directory = 9

Tree = 10

NDSContainer = 11

Printer = &HFF

End Enum

Private mvNetRes As NETRES2

Private mvGotChildren As Boolean

Private mvChildren As NetResources ' Collection of child containers and disk objects (what you usually get in the Network Neighborhood tree)

Private mvAmRoot As Boolean

Private mvAmPrinter As Boolean

Private Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function GlobalFree Lib "KERNEL32" (ByVal hMem As Long) As Long

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private Declare Function lstrcpyA Lib "KERNEL32" Alias "lstrcpy" (ByVal NewString As String, ByVal OldString 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, ByVal lpBuffer As Long, ByRef lpBufferSize As Long) As Long

Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long

Private Type sNETRESOURCE ' 和 API 兼容的 NETRESOURCE 结构

dwScope As Long ' 所有的成员都是 Long 型的

dwType As Long

dwDisplayType As Long

dwUsage As Long

lpLocalName As Long

lpRemoteName As Long

lpComment As Long

lpProvider As Long

End Type

Private Type NETRES2 ' 和 VB 兼容的 NETRESOURCE 结构

dwScope As Long ' 成员都映射为 VB 中的数据类型

dwType As Long

dwDisplayType As Long

dwUsage As Long

lpLocalName As String

lpRemoteName As String

lpComment As String

lpProvider As String

End Type

Private Const RESOURCE_CONNECTED = &H1

Private Const RESOURCE_GLOBALNET = &H2

Private Const RESOURCE_REMEMBERED = &H3

Private Const RESOURCE_CONTEXT = &H5

Private Const RESOURCETYPE_ANY = &H0

Private Const RESOURCETYPE_DISK = &H1

Private Const RESOURCETYPE_PRINT = &H2

Private Const RESOURCETYPE_UNKNOWN = &HFFFF

Private Const RESOURCEUSAGE_CONNECTABLE = &H1

Private Const RESOURCEUSAGE_CONTAINER = &H2

Private Const RESOURCEUSAGE_RESERVED = &H80000000

Private Const GMEM_DDESHARE = &H2000

Private Const GMEM_DISCARDABLE = &H100

Private Const GMEM_DISCARDED = &H4000

Private Const GMEM_FIXED = &H0

Private Const GMEM_INVALID_HANDLE = &H8000

Private Const GMEM_LOCKCOUNT = &HFF

Private Const GMEM_MODIFY = &H80

Private Const GMEM_MOVEABLE = &H2

Private Const GMEM_NOCOMPACT = &H10

Private Const GMEM_NODISCARD = &H20

Private Const GMEM_NOT_BANKED = &H1000

Private Const GMEM_NOTIFY = &H4000

Private Const GMEM_SHARE = &H2000

Private Const GMEM_VALID_FLAGS = &H7F72

Private Const GMEM_ZEROINIT = &H40

Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Const ERROR_MORE_DATA = 234

Private Const RESOURCEDISPLAYTYPE_GENERIC = 0

Private Const RESOURCEDISPLAYTYPE_DOMAIN = 1

Private Const RESOURCEDISPLAYTYPE_SERVER = 2

Private Const RESOURCEDISPLAYTYPE_SHARE = 3

Private Const RESOURCEDISPLAYTYPE_FILE = 4

Private Const RESOURCEDISPLAYTYPE_GROUP = 5

Private Const RESOURCEDISPLAYTYPE_NETWORK = 6

Private Const RESOURCEDISPLAYTYPE_ROOT = 7

Private Const RESOURCEDISPLAYTYPE_SHAREADMIN = 8

Private Const RESOURCEDISPLAYTYPE_DIRECTORY = 9

Private Const RESOURCEDISPLAYTYPE_TREE = &HA

Private Const RESOURCEDISPLAYTYPE_NDSCONTAINER = &HB

Private Sub GetPrinters() '获取打印机

Dim hEnum As Long, lpBuff As Long

Dim cbBuff As Long, cCount As Long

Dim p As Long, res As Long, i As Long

Dim EnumHTemp As Long

Dim reqBufferSize As Long

Dim nR As sNETRESOURCE ' 定义一个具有 API NETRESOURCE 结构的变量

Dim tempRes As NETRES2 ' 定义一个具有 VB NETRESOURCE 结构的变量

Dim tChild As NetResource

'如果这个对象是 Network root，我们作一些微小的改动以适应 API NETRESOURCE 的结构

If mvAmRoot Then

nR.dwUsage = RESOURCEUSAGE_CONNECTABLE

nR.lpRemoteName = 0

End If

'开始枚举网络资源

res = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_PRINT, RESOURCEUSAGE_CONNECTABLE, mvNetRes, hEnum)

If res <> 0 Then Exit Sub

'现在开始枚举集合

EnumHTemp = hEnum

'分配一个 1K 的缓冲区用于存储 NETRESOURCE 结构的返回值

cbBuff = 1024&

lpBuff = GlobalAlloc(GPTR, cbBuff)

Do

EnumHTemp = hEnum

cCount = &HFFFFFFFF '返回的网络资源的数量，&HFFFFFFFF

res = WNetEnumResource(hEnum, cCount, lpBuff, cbBuff)

If res = ERROR_MORE_DATA Then

GlobalFree lpBuff ' 释放缓冲区

lpBuff = GlobalAlloc(GPTR, cbBuff) '分配一个新的空间 ，大小为枚举中所要求的大小

Else

If res = 0 Then ' 成功执行

p = lpBuff

' 保存网络资源的数量

For i = 1 To cCount

CopyMemory nR, ByVal p, LenB(nR)

p = p + LenB(nR)

If nR.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE Then

tempRes.dwDisplayType = nR.dwDisplayType

tempRes.dwScope = nR.dwScope

tempRes.dwType = nR.dwType

tempRes.dwUsage = nR.dwUsage

tempRes.lpComment = lStrCpy(nR.lpComment)

tempRes.lpLocalName = lStrCpy(nR.lpLocalName)

tempRes.lpProvider = lStrCpy(nR.lpProvider)

tempRes.lpRemoteName = lStrCpy(nR.lpRemoteName)

Set tChild = New NetResource

tChild.NRStruct = tempRes

tChild.IsPrinter = True '

mvChildren.Add tChild

End If

Next

End If

End If

Loop Until cCount = 0

WNetCloseEnum hEnum ' 关闭 enum

GlobalFree lpBuff ' 释放缓冲区

End Sub

Friend Property Let IsPrinter(pVal As Boolean)

mvAmPrinter = pVal

End Property

Private Function lStrCpy(lStrPointer As Long) As String

Dim TString As String

TString = String(255, Chr$(0))

lstrcpyA TString, lStrPointer

lStrCpy = Left(TString, InStr(TString, Chr$(0)) - 1)

End Function

Public Property Get Children() As NetResources

If Not mvGotChildren Then GetChildren

Set Children = mvChildren

End Property

Public Property Get Comment() As String

Comment = mvNetRes.lpComment

End Property

Private Sub GetChildren() '获得子节点

' API wrangling...

' Initialise my collection and variables

Set mvChildren = New NetResources

Dim hEnum As Long, lpBuff As Long

Dim cbBuff As Long, cCount As Long

Dim p As Long, res As Long, i As Long

Dim EnumHTemp As Long

Dim reqBufferSize As Long

Dim nR As sNETRESOURCE ' API friendly structure

Dim tempRes As NETRES2 ' VB friendly structure

Dim tChild As NetResource

' If this object is the Network root then we need to make a slight adjustment to the starting values

' of our API friendly NETRESOURCE structure

If mvAmRoot Then

nR.dwUsage = RESOURCEUSAGE_CONNECTABLE

nR.lpRemoteName = 0

End If

' Open a net enumeration

res = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, mvNetRes, hEnum)

' Check for errors

If res <> 0 Then

' Error returned when trying to open the enumeration

' Probably means we don't have access to see its children.

' See the MSDN for more details on possible errors.

' Currently no trapping is done here and the routine just exits with an empty children collection

Exit Sub

End If

' Now begin to enumerate the collection

EnumHTemp = hEnum

' Allocate a default buffer for the NETRESOURCE structure returned from the enum routine, say 1K

cbBuff = 1024&

lpBuff = GlobalAlloc(GPTR, cbBuff)

Do

EnumHTemp = hEnum

cCount = &HFFFFFFFF ' Number of entries to return from enumeration - &HFFFFFFFF causes all objects to be returned

res = WNetEnumResource(hEnum, cCount, lpBuff, cbBuff)

If res = ERROR_MORE_DATA Then

' The enumeration has reported that the lpBuff is not big enough to hold all of the information in the

' NETRESOURCE structure. cbBuff has been updated to hold the required amount of space.

GlobalFree lpBuff ' Free the memory we're using for the current small buffer

lpBuff = GlobalAlloc(GPTR, cbBuff) ' Allocate a new space of the size requested by the enumeration

Else

If res = 0 Then ' No error

p = lpBuff

' cCount holds the number of NETRESOURCE structures returned in this pass

' (The enumeration returns as many as will fit into the buffer)

For i = 1 To cCount ' Loop through the buffer, tackling each structure in turn

CopyMemory nR, ByVal p, LenB(nR) ' Copy the block of memory representing the structure into a local API friendly NETRESOURCE structure

p = p + LenB(nR) ' Step forward in the buffer by the length of the copied structure

tempRes.dwDisplayType = nR.dwDisplayType ' Begin copying the members of the API friendly structure to the VB friendly structure

tempRes.dwScope = nR.dwScope

tempRes.dwType = nR.dwType

tempRes.dwUsage = nR.dwUsage

tempRes.lpComment = lStrCpy(nR.lpComment) ' String copies accomplished by using the lStrCpy routine

tempRes.lpLocalName = lStrCpy(nR.lpLocalName)

tempRes.lpProvider = lStrCpy(nR.lpProvider)

tempRes.lpRemoteName = lStrCpy(nR.lpRemoteName)

Set tChild = New NetResource ' Create the new NetResource object that will be the new child

tChild.NRStruct = tempRes ' Pass the current VB friendly NETRESOURCE structure to tbe force populate method of the NetResource object

mvChildren.Add tChild ' Add the new object to my children collection

Next

End If

End If

Loop Until cCount = 0

' Close the enum

WNetCloseEnum hEnum

' Free the memory

GlobalFree lpBuff

' In order to distinguish printers from other shares we need to enumerate them separately

GetPrinters '为了区别其他共享资源，需要单独列举打印机

mvGotChildren = True

End Sub

Public Property Get LocalName() As String

LocalName = mvNetRes.lpLocalName

End Property

Friend Property Let NRStruct(RHS As NETRES2)

' Private force populate routine

' When a NetResource object it defaults to being the network root object

' The only way to change this is to call this routine and pass a VB friendly NETRES2 NETRESOURCE structure

' When this function is called correctly it populates the data for this NetResource and forces it to act as a child rather than

' a network root.

' When compiled as a COM DLL this function will not be visible to the user - it's intended for internal use only

mvNetRes = RHS

mvAmRoot = False

End Property

Public Property Get Provider() As String

Provider = mvNetRes.lpProvider

End Property

Public Property Get RemoteName() As String

RemoteName = mvNetRes.lpRemoteName

End Property

Public Property Get ResourceType() As NetResourceTypes

If Not mvAmPrinter Then ResourceType = mvNetRes.dwDisplayType Else ResourceType = Printer

End Property

Public Property Get ResourceTypeName() As String

' Provides a friendly name for the resource type as an alternative to using the enumerated "ResourceType" property

' This can be used to quicky bind NetResource objects to named images in an imagelist control (for example)

If mvAmPrinter Then

ResourceTypeName = "Printer"

Exit Property

End If

Select Case mvNetRes.dwDisplayType

Case RESOURCEDISPLAYTYPE_GENERIC

ResourceTypeName = "Generic"

Case RESOURCEDISPLAYTYPE_DOMAIN

ResourceTypeName = "Domain"

Case RESOURCEDISPLAYTYPE_SERVER

ResourceTypeName = "Server"

Case RESOURCEDISPLAYTYPE_SHARE

ResourceTypeName = "Share"

Case RESOURCEDISPLAYTYPE_FILE

ResourceTypeName = "File"

Case RESOURCEDISPLAYTYPE_GROUP

ResourceTypeName = "Group"

Case RESOURCEDISPLAYTYPE_NETWORK

ResourceTypeName = "Network"

Case RESOURCEDISPLAYTYPE_ROOT

ResourceTypeName = "Root"

Case RESOURCEDISPLAYTYPE_SHAREADMIN

ResourceTypeName = "AdminShare"

Case RESOURCEDISPLAYTYPE_DIRECTORY

ResourceTypeName = "Directory"

Case RESOURCEDISPLAYTYPE_TREE

ResourceTypeName = "Tree"

Case RESOURCEDISPLAYTYPE_NDSCONTAINER

ResourceTypeName = "NDSContainer"

End Select

End Property

Public Property Get ShortName() As String

' Return just the final part of the object's name (rather than a fully qualified path or context)

Dim i As Integer

i = InStrRev(mvNetRes.lpRemoteName, "\")

ShortName = Right(mvNetRes.lpRemoteName, Len(mvNetRes.lpRemoteName) - i)

End Property

Private Sub Class_Initialize()

mvAmRoot = True

End Sub

Private Sub Class_Terminate()

Set mvChildren = Nothing

End Sub

（6）为 NetResources 类模块添加如下代码。

Option Explicit

'local variable to hold collection

Private mCol As Collection

Friend Function Add(objNewMember As NetResource) As NetResource

' Note : this function only allows adding of already extant objects. NetResource objects cannot be created

' by adding them to a NetResources collection since most of the network structure is hardware based and

' cannot be changed by software.

'create a new object

mCol.Add objNewMember, objNewMember.RemoteName

'return the object created

Set Add = objNewMember

End Function

Public Property Get Item(vntIndexKey As Variant) As NetResource

' This item routine is a slight modification from the norm

' If an invalid or unmatched key is passed then this property returns a Nothing object rather than an error

Dim nrX As NetResource

On Error Resume Next

Set nrX = mCol(vntIndexKey)

If Err <> 0 Then

Set Item = Nothing

Else

Set Item = nrX

End If

'Set Item = mCol(vntIndexKey)

End Property

Public Property Get Count() As Long

'used when retrieving the number of elements in the

'collection. Syntax: Debug.Print x.Count

Count = mCol.Count

End Property

Public Sub Remove(vntIndexKey As Variant)

'used when removing an element from the collection

'vntIndexKey contains either the Index or Key, which is why

'it is declared as a Variant

'Syntax: x.Remove(xyz)

mCol.Remove vntIndexKey

End Sub

Public Property Get NewEnum() As IUnknown

'this property allows you to enumerate

'this collection with the For...Each syntax

Set NewEnum = mCol.[_NewEnum]

End Property

Private Sub Class_Initialize()

'creates the collection when this class is created

Set mCol = New Collection

End Sub

Private Sub Class_Terminate()

'destroys collection when this class is terminated

Set mCol = Nothing

End Sub