Windows Seri key

GO TO ADMIN PANEL > ADD-ONS AND INSTALL VERTIFORO SIDEBAR TO SEE FORUMS AND SIDEBAR

asiruh012

Torrent-Oyun.com
Katılım
Nis 2, 2012
Mesajlar
1,403
Beğeniler
40
Puanları
48
#1
Selamlar geçenlerde konu açmıştım laptop alacam diye ama fredoss getirteceğim kendim windows 10 u yükletip kendi pc min serial keyini ona atmayı düşünüyodum böyle birşey yapabilir miyim? yapabilirsem windows keyini nasıl öğrenirim?
 

GREY

[TechGuy]
Katılım
Nis 5, 2017
Mesajlar
2,823
Beğeniler
1,168
Puanları
113
#3
Option Explicit

Dim objshell,path,DigitalID, Result
Set objshell = CreateObject("WScript.Shell")
'Set registry key path
Path = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
'Registry key value
DigitalID = objshell.RegRead(Path & "DigitalProductId")
Dim ProductName,ProductID,ProductKey,ProductData
'Get ProductName, ProductID, ProductKey
ProductName = "Windows sürümü: " & objshell.RegRead(Path & "ProductName")
ProductID = "Ürün Kimliği: " & objshell.RegRead(Path & "ProductID")
ProductKey = "Yüklü ürün anahtarı: " & ConvertToKey(DigitalID)
ProductData = ProductName & vbNewLine & ProductID & vbNewLine & ProductKey
'Show messbox if save to a file
If vbYes = MsgBox(ProductData & vblf & vblf & "Veriler bir dosyaya kaydedilsin mi?", vbYesNo + vbQuestion, "Windows anahtar bilgilerini yedekle") then
Save ProductData
End If



'Convert binary to chars
Function ConvertToKey(Key)
Const KeyOffset = 52
Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
'Check if OS is Windows 8
isWin8 = (Key(66) \ 6) And 1
Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
i = 24
Maps = "BCDFGHJKMPQRTVWXY2346789"
Do
Current= 0
j = 14
Do
Current = Current* 256
Current = Key(j + KeyOffset) + Current
Key(j + KeyOffset) = (Current \ 24)
Current=Current Mod 24
j = j -1
Loop While j >= 0
i = i -1
KeyOutput = Mid(Maps,Current+ 1, 1) & KeyOutput
Last = Current
Loop While i >= 0

If (isWin8 = 1) Then
keypart1 = Mid(KeyOutput, 2, Last)
insert = "N"
KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
If Last = 0 Then KeyOutput = insert & KeyOutput
End If


ConvertToKey = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)


End Function
'Save data to a file
Function Save(Data)
Dim fso, fName, txt,objshell,UserName
Set objshell = CreateObject("wscript.shell")
'Get current user name
UserName = objshell.ExpandEnvironmentStrings("%UserName%")
'Create a text file on desktop
fName = "C:\Users\" & UserName & "\Desktop\AnahtarBul.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.CreateTextFile(fName)
txt.Writeline Data
txt.Close
End Function
Hocam bu kodu metin belgesine kopyalayın ve ismini girdikten sonra ".vbs" olarak kaydedin sonra çalıştırın
 

Torrent-Oyun Discord

Oyunlar

Yasal Uyarı

Sitemiz, hukuka, yasalara, telif haklarına ve kişilik haklarına saygılı olmayı amaç edinmiştir. Sitemiz, 5651 sayılı yasada tanımlanan "yer sağlayıcı" olarak hizmet vermektedir. İlgili yasaya göre, site yönetiminin hukuka aykırı içerikleri kontrol etme yükümlülüğü yoktur. Bu sebeple, sitemiz "uyar ve kaldır" prensibini benimsemiştir.

Yasal Uyarı

Telif hakkına konu olan eserlerin yasal olmayan bir biçimde paylaşıldığını ve yasal haklarının çiğnendiğini düşünen hak sahipleri veya meslek birlikleri, sikayet@torrent-oyun.com mail adresinden bize ulaşabilirler. Bizle iletişime geçilmesi halinde ilgili kanunlar ve yönetmelikler çerçevesinde en geç 1 (Bir) Hafta içerisinde size dönüş yapılıp gerekli bilgi verilecektir.
Üst Alt