Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const NERR_SUCCESS As Long = 0&
Private Const MAX_PREFERRED_LENGTH As Long = -1
Private Declare Function NetGetJoinInformation Lib "Netapi32" _
(ByVal lpServer As Long, _
lpNameBuffer As Long, _
BufferType As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32.dll" _
(ByVal Buffer As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pTo As Any, uFrom As Any, _
ByVal lSize As Long)
Private Declare Function lstrlenW Lib "kernel32" _
(ByVal lpString As Long) As Long
Private Sub Form_Load()
Command1.Caption = "NetGetJoinInformation"
End Sub
Private Sub Command1_Click()
Dim bufptr As Long
Dim dwServer As Long
Dim dwBufferType As Long
Dim sServer As String
'This retrieves the join info for the
'local machine. You can also pass the
'name of a remote machine instead.
sServer = QualifyServer(Environ$("COMPUTERNAME") & vbNullString)
dwServer = StrPtr(sServer)
If NetGetJoinInformation(dwServer, _
bufptr, _
dwBufferType) = NERR_SUCCESS Then
Text1.Text = GetPointerToByteStringW(bufptr)
Text2.Text = GetJoinStatus(dwBufferType)
End If
NetApiBufferFree bufptr
End Sub
Private Function GetJoinStatus(dwStatus As Long) As String
Select Case dwStatus
Case 0: GetJoinStatus = "The status is unknown"
Case 1: GetJoinStatus = "The computer is not joined"
Case 2: GetJoinStatus = "The computer is joined to a workgroup"
Case 3: GetJoinStatus = "The computer is joined to a domain"
Case Else: GetJoinStatus = "dwStatus outside valid enum range"
End Select
End Function
Private 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
Private Function QualifyServer(ByVal sServer As String) As String
'see if there are already two slashes
'preceeding the server name
If Left$(sServer, 2) = "\\" Then
'there are, so the server is already
'qualified; return the passed string
QualifyServer = sServer
Else
'there aren't two, but is there one?
If Left$(sServer, 1) = "\" Then
'yes, so add one more
QualifyServer = "\" & sServer
Else
'the string needs both
QualifyServer = "\\" & sServer
End If 'If Left$(sServer, 1) <> "\"
End If 'If Left$(sServer, 2) = "\\"
End Function |