ağdaki bilgisayar açık mı
Tarih
16/04/2012 10:46
Konu Sahibi
accessman
Yorumlar
3
Okunma
1261
Konuyu Oyla:
  • Derecelendirme: 0/5 - 0 oy
  • 5
  • 4
  • 3
  • 2
  • 1

Derecelendirme: 0/5 - 0 oy



accessman

Kullanici Avatari
Onursal
2.367
31/10/2008
425
Denizli
Ofis 2003
20/09/2016,00:20
Çözüldü 
iyi günler
bu kodu bir siteden buldum
nasıl kullanacağım yardım edebilirmisiniz

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
'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


accessman

Kullanici Avatari
Onursal
2.367
31/10/2008
425
Denizli
Ofis 2003
20/09/2016,00:20
Çözüldü 
sn.kural'ın eklemiş olduğu örnekten
modül içerisine

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
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:
1
2
3
4
5
6
7
8
9
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


Yandemir
Only Office 2003
Kullanici Avatari
Onursal
M.... Y....
1.432
26/08/2009
482
Tekirdağ
Ofis 2003
Dün,22:27
Çözüldü 
üst örnekteki kodu yeni modül içine yapıştırın

Visual Basic Code
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


accessman

Kullanici Avatari
Onursal
2.367
31/10/2008
425
Denizli
Ofis 2003
20/09/2016,00:20
Çözüldü 
Tesekkurler
@benbendedeilem
Cevapla







Konuyu Okuyanlar: 1 Ziyaretçi


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Tarih Son Yorum
  Linkteki Resmi Bilgisayar kayıt Etmek Makrovba 4 481 19/04/2016, 17:22 ozanakkaya
Çözüldü Bilgisayar adını metin kutusuna yazdırmak misilak 3 394 13/01/2016, 18:04 atoz112
Çözüldü Dosya açık mı kontrolü neyzen006 3 523 06/08/2015, 21:56 mehmetdemiral
Çözüldü bilgisayar toplama programı kaldem 30 6.955 08/05/2015, 18:55 pspasc
Çözüldü ağdaki başkabir access dosyasında bulunana tablodaki verilerin hepsini çekme moskovic 1 1.482 06/06/2014, 19:00 moskovic


Türkçe Çeviri: MCTR, Forum Yazılımı: MyBB, © 2002-2016 MyBB Group.
DMCA.com Protection Status
© Desing by XSTYLED| Develops by ozanakkaya