• بادئ الموضوع بادئ الموضوع click
  • تاريخ البدء تاريخ البدء

click

زيزوومى مبدع
إنضم
8 أكتوبر 2007
المشاركات
1,072
مستوى التفاعل
126
النقاط
650
غير متصل
حيث جربت اكثر من نسخة معدله في المنتدى ، ولكن لا تعمل معي جيدا
 

توقيع : click
هو تفعيل رسمي ولأكثر من جهاز ، واريد ان اخذه من جهاز لدي اخر نسخة منه ليكون على جهاز اخر
 

توقيع : click
هو تفعيل رسمي ولأكثر من جهاز ، واريد ان اخذه من جهاز لدي اخر نسخة منه ليكون على جهاز اخر
تمام
يمكنك تجربة هذا الملف بالمرفقات وسيستخرج المفتاح لك
ضع هذا الكود في ملف بإمتداد vbs
مثال: test.vbs
وقم بتشغيله وسيتم استخراج التفعيل
كود:
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 = "Product Name: " & objshell.RegRead(Path & "ProductName")
ProductID = "Product ID: " & objshell.RegRead(Path & "ProductID")
ProductKey = "Installed Key: " & ConvertToKey(DigitalID)
ProductData = ProductName & vbNewLine & ProductID & vbNewLine & ProductKey
'Show messbox if save to a file
If vbYes = MsgBox(ProductData & vblf & vblf & "Save to a file?", vbYesNo + vbQuestion, "BackUp Windows Key Information") 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\WindowsKeyInfo.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.CreateTextFile(fName)
txt.Writeline Data
txt.Close
End Function
أو بالمرفقات, فقط استبدل الإمتداد من .txt إلى .vbs
 

المرفقات

توقيع : MesterPerfectMesterPerfect is verified member.
هل سيؤثر على نسخة الجهاز الاساسي المفعل ام لا

الملف شغال تسلم

2021-06-09_162335.webp


هل هناك اداة كذلك للاوفيس 2016 برو او 2019 برو
 
التعديل الأخير:
توقيع : click
هل سيؤثر على نسخة الجهاز الاساسي المفعل ام لا

الملف شغال تسلم

مشاهدة المرفق 220869

هل هناك اداة كذلك للاوفيس 2016 برو او 2019 برو
طالما المفتاح عام لن تواجه مشكلة إن شاء الله يا غالي
أعتقد أن هناك أداة للأوفيس سأبحث لك عنها
 
توقيع : MesterPerfectMesterPerfect is verified member.
  • Like
التفاعلات: click
بارك الله فيك

يا اخي اكثر الله من امثالك وجعل تعبك معي في ميزان حسناتك

في انتظارك يا غالي
 
توقيع : click
عودة
أعلى