| 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 | |
| keypart1 = Mid(KeyOutput, 2, Last) | |
| insert = "N" | |
| KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0) | |
| If Last = 0 Then KeyOutput = insert & KeyOutput | |
| 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 |
I keep getting error message when trying to save key to file.
I keep getting error message when trying to save key to file.
Did you figure it out? One of my clients is reporting the same issue. It works for a lot of other people though.
No, I never rec'd a response.
No, I never rec'd a response.
I think its to do with the path it saves to. I do not have access to my CU computer that experiences the issue so I got the info manually.
If it helps and you have access to a computer that you can test on, change the destination where it writes and remove the variable " & UserName & " to a permanent one. My guess is something with this variable is making an issue.
Regarding the error code 800A004C:
The error can occur if you've relocated the Desktop folder or your Users home path is in a different drive than C:.
Change the following code in line #60:
fName = "C:\Users\" & UserName & "\Desktop\WindowsKeyInfo.txt"
to a fixed path like:
fName = "D:\WindowsKeyInfo.txt"
Works