Belgelerin bilgisayarın mac adresine göre çalışması (özelleştirilmesi)

[fethiye]

Herkese merhaba;
Forumda aradım ama bulamadım. Konu makro ve VBA ile ilgili olabilir diye buraya yazdım. Yapmış olduğumuz herhangi bir belgenin ya da programın bilgisayarın mac adresine göre özelleştirebilir miyiz?. Yani yapmış olduğumuz program bilgisayarın mac adresini sorgulayacak ve eğer uyarsa çalışacak aksi taktirde çalışmayı reddedecek.

 

[mesuttasar]

Herkese merhaba;
Forumda aradım ama bulamadım. Konu makro ve VBA ile ilgili olabilir diye buraya yazdım. Yapmış olduğumuz herhangi bir belgenin ya da programın bilgisayarın mac adresine göre özelleştirebilir miyiz?. Yani yapmış olduğumuz program bilgisayarın mac adresini sorgulayacak ve eğer uyarsa çalışacak aksi taktirde çalışmayı reddedecek.

Selamlar ,internetten bulduğum aşağıdaki kodlar bilgisayarınızın mac adresini bulmanızı sağlıyor.

[FONT=Arial]Option Explicit[/FONT]
[FONT=Arial]Sub testme01()[/FONT]
 
[FONT=Arial]Dim strComputer As String[/FONT]
[FONT=Arial]Dim objWMIService As Object[/FONT]
[FONT=Arial]Dim colAdapters As Object[/FONT]
[FONT=Arial]Dim objAdapter As Object[/FONT]
 
[FONT=Arial]strComputer = "."[/FONT]
[FONT=Arial]Set objWMIService = GetObject _[/FONT]
[FONT=Arial]("winmgmts:" & "!\\" & strComputer & "\root\cimv2")[/FONT]
[FONT=Arial]Set colAdapters = objWMIService.ExecQuery _[/FONT]
[FONT=Arial]("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")[/FONT]
[FONT=Arial]For Each objAdapter In colAdapters[/FONT]
[FONT=Arial]MsgBox "Physical address: " & objAdapter.MACAddress[/FONT]
[FONT=Arial]Next objAdapter[/FONT]
[FONT=Arial]End Sub[/FONT]

 

[fethiye]

Mesut Bey; Cevabınız için teşekkürler. Şu anda sabit bulunmadığımdan makroyu deneme imkanım olmadı. Ancak bilgisayarın mac adresini bulduktan sonra örnek dosyamızda dosyamızı çalıştırmak istediğimiz bilgisayarın mac adresi ile karşılaştırıp eşleşirse örnek dosyamızın çalışmasını, eşleşmezse dosyamızın çalışmamasını nasıl sağlarız?. Örneğin yukarıdaki kod ile bulduğumuz, bilgisayarımızın mac adresini dosyada belirteceğim çalışmasını isteyeceğim bilgisayarın mac adresi ile karşılaştırıp aynıysa çalışmasını, değilse çalışmamasını nasıl sağlarım?

 

[mesuttasar]

Sayın fethiye , yukarıda bulunan kodlar , bilgisayarın mac adresini buluyor.Örnek dosyanızın içinde , dosyada çalışmaya yetkili olan bilgisayarların mac adreslerinin bulunduğu bir kısım olmalı.Autpen makrosuna , bu bilgisayarın mac adresi , tabloda bulunan mac adreslerinin herhangi biriyle uyuşup uyuşmadığını kontrol et , uyuyorsa açıl uymuyorsa kapat şeklinde kodlar ilave edilmeli.Sorunun ilk kısmını yukarıdaki kodlarla halledebilirsiniz , diğer kısımlarla ilgili forumda parola sorgula diye aratırsanız ustaca hazırlanmış çok güzel kodlar bulabilirsiniz.Saygılarımla

 

[fethiye]

Teşekkürler, Mesut Bey.

 

[mesuttasar]

