Display Wifi Password on Desktop Screen

Copy This CODE:

Option Explicit

Dim Ws,AppData,Wifi_Folder,fso,f,Data

Dim SSID,KeyPassword,ExportCmd,oFolder,File,Info,LogFile

LogFile = Left(Wscript.ScriptFullName,InstrRev(Wscript.ScriptFullName, ".")) & "txt"

Set Ws = CreateObject("Wscript.Shell")

Set fso = CreateObject("Scripting.FileSystemObject")

AppData = ws.ExpandEnvironmentStrings("%AppData%")

Wifi_Folder = AppData & "\Wifi"

If Not fso.FolderExists(Wifi_Folder) Then fso.CreateFolder(Wifi_Folder)

ExportCmd = "Cmd /C netsh wlan export profile key=clear folder="& Wifi_Folder &""

ws.run ExportCmd,0,True

Set oFolder = fso.GetFolder(Wifi_Folder)

Info = String(40,"-") & vbCrlf & Space(4) &_

"SSID" & Space(3) &":"& Space(3) & "Password" & vbCrlf &_

String(40,"-") & vbCrlf

For Each File in oFolder.Files

If UCase(fso.GetExtensionName(File.Name)) = "XML" Then

Set f=fso.opentextfile(File,1)

Data = f.ReadAll

SSID = Extract(Data,"(?:<name>)(.*)(?:<\/name>)")

KeyPassword = Extract(Data,"(?:<keyMaterial>)(.*)(?:<\/keyMaterial>)")

Info = Info & qq(SSID) & ":" & qq(KeyPassword) & vbCrlf

End If

Next

MsgBox Info,vbInformation

Call WriteLog(Info,LogFile)

If fso.FileExists(LogFile) Then ws.run qq(LogFile)

'---------------------------------------------------------------------------------------------

Function Extract(Data,Pattern)

Dim oRE,colMatches,Match,numMatches,myMatch

Dim numSubMatches,subMatchesString,i,j

set oRE = New RegExp

oRE.IgnoreCase = True

oRE.Global = False

oRE.MultiLine = True

oRE.Pattern = Pattern

set colMatches = oRE.Execute(Data)

numMatches = colMatches.count

For i=0 to numMatches-1   

'Loop through each match

Set myMatch = colMatches(i)

numSubMatches = myMatch.submatches.count

'Loop through each submatch in current match

If numSubMatches > 0 Then    

For j=0 to numSubMatches-1

subMatchesString = subMatchesString & myMatch.SubMatches(0)

Next

End If

Next

Extract = subMatchesString

End Function

'---------------------------------------------------------------------------------------------

Function qq(str) 

qq = Chr(34) & str & Chr(34) 

End Function

'---------------------------------------------------------------------------------------------

Sub WriteLog(strText,LogFile)

Dim fs,ts 

Const ForWriting = 2

Set fs = CreateObject("Scripting.FileSystemObject")

Set ts = fs.OpenTextFile(LogFile,ForWriting,True)

ts.WriteLine strText

ts.Close

End Sub

'---------------------------------------------------------------------------------------------

Note: Save File as  (.vbs) extension 

Thanks