Jump to content

VBS Script That Makes A HTA

gunsmokingman
 Share

Recommended Posts

gunsmokingman

gunsmokingman

Posted
Posted

Here is a VBS script that searches all the Local Hardd rives for MP3 and WMA files, it then

adds them to a HTA that has a play button for each song added.

strComputer = "."
Dim Act, Fso, Ts, CT, DT : CT = 0 : DT = 0 
Dim Ext, FName, PName, Mp3Rpt,WmaRpt, S_5, V, Wma,Mp3 : Wma = 0 : Mp3 = 0
Dim HtaMp3, HtaWma, Uname, HtaL1, L1Hta, HtaL2, L2Hta
S_5 = Space(5) : V = vbCrLf  
Set Act = CreateObject("Wscript.Shell")
Set Fso = CreateObject("Scripting.FileSystemObject")
UName = Act.ExpandEnvironmentStrings("%UserName%") 
Dim U_Desk : U_Desk = Act.SpecialFolders.Item("Desktop")
  Seek_MP3_WMA
	''''''''''''''''''''''''
'/-> Hta Styles, Onload Script For The HTA
	''''''''''''''''''''''''
   Function BuildTheHta
   Ts.WriteLine S_5 & "<HTML><HEAD><TITLE>" & Uname & ", Music Collection</TITLE>"  
   Ts.WriteLine S_5 & "<HTA:APPLICATION"
   Ts.WriteLine S_5 & "ID = ""My Music Collection"" APPLICATIONNAME = ""My Music Collection"""
   Ts.WriteLine S_5 & "BORDER = ""thick""		   CAPTION = ""Yes"""
   Ts.WriteLine S_5 & "SHOWINTASKBAR = ""Yes""	  SINGLEINSTANCE = ""Yes"""
   Ts.WriteLine S_5 & "SYSMENU = ""Yes""			WINDOWSTATE = ""normal"""
   Ts.WriteLine S_5 & "VERSION = ""1.2.1""		  INNERBORDER = ""yes"""
   Ts.WriteLine S_5 & "SELECTION = ""yes""		  MAXIMIZEBUTTON = ""No"""
   Ts.WriteLine S_5 & "MINIMIZEBUTTON = ""Yes""	 NAVIGABLE = ""yes"""
   Ts.WriteLine S_5 & "CONTEXTMENU = ""yes""		BORDERSTYLE = ""normal"""
   Ts.WriteLine S_5 & "Icon = ""%SystemRoot%\Explorer.exe"">"  
   Ts.WriteLine S_5 & "<STYLE>Body.Normal"
   Ts.WriteLine S_5 & "{ font:12.75pt Poor Richard;color:#808080;filter:progid:DXImageTransform.Microsoft.Gradient"
   Ts.WriteLine S_5 & "(GradientType=0,StartColorStr='#dedad4',EndColorStr='#cac6c0');}"
   Ts.WriteLine S_5 & "td.Bar1"
   Ts.WriteLine S_5 & "{ font:9.75pt Poor Richard;color:#000080;filter:progid:DXImageTransform.Microsoft.Gradient"
   Ts.WriteLine S_5 & "(GradientType=0, StartColorStr='#5e9ab9',EndColorStr='#eeeeee');}"   
   Ts.WriteLine S_5 & ".Bttn1"
   Ts.WriteLine S_5 & "{ font:10.75pt;font-family:Poor Richard;font-weight:Italic;line-height:110%;color:#edeced;"
   Ts.WriteLine S_5 & "(background-color : #6CA2E3;filter:progid:DXImageTransform.Microsoft.Gradient}"
   Ts.WriteLine S_5 & "(GradientType=0,StartColorStr='#c7c3be',endColorStr='#e8e4de');width:71;height:25;}"
   Ts.WriteLine S_5 & "{ font:10.75pt Poor Richard;color:#000080;filter:progid:DXImageTransform.Microsoft.Gradient"
   Ts.WriteLine S_5 & "(GradientType=0, StartColorStr='#5e9ab9',EndColorStr='#eeeeee');}"
   Ts.WriteLine S_5 & ""
   Ts.WriteLine S_5 & ""
   Ts.WriteLine S_5 & ""
   Ts.WriteLine S_5 & "</STYLE>"
   Ts.WriteLine S_5 & "<script> window.resizeTo (775,475), window.moveTo (450,275);</SCRIPT>"
   Ts.WriteLine S_5 & "<script language=""vbscript"">"
   Ts.WriteLine S_5 & "Dim Act, Fso, UName"
   Ts.WriteLine S_5 & "Set Act = CreateObject(""Wscript.shell"")"
   Ts.WriteLine S_5 & "Set Fso = CreateObject(""Scripting.FileSystemObject"")"
   Ts.WriteLine S_5 & "UName = Act.ExpandEnvironmentStrings(""%UserName%"") "
   Ts.WriteLine S_5 & "Function Window_Onload"
   Ts.WriteLine S_5 & "Label1.InnerHtml=  UName & "", Music Files""" 
   Ts.WriteLine S_5 & "End Function "
   Ts.WriteLine S_5 & ""
   Ts.WriteLine S_5 & "</SCRIPT>"
   Ts.WriteLine S_5 & "<CENTER><BODY Class=""Normal""><Table>"
   Ts.WriteLine S_5 & "<SPAN Id=""Label1""> </SPAN>"   
   Exit Function
   End Function
   Function Seek_MP3_WMA
   Act.Popup "Preparing to search all Local Hard Drive" & vbCrLf &_
			 "This will take a few minutes to complete", 7, "Start Search", 0 + 32
   Set Ts = Fso.OpenTextFile(U_Desk & "\MusicFileList.hta",2,True)
   BuildTheHta
   Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer& "\root\cimv2")
   Set colFiles = objWMIService.ExecQuery("Select * from CIM_DataFile Where Extension = 'MP3' OR Extension = 'WMA'")
   For Each objFile in colFiles
	CT = CT + 1 : DT = DT + 1 
	Ext = objFile.Extension : FName = objFile.FileName : PName = objFile.Name : FCnt = "File Counter : "
	''''''''''''''''''''''''
