-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
excelin başka makinada çalışmaması
- Konbuyu başlatan zırzır
- Başlangıç tarihi
- Katılım
- 1 Temmuz 2005
- Mesajlar
- 2,607
- Excel Vers. ve Dili
- Ofis 2013 TR 64 Bit
Merhaba,
Aşağıdaki kodları inceleyiniz. İlk çalıştığında msgbox penceresinde verdiği hata kodu aslında disk seri no dur. Onu not alın ve daha sonra kodların içinde renkli olarak belirttiğim yere yazın. İsterseniz çalışmasını engelleyebilir, isterseniz deneme süresi verebilirsiniz. Güle güle kullanın.
Aşağıdaki kodları inceleyiniz. İlk çalıştığında msgbox penceresinde verdiği hata kodu aslında disk seri no dur. Onu not alın ve daha sonra kodların içinde renkli olarak belirttiğim yere yazın. İsterseniz çalışmasını engelleyebilir, isterseniz deneme süresi verebilirsiniz. Güle güle kullanın.
Kod:
Declare Function GetVolumeInformationA Lib "Kernel32" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Sub Auto_Open()
Dim i As Integer
Dim j As Integer
Dim SerialNumber As Long
Application.ScreenUpdating = False
Application.EnableCancelKey = xlDisabled
'Şifre Bölümü
GetVolumeInformationA "C:\", vbNullString, 0, _
SerialNumber, 0, 0, vbNullString, 0
If SerialNumber <> [B][COLOR="Blue"]xxxxxxxxx [/COLOR][/B]Then
MsgBox "Kopya Program Kullanıyorsunuz...", vbCritical, "D i k k a t . . . !"
MsgBox " Lütfen 0 xxxxxxxx no.lu telefondan dEdE'yi arayınız.. Hata Kodu : " & SerialNumber, vbInformation, "Bilgi İçin"
ActiveWorkbook.Close
End If
Application.EnableCancelKey = xlDisabled
'Deneme süresi verme bölümü
Worksheets("Sayfa1").Range("A1") = Worksheets("Sayfa1").Range("A1") + 1
If Worksheets("Sayfa1").Range("A1").Value > 5 Then
MsgBox "Deneme Süreniz Doldu. Lütfen 0 xxxxxxxxx no.lu telefondan dEde'yi arayınız.. ", vbCritical, "ÜZGÜNÜM"
auto_close
End If
End Sub
Sub auto_close()
Application.ScreenUpdating = True
ActiveWorkbook.Save
Application.Quit
End Sub
Son düzenleme:
Bir alternatifte benden olsun,
Haluk Bey'e ait bir dosyayı arşivimden buldum, CPUID2.xls dosyasında bazı düzenlemeler yaptım, öncelikle "donanım bilgileri.xls" dosyasını çalıştırın, buradaki "İŞLEMCİ" butonuna tıklayın, msgbox'da karşınıza çıkan CPUID yi bir yere not edin, daha sonra CPUID2.xls dosyasını makroları devre dışı bırakarak çalıştırın B2 hücresine; not ettiğiniz CPUID'yi yazın ve dosyanızı kaydedin, daha sonra CPUID2.xls dosyasını makroları etkinleştirerek açın, eğer farklı bir bilgisayarda bu dosyayı (CPUID2.xls) açmak isterseniz dosyanın açılmayacağını görebilirsiniz. dosyalar ektedir, iyi çalışmalar dilerim.