DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Test()
' Haluk - 28/10/2022
' sa4truss@gmail.com
Dim objWMI As Object
Const HKEY_LOCAL_MACHINE As Long = &H80000002
Const strParentKey As String = "SOFTWARE\Microsoft\Office\14.0\Registration"
Set objshell = CreateObject("WScript.Shell")
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
objWMI.EnumKey HKEY_LOCAL_MACHINE, strParentKey, arrSubKeys
For Each strSubKey In arrSubKeys
strKey = strParentKey & "\" & strSubKey
objWMI.EnumKey HKEY_LOCAL_MACHINE, strKey, arrKeys
If IsArray(arrKeys) Then
regPath = "HKEY_LOCAL_MACHINE\" & strKey & "\"
ProductName = "Product Name: " & objshell.RegRead(regPath & "ProductNameNonQualified")
ProductID = "Product ID: " & objshell.RegRead(regPath & "ProductID")
DigitalID = objshell.RegRead(regPath & "DigitalProductId")
ProductKey = "Product Key: " & ConvertToKey(DigitalID)
ProductData = ProductName & vbCrLf & ProductID & vbCrLf & ProductKey
End If
Next
MsgBox ProductData
Set objshell = Nothing
Set objWMI = Nothing
End Sub
'
Function ConvertToKey(Key)
Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
Const KeyOffset = 52
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
Merhaba Tahsin bey (@tahsinanarat),
Office 2019 Lisansınızı marketten görebileceğiniz gibi, bu sayfadaRegedit
den belirtilenBilgisayar\HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\SoftwareProtectionPlatform
yoldaBackupProductKeyDefault
anahtarından Office 2019 yedek anahtarınızı temin edebilirsiniz.
İyi çalışmalar.
Merhaba,Bu arada..... 14 No'lu mesajda önerilen yolda bulunan anahtar Office programının mı yoksa Windows'un mu tam emin değilim ....
Hocam çok eski bir mini program. Yeni tip antivirüs ve benzerleri bu sebepten uyarı veriyor olabilir.