'/-> Removes Some MP3 Files 
	''''''''''''''''''''''''
	If "mp3" = Ext Then 
	If "demo" = FName Then 
	On Error Resume Next
	Else 
	If "0006076836202.01.01.001[1]" = FName Then 
	On Error Resume Next
	Else 
	If "thekillerssomebodytoldmedanceremix[1]" = FName Then 
	On Error Resume Next
	Else 
	If "what%20ive%20been%20looking%20for[1]" = FName Then 
	On Error Resume Next
	Else
	If "teddy-%20for%20you%20i%20will[1]" = FName Then 
	On Error Resume Next
	Else
	If "you%20know%20what%20they%20do%20to%20guys%20like%20us%20in%20prison[1]" = FName Then 
	On Error Resume Next
	Else
	If "0005008613227.01.01.008[1]" = FName Then 
	On Error Resume Next
	Else
	If "were%20all%20in%20this%20together[1]" = FName Then 
	On Error Resume Next
	Else
	If "0004400641072.01.01.007[1]" = FName Then 
	On Error Resume Next
	Else
	If "sf192965-01-01-02[1]" = FName Then 
	On Error Resume Next
	Else
	If "american folk" = FName Then 
	On Error Resume Next
	Else
	If "classic rock" = FName Then 
	On Error Resume Next
	Else
	If "hearts and flowers" = FName Then 
	On Error Resume Next
	Else
	If "swing" = FName Then 
	On Error Resume Next
	Else
	Hta_Mp3
	End If
	End If 
	End If 
	End If
	End If
	End If
	End If
	End If
	End If 
	End If 
	End If
	End If
	End If
	End If
	End If
	''''''''''''''''''''''''
'/-> Removes The Default WMP That Window Has
	''''''''''''''''''''''''
	If "wma" = Ext Then 
	If "Beethoven's Symphony No. 9 (Scherzo)" = FName Then 
	On Error Resume Next
	Else 
	If "New Stories (Highway Blues)" = FName Then
	On Error Resume Next
	Else 
	If "title" = FName Then
	On Error Resume Next
	Else 
	If "blank[1]" = FName Then
	On Error Resume Next
	Else
	Hta_Wma
	End If 
	End If 
	End If
	End If
	End If
	Next
	Ts.WriteLine "</TABLE><TABLE><TD>Amount Of MP3 File On The Computer » " & Mp3 & "</TD></TABLE><TABLE>"
	Ts.WriteLine L1Hta
	Ts.WriteLine "</TABLE><TABLE><TD>Amount Of WMA File On The Computer » " & Wma & "</TD></TABLE><TABLE>"
	Ts.WriteLine L2Hta
	Ts.Close
	Exit Function  
   End Function 
'/-> Add The Mp3
   Function Hta_Mp3
   Mp3 = Mp3 + 1 
   HtaL1 = (S_5 & "<script language=""vbscript""> Function MP3_" & DT &_
	 V & S_5 & "Act.Run(""wmplayer.exe "" & chr(34) & """ & PName & """ & chr(34))" &_
	 V & S_5 & " End Function </SCRIPT>" &_
	 V & S_5 & "<TABLE Border=""2""><TD Class=""Bar1"" Title=" & PName& "\" &FName&" width=""725"">    " &_
	 V & S_5 & "<INPUT Type=""Button"" Class=""Bttn1"" language=""vbscript"" OnClick=""MP3_" & DT & """ Value=""Play"">" &_
	 V & S_5 & "    " & UCase(FName & "." & Ext) & "</TD></TABLE>")
   L1Hta = L1Hta & vbCrLf & HtaL1
   End Function 
'/-> Add The WMA 
   Function Hta_Wma
   Wma = Wma + 1 
   HtaL2 = (S_5 & "<script language=""vbscript""> Function WMA_" & DT &_
	 V & S_5 & "Act.Run(""wmplayer.exe "" & chr(34) & """ & PName & """ & chr(34))" &_
	 V & S_5 & " End Function </SCRIPT>" &_ 
	 V & S_5 & "<TABLE Border=""2""><TD Class=""Bar1"" Title=" & PName& "\" &FName&" width=""725"">    " &_
	 V & S_5 & "<INPUT Type=""Button"" Class=""Bttn1"" language=""vbscript"" OnClick=""WMA_" & DT & """ Value=""Play"">" &_
	 V & S_5 & "    " & UCase(FName & "." & Ext) & "</TD></TABLE>")
   L2Hta = L2Hta & vbCrLf & HtaL2
   End Function 
'/-> Run The Hta 
	Act.Run(Chr(34) & U_Desk & "\MusicFileList.hta" & Chr(34))
'/-> Clean Up The VBS 
	Dim Vbs : Vbs = Act.ExpandEnvironmentStrings("%SystemDrive%\Find_Mp3Wma_v2.vbs")
	If Fso.FileExists(Vbs) Then Fso.DeleteFile(Vbs) End If

Here is a SFX file of the above code

Find_Mp3Wma_v2.exe


Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
 Share
Go to topic listing

  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...