Cihazın Seri Numarasını aldırma

[necrofilus]

Herkese merhaba,

Yaptığım bi excel çalışmasında programın başka cihazlarda çalışmaması için bilgisayarın hdd yada cpu seri numarasını aldırmayı istiyorum. hdd seri numarası aldırmayla ilgili bazı kodlar buldum ancak bunların fiziksel seri numaralar olmadığını formatlama esnasında değiştiğini öğrendim.

Değişmeyen bir seri numarası aldırmak istiyorum bunda da en güvenilir olarak cpu seri numarası olduğunu öğrendim ancak bunu yapabilecek kodu bir türlü bulamadım yardımcı olursanız çok sevinirim.

 

[dEdE]

Merhaba,
Sayın Raider' ait olan aşağıdaki kodlar işinizi görür sanırım.

Sub CPU_Bilgileri()
Dim MyOBJ As Object
Dim MyCPU As Variant
Dim MyMsg As String
On Error Resume Next
Set MyOBJ = GetObject("WinMgmts:").instancesOf _
            ("Win32_Processor")
If Err.Number <> 0 Then
  MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _
  "Windows Management Instrumentation"
  Exit Sub
On Error GoTo 0
End If
For Each MyCPU In MyOBJ
    MyMsg = "İşlemci : " & Trim(MyCPU.Name) & vbCrLf
    MyMsg = MyMsg & "Üretici Firma : " & MyCPU.Manufacturer & vbCrLf
    MyMsg = MyMsg & "CPU ID    : " & MyCPU.ProcessorId & vbCrLf
    MyMsg = MyMsg & "CPU hızı    : " & MyCPU.CurrentClockSpeed & vbCrLf
    MyMsg = MyMsg & "Max CPU hızı    : " & MyCPU.MaxClockSpeed & vbCrLf
Next
MsgBox MyMsg, vbInformation, "CPU Bilgileri   (Raider ®)"
End Sub

 

[necrofilus]

İhtiyacım olandan bile fazlası teşekkür ederim

 

[sailor01]

Teşekkürler

Ellerinize, bilgilerinize sağlık. Harika oldu :dua2:

 

[scbeliaal]

hocam emeğine sağlık. cpu id yi nerden öğrenebiliriz?

 

[antonio]

Harikasınız dEdE! Bir o kadar teşekkür ve dua da benden gelsin..
Bu konuda hiç bir bilgim henüz yok. Sizin yazdığınız kodları, yaptığımız her hangi bir çalışmaya sadece bu haliyle mi ekleyeceğiz, yoksa değiştirmemiz gereken yerler mi var?
Önceden teşekkürler, saygılarımla..

 

[halit3]

Alternatif kod

Sub cpual()

Dim wmi, cpu, cpuid
  Set wmi = GetObject("winmgmts:")
  For Each cpu In wmi.InstancesOf("Win32_Processor")
   cpuid = cpuid + cpu.ProcessorID
  Next
  MsgBox cpuid
End Sub

Kaynak link

http://www.codeproject.com/Questions/51037/How-to-read-system-processor-id-in-VB6-0

 

[antonio]

Teşekkürler Halit hocam..

 

[direnvip]

Peki sayın Dede bunu excel dosyasının açılmaması için nasıl kullanabiliriz.daha açıklayacı olmak gerekirse bir dosya var ve sadece benim bilgisayarımda görüntülenmesi gerekiyor başka bir yere gönderilmesi halinde dosyanın otomatik kapatılmasını görüntülnememesi CPU üzerinden saglayabilir miyim ?
teşekkürler

Merhaba,
Sayın Raider' ait olan aşağıdaki kodlar işinizi görür sanırım.

Sub CPU_Bilgileri()
Dim MyOBJ As Object
Dim MyCPU As Variant
Dim MyMsg As String
On Error Resume Next
Set MyOBJ = GetObject("WinMgmts:").instancesOf _
            ("Win32_Processor")
If Err.Number <> 0 Then
  MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _
  "Windows Management Instrumentation"
  Exit Sub
On Error GoTo 0
End If
For Each MyCPU In MyOBJ
    MyMsg = "İşlemci : " & Trim(MyCPU.Name) & vbCrLf
    MyMsg = MyMsg & "Üretici Firma : " & MyCPU.Manufacturer & vbCrLf
    MyMsg = MyMsg & "CPU ID    : " & MyCPU.ProcessorId & vbCrLf
    MyMsg = MyMsg & "CPU hızı    : " & MyCPU.CurrentClockSpeed & vbCrLf
    MyMsg = MyMsg & "Max CPU hızı    : " & MyCPU.MaxClockSpeed & vbCrLf
Next
MsgBox MyMsg, vbInformation, "CPU Bilgileri   (Raider ®)"
End Sub

 

[Korhan Ayhan]

İlk olarak her ihtimale karşı dosyanızın bir yedeğini oluşturun.

Sonra aşağıdaki kodu bir modüle uygulayın.

Function CPU_NO()
    Dim Nesne As Object
    Dim Veri As Variant
    
    On Error Resume Next
    Set Nesne = GetObject("WinMgmts:").InstancesOf("Win32_Processor")
    On Error GoTo 0
    
    For Each Veri In Nesne
        CPU_NO = Veri.ProcessorId
    Next
End Function

Daha sonra aşağıdaki kodu ise çalışmanızın "BuÇalışmaKitabı" bölümüne uygulayın.

Kod içindeki kırmızı bölüme kendi CPU nosunu yazıp dosyanızı makro içeren dosya formatında kayıt edip kapatın.

Private Sub Workbook_Open()
    If CPU_NO <> "[COLOR="Red"]AAA12345AAA[/COLOR]" Then
        ThisWorkbook.Save
        If Excel.Application.Windows.Count = 1 Then
            Application.Quit
        Else
            ThisWorkbook.Close 0
        End If
    End If
End Sub

Son olarak dosyanızı yeniden açmayı deneyin. CPU nosu farklı bilgisayarlarda dosyanız açılmayacaktır.

 

[__TR__]

Farklılık zenginliktir!
Aşağıdaki kod dosya açılışının veya başka bir yere taşınmasının dışında görünmesini istemediğiniz bilgilerin yer aldığı Sekmenin izinsiz, şifresiz görüntülenmemesi üzerine kurgulanmıştır.
Şunu belirtmekte fayda var; bu kod şuanki haliyle, uyguladığınız sekmeye her geçişte programı kullanan sizde olsanız şifre girmeye zorlamaktadır.

Kodu şifre ile girilmesini istediğiniz sekmenin kod bölümüne ekleyiniz. Giriş şifresi kırmızı ile renklendirilmiştir.

Private Sub Worksheet_Activate()
Application.Visible = False
[COLOR="Red"]Şifre = "abc"[/COLOR]
Yaz_Şifre = InputBox("Lütfen Şifre Giriniz!", "")
If Yaz_Şifre <> Şifre Then Sheets("Sayfa1").Select
Application.Visible = True
End Sub