Örnek bir dosya ekledim.Sınama sayfasında , H sütununda belgeyi kullanacak olan bilgisayarların mac adreslerini alt alta yazıp denermisiniz.

Option Explicit
Sub testme01()
 
Dim strComputer As String
Dim objWMIService As Object
Dim colAdapters As Object
Dim objAdapter As Object
 
strComputer = "."
Set objWMIService = GetObject _
("winmgmts:" & "!\\" & strComputer & "\root\cimv2")
Set colAdapters = objWMIService.ExecQuery _
("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each objAdapter In colAdapters
'MsgBox "Physical address: " & objAdapter.MACAddress
Sheets("SINAMA").Select
[a1] = "Physical address: "
[a2] = objAdapter.MACAddress
Columns("a").AutoFit
Next objAdapter
End Sub
 
'____________________________________________________________________
 
Sub auto_open()
Static HATA As Integer
Dim KULLANICI As Long
Call testme01
On Error GoTo HATALI_GİRİŞ
Application.Visible = False
With Sheets("SINAMA").Range("H1:H100")
KULLANICI = .Find(What:=Cells(2, 1).Value, LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase _
        :=True, SearchFormat:=False).Row
End With
If KULLANICI = 0 Then GoTo HATALI_GİRİŞ
MsgBox "Sisteme girişiniz onaylanmıştır.", vbInformation, "HOŞGELDİNİZ "
Application.Visible = True
Exit Sub
HATALI_GİRİŞ:
MsgBox "Bu bilgisayarda , bu dosyayı çalıştırmaya yetkiniz yoktur." _
& Chr(10) & "Lütfen sistem yöneticisiyle iletişime geçiniz." _
& Chr(10) & ".........", vbCritical, "DİKKAT !"
HATA = 1
Application.DisplayAlerts = False
If HATA = 1 Then Application.Quit
End Sub

 

[fethiye]

Teşekkürler Mesut Bey, Bayram dolayısıyla dışrıdayım, hazırlamış olduğunuz dosyayı deneyeceğim. Tekrar teşekkürler, iyi bayramlar...

 

[maskex]

Örnek bir dosya ekledim.Sınama sayfasında , H sütununda belgeyi kullanacak olan bilgisayarların mac adreslerini alt alta yazıp denermisiniz.

Option Explicit
Sub testme01()

Dim strComputer As String
Dim objWMIService As Object
Dim colAdapters As Object
Dim objAdapter As Object

strComputer = "."
Set objWMIService = GetObject _
("winmgmts:" & "!\\" & strComputer & "\root\cimv2")
Set colAdapters = objWMIService.ExecQuery _
("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each objAdapter In colAdapters
'MsgBox "Physical address: " & objAdapter.MACAddress
Sheets("SINAMA").Select
[a1] = "Physical address: "
[a2] = objAdapter.MACAddress
Columns("a").AutoFit
Next objAdapter
End Sub

'____________________________________________________________________

Sub auto_open()
Static HATA As Integer
Dim KULLANICI As Long
Call testme01
On Error GoTo HATALI_GİRİŞ
Application.Visible = False
With Sheets("SINAMA").Range("H1:H100")
KULLANICI = .Find(What:=Cells(2, 1).Value, LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase _
        :=True, SearchFormat:=False).Row
End With
If KULLANICI = 0 Then GoTo HATALI_GİRİŞ
MsgBox "Sisteme girişiniz onaylanmıştır.", vbInformation, "HOŞGELDİNİZ "
Application.Visible = True
Exit Sub
HATALI_GİRİŞ:
MsgBox "Bu bilgisayarda , bu dosyayı çalıştırmaya yetkiniz yoktur." _
& Chr(10) & "Lütfen sistem yöneticisiyle iletişime geçiniz." _
& Chr(10) & ".........", vbCritical, "DİKKAT !"
HATA = 1
Application.DisplayAlerts = False
If HATA = 1 Then Application.Quit
End Sub

Merhabalar,

@mesuttasar

Elinize sağlık dosya belirttiğiniz gibi çalışıyor.