form1.frm

电子书“Visual Basic 6 网络编程实例教程.rar”

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "远程机器上的共享资源"
   ClientHeight    =   4485
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6105
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4485
   ScaleWidth      =   6105
   StartUpPosition =   2  '屏幕中心
   Begin VB.ListBox List1 
      Height          =   2760
      Left            =   240
      TabIndex        =   1
      Top             =   600
      Width           =   5655
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Default         =   -1  'True
      Height          =   495
      Left            =   240
      TabIndex        =   0
      Top             =   3600
      Width           =   1215
   End
   Begin VB.Label Label7 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "路径"
      Height          =   180
      Left            =   4800
      TabIndex        =   8
      Top             =   360
      Width           =   360
   End
   Begin VB.Label Label6 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "备注"
      Height          =   180
      Left            =   3720
      TabIndex        =   7
      Top             =   360
      Width           =   360
   End
   Begin VB.Label Label5 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "访问许可"
      Height          =   180
      Left            =   2760
      TabIndex        =   6
      Top             =   360
      Width           =   720
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "连接类型"
      Height          =   180
      Left            =   1920
      TabIndex        =   5
      Top             =   360
      Width           =   720
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "共享资源"
      Height          =   180
      Left            =   360
      TabIndex        =   4
      Top             =   360
      Width           =   720
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label2"
      Height          =   180
      Left            =   4080
      TabIndex        =   3
      Top             =   3840
      Width           =   540
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label1"
      Height          =   180
      Left            =   1800
      TabIndex        =   2
      Top             =   3840
      Width           =   540
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Command1_Click()
    Dim bufptr          As Long  '输出参数
   Dim dwServer        As Long  '服务器地址
   Dim dwEntriesread   As Long  '输出参数
   Dim dwTotalentries  As Long  '输出参数
   Dim dwResumehandle  As Long  '输出参数
   Dim success         As Long
   Dim nStructSize     As Long
   Dim cnt             As Long
   Dim usrname         As String
   Dim bServer         As String
   Dim shi2            As SHARE_INFO_2
  '使用本地机器
   bServer = "\\" & Environ$("COMPUTERNAME") & vbNullString
  '创建指向本地机的指针
   dwServer = StrPtr(bServer)
   success = NetShareEnum(dwServer, _
                          2, _
                          bufptr, _
                          MAX_PREFERRED_LENGTH, _
                          dwEntriesread, _
                          dwTotalentries, _
                          dwResumehandle)
   List1.Clear
   Label2.Caption = success
   If success = NERR_SUCCESS And _
      success <> ERROR_MORE_DATA Then
      nStructSize = LenB(shi2)
      For cnt = 0 To dwEntriesread - 1
        '获取数据，并将其转换为SHARE_INFO_2类型，然后将数据添加到列表中
         CopyMemory shi2, ByVal bufptr + (nStructSize * cnt), nStructSize
         List1.AddItem GetPointerToByteStringW(shi2.shi2_netname) & vbTab & _
                       GetConnectionType(shi2.shi2_type) & vbTab & _
                       GetConnectionPermissions(shi2.shi2_permissions) & vbTab & _
                       GetPointerToByteStringW(shi2.shi2_remark) & vbTab & _
                       GetPointerToByteStringW(shi2.shi2_path)
    Next
   End If
   Call NetApiBufferFree(bufptr)
End Sub

Private Sub Form_Load()
    ReDim TabArray(0 To 4) As Long
   TabArray(0) = 73
   TabArray(1) = 125
   TabArray(2) = 151
   TabArray(3) = 202
  '设置列表框的制表位置
   Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
   Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 4&, TabArray(0))
   List1.Refresh
   Command1.Caption = "运行(&R)"
   Label1.Caption = "成功调用(0)或错误"
   Label2.Caption = ""
End Sub

Private Function GetConnectionPermissions(ByVal dwPermissions As Long) As String
  '访问许可只能返回运行共享级安全的服务器的共享资源，
  '运行用户级安全的服务器则忽略这个成员
   Dim tmp As String
   If (dwPermissions And ACCESS_READ) Then tmp = tmp & "R"
   If (dwPermissions And ACCESS_WRITE) Then tmp = tmp & " W"
   If (dwPermissions And ACCESS_CREATE) Then tmp = tmp & " C"
   If (dwPermissions And ACCESS_DELETE) Then tmp = tmp & " D"
   If (dwPermissions And ACCESS_EXEC) Then tmp = tmp & " E"
   If (dwPermissions And ACCESS_ATRIB) Then tmp = tmp & " A"
   If (dwPermissions And ACCESS_PERM) Then tmp = tmp & " P"
   If Len(tmp) = 0 Then tmp = "n/a"
   GetConnectionPermissions = tmp
End Function

Private Function GetConnectionType(ByVal dwConnectType As Long) As String
  '连接类型
   Select Case dwConnectType
      Case STYPE_DISKTREE: GetConnectionType = "磁盘驱动器"
      Case STYPE_PRINTQ:   GetConnectionType = "打印机"
      Case STYPE_DEVICE:   GetConnectionType = "通信设备"
      Case STYPE_IPC:      GetConnectionType = "进程内通信"
      Case STYPE_SPECIAL:  GetConnectionType = "管理程序"
      Case Else:
         Select Case (dwConnectType Xor STYPE_SPECIAL)
            Case STYPE_IPC: GetConnectionType = "进程内通信"
            Case Else:      GetConnectionType = "未定义"
         End Select
   End Select
End Function

Public Function GetPointerToByteStringW(ByVal dwData As Long) As String
   Dim tmp() As Byte
   Dim tmplen As Long
   If dwData <> 0 Then
      tmplen = lstrlenW(dwData) * 2
      If tmplen <> 0 Then
         ReDim tmp(0 To (tmplen - 1)) As Byte
         CopyMemory tmp(0), ByVal dwData, tmplen
         GetPointerToByteStringW = tmp
     End If
   End If
End Function