bu kodu bir siteden buldum
nasıl kullanacağım yardım edebilirmisiniz
Kod:
'Kaynak: http://www.freevbcode.com/ShowCode.Asp?ID=5983
Public Const NERR_Success = 0&
Public Const NERR_MoreData = 234&
Public Const SRV_TYPE_ALL = &HFFFF
Private Type SERVER_INFO_API
PlatformId As Long
ServerName As Long
Type As Long
VerMajor As Long
VerMinor As Long
Comment As Long
End Type
Type ServerInfo
PlatformId As Long
ServerName As String
Type As Long
VerMajor As Long
VerMinor As Long
Comment As String
Platform As String
ServerType As Integer
LanGroup As String
LanRoot As String
End Type
Type ListOfServer
Init As Boolean
LastErr As Long
List() As ServerInfo
End Type
Public Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
(pTo As Any, _
uFrom As Any, _
ByVal lSize As Long)
Declare Function lstrlenW Lib "kernel32" _
(ByVal lpString As Long) As Long
Declare Function NetApiBufferFree Lib "netapi32" _
(ByVal lBuffer&) As Long
Declare Function NetGetDCName Lib "netapi32" _
(lpServer As Any, lpDomain As Any, _
vBuffer As Any) As Long
Declare Function NetServerEnum Lib "netapi32" _
(lpServer As Any, ByVal lLevel As Long, vBuffer As Any, _
lPreferedMaxLen As Long, lEntriesRead As Long, lTotalEntries As Long, _
ByVal lServerType As Long, ByVal sDomain$, vResume As Any) As Long
Public Const MyServer As String = "raider"
Sub CheckComputer()
Dim intIDX As Integer
Dim ServerList As ListOfServer
Dim MyMsg As String
ServerList = EnumServer(SRV_TYPE_ALL)
If ServerList.Init Then
For i = LBound(ServerList.List) To UBound(ServerList.List)
If LCase(ServerList.List(i).ServerName) = LCase(MyServer) Then
MyMsg = "Bilgisayar açık, işleme devam edebilirsiniz...."
Exit For
Else
MyMsg = "Bilgisayar şu anda kapalı veya yanlış bilgisayar adı, daha sonra deneyin...."
End If
Next
MsgBox MyMsg
End If
End Sub
'
Public Function EnumServer(lServerType As Long) As ListOfServer
Dim nRet As Long, x As Integer, i As Integer
Dim lRetCode As Long
Dim tServerInfo As SERVER_INFO_API
Dim lServerInfo As Long
Dim lServerInfoPtr As Long
Dim ServerInfo As ServerInfo
Dim lPreferedMaxLen As Long
Dim lEntriesRead As Long
Dim lTotalEntries As Long
Dim sDomain As String
Dim vResume As Variant
Dim yServer() As Byte
Dim SrvList As ListOfServer
yServer = MakeServerName(ByVal "")
lPreferedMaxLen = 65536
nRet = NERR_MoreData
Do While (nRet = NERR_MoreData)
'Call NetServerEnum to get a list of Servers
nRet = NetServerEnum(yServer(0), 101, lServerInfo, _
lPreferedMaxLen, lEntriesRead, _
lTotalEntries, lServerType, _
sDomain, vResume)
If (nRet <> NERR_Success And _
nRet <> NERR_MoreData) Then
SrvList.Init = False
SrvList.LastErr = nRet
NetError nRet
Exit Do
End If
' NetServerEnum Index is 1 based
x = 1
lServerInfoPtr = lServerInfo
Do While x <= lTotalEntries
CopyMem tServerInfo, ByVal lServerInfoPtr, Len(tServerInfo)
ServerInfo.Comment = PointerToStringW(tServerInfo.Comment)
ServerInfo.ServerName = PointerToStringW(tServerInfo.ServerName)
ServerInfo.Type = tServerInfo.Type
ServerInfo.PlatformId = tServerInfo.PlatformId
ServerInfo.VerMajor = tServerInfo.VerMajor
ServerInfo.VerMinor = tServerInfo.VerMinor
i = i + 1
ReDim Preserve SrvList.List(1 To i) As ServerInfo
SrvList.List(i) = ServerInfo
x = x + 1
lServerInfoPtr = lServerInfoPtr + Len(tServerInfo)
Loop
lRetCode = NetApiBufferFree(lServerInfo)
SrvList.Init = (x > 1)
Loop
EnumServer = SrvList
End Function
Public Function MakeServerName(ByVal ServerName As String)
Dim yServer() As Byte
If ServerName <> "" Then
If InStr(1, ServerName, "\\") = 0 Then
ServerName = "\\" & ServerName
End If
End If
yServer = ServerName & vbNullChar
MakeServerName = yServer
End Function
Public Function NetError(nErr As Long, Optional Ret) As String
Dim Msg As String
If IsMissing(Ret) Then Ret = False
Select Case nErr
Case 5
Msg = "Access Denied!"
Case 1722
Msg = "Server not accessible!"
Case 1326
Msg = " Sie besitzen nicht die Berechtigungen dafür"
Case Else
Msg = "Error Nr. (" & nErr & ") !"
End Select
If Not Ret Then
Beep
MsgBox Msg, vbCritical, "Net Error"
Else
NetError = Msg
End If
End Function
'
Public Function PointerToStringW(lpStringW As Long) As String
Dim buffer() As Byte
Dim nLen As Long
If lpStringW Then
nLen = lstrlenW(lpStringW) * 2
If nLen Then
ReDim buffer(0 To (nLen - 1)) As Byte
CopyMem buffer(0), ByVal lpStringW, nLen
PointerToStringW = buffer
End If
End If
End Function