Skip to main content

AccessTr.neT


ağdaki bilgisayar açık mı

ağdaki bilgisayar açık mı

Çözüldü #1
iyi günler
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

@benbendedeilem
Cevapla
Çözüldü #2
sn.kural'ın eklemiş olduğu örnekten
modül içerisine
Kod:
Public Function siteaktifmi(site As String)
    Const OpenAsASCII = 0
     Const FailIfNotExist = 0
     Const ForReading = 1
     Dim objShell, objFSO, sTempFile, fFile
    Set objShell = CreateObject("WScript.Shell")
     Set objFSO = CreateObject("Scripting.FileSystemObject")
    sTempFile = objFSO.GetSpecialFolder(2).ShortPath & "\" & objFSO.GetTempName
    objShell.Run "%comspec% /c ping.exe -n 2 -w 500 " & site & ">" & sTempFile, 0, True
    Set fFile = objFSO.OpenTextFile(sTempFile, ForReading, FailIfNotExist, OpenAsASCII)
    Select Case InStr(fFile.ReadAll, "TTL=")
         Case 0
            siteaktifmi = False
         Case Else
            siteaktifmi = True
    End Select
    fFile.Close
     objFSO.DeleteFile (sTempFile)
    Set objFSO = Nothing
    Set objShell = Nothing
End Function

fomda butona
ağdaki bilgissayar adı ne ise burada "asm"
Kod:
Private Sub Komut0_Click()
If siteaktifmi("asm") = True Then
     Me.Metin4.Value = "Siteye Erişiminiz Vardır."
Else
Me.Metin4.Value = "Siteye Erişiminiz Yoktur."
End If

End Sub
[code]

@benbendedeilem
Cevapla
Çözüldü #3
üst örnekteki kodu yeni modül içine yapıştırın

Public Const MyServer As String = "ServerAdi"
modülde bu satırda Server Adınızı gerekli yere yazın.

Form içinde CheckComputer ile kontrol yapın.
Murat YANDEMİR ( PyramiD YAZILIM Uluslar Arası Nakliye Programları )
Bilgisayar Programcısı (1989'dan beri)

+rep Yollar biter Access bitmez. +rep
Cevapla
Çözüldü #4
Tesekkurler
@benbendedeilem
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task