Source code for resizevideo.hta

```
Option Explicit
```
```
On Error GoTo 0
```
```
 
```
```
Const wshFailed   = 2
```
```
Const wshFinished = 1
```
```
Const wshRunning  = 0
```
```
 
```
```
Dim arrPATH
```

Dim intCurrentHeight, intCurrentWidth, intMaxWidth, intMinWidth

```
Dim objFso, wshShell
```

Dim strFFMPEG, strFFPROBE, strVersion, strVideoInputFile, strVideoOutputFile

```
 
```
```
 
```
```
Sub window_onload()
```

	Dim intAnswer, intPosX, intPosY, strMsg, strParentFolder, strTitle

```
 
```
```
	strVersion = "1.00"
```
```
 
```
```
	On Error GoTo 0
```
```
 
```
```
	window.resizeTo 1200, 540
```

	intPosX = CInt( ( window.screen.width - 1200 ) / 2 )

```
	If intPosX < 0 Then intPosX = 0
```
```
	intPosY = 100
```
```
	window.moveTo intPosX, intPosY
```

	document.title = "ResizeVideo, Version " & strVersion & " " & Chr( 169 ) & " 2021 Rob van der Woude"

	Set wshShell = CreateObject( "WScript.Shell" )

	Set objFso   = CreateObject( "Scripting.Filesystemobject" )

	arrPATH      = Split( Replace( objFso.GetParentFolderName( self.location.pathname ) & ";" & wshShell.Environment.Item( "PATH" ), "/", "" ), ";" )

```
	strFFMPEG    = ""
```
```
	intMinWidth  = 320
```
```
	intMaxWidth  = 8192
```
```
	If Not CheckFFMPEG( ) Then
```

		strParentFolder =  Replace( objFso.GetParentFolderName( self.location.pathname ), "/", "" )

		strMsg          = "Unable to locate FFMPEG.EXE." _

```
		                & vbCrLf & vbCrLf _
```

		                & "Make sure it is available, and located either in this program's parent folder (""" & Replace( objFso.GetParentFolderName( self.location.pathname ), "/", "" ) & """) or in a directory listed in the PATH." _

```
		                & vbCrLf & vbCrLf _
```

		                & "Do you want to open the FFMPEG download page in your default browser now?"

```
		strTitle        = "Missing FFMPEG"
```

		intAnswer       = MsgBox( strMsg, vbYesNoCancel, strTitle )

```
		If intAnswer = vbYes Then
```

			wshShell.Run "https://www.gyan.dev/ffmpeg/builds/", 0, False

			MsgBox "Download and install the FFMPEG package and make sure FFMPEG.EXE is located either in this program's parent folder (""" & Replace( objFso.GetParentFolderName( self.location.pathname ), "/", "" ) & """ or in a directory listed in the PATH."

```
		ElseIf intAnswer = vbCancel Then
```
```
			AbortProgram
```
```
		End If
```
```
	End If
```
```
End Sub
```
```
 
```
```
 
```
```
Sub AbortProgram( )
```
```
	self.close
```
```
End Sub
```
```
 
```
```
 
```
```
Function CheckFFMPEG( )
```
```
	CheckFFMPEG = False
```
```
	Dim i
```
```
	For i = 0 To UBound( arrPATH )
```

		strFFMPEG = objFso.BuildPath( arrPATH(i), "ffmpeg.exe" )

		If objFso.FileExists( strFFMPEG ) Then

```
			CheckFFMPEG = True
```
```
			Exit For
```
```
		End If
```
```
	Next
```
```
End Function
```
```
 
```
```
 
```
```
Function CheckFFPROBE( )
```
```
	CheckFFPROBE = False
```
```
	Dim i
```
```
	For i = 0 To UBound( arrPATH )
```

		strFFPROBE = objFso.BuildPath( arrPATH(i), "ffprobe.exe" )

		If objFso.FileExists( strFFPROBE ) Then

```
			CheckFFPROBE = True
```
```
			Exit For
```
```
		End If
```
```
	Next
```
```
End Function
```
```
 
```
```
 
```
```
Sub GetCurrentWidth( )
```
```
	intCurrentWidth = 0
```

	strVideoInputFile = document.getElementById( "VideoFile" ).value

```
	If CheckFFPROBE Then
```

		Dim objExec, strFFProbeCommand, strResult

		strFFProbeCommand = """" & strFFPROBE & """ -v error -select_streams v:0 -show_entries stream=width,height -of csv=s=x:p=0 """ & strVideoInputFile & """"

		Set objExec = wshShell.Exec( strFFProbeCommand )

		strResult   = objExec.StdOut.ReadAll( )

```
		Set objExec = Nothing
```
```
		If InStr( strResult, "x" ) Then
```

			intCurrentWidth  = CInt( Mid( strResult, 1, InStr( strResult, "x" ) - 1 ) )

			intCurrentHeight = CInt( Mid( strResult,    InStr( strResult, "x" ) + 1 ) )

```
		End If
```
```
	Else
```
```
		Dim objDir, objFile, objShell
```

		Set objShell = CreateObject( "Shell.Application" )

		Set objDir   = objShell.Namespace( objFso.GetDriveName( strVideoInputFile ) )

```
		For Each objFile In objDir.Items
```

			If objFile.Path = strVideoInputFile Then

				intCurrentHeight = CInt( objDir.GetDetailsOf( objFile, 314 ) )

				intCurrentWidth  = CInt( objDir.GetDetailsOf( objFile, 316 ) )

```
 
```
```
			End If
```
```
		Next
```
```
	End If
```
```
	Set objDir   = Nothing
```
```
	Set objShell = Nothing
```

	document.getElementById( "CurrentWidth" ).value = intCurrentWidth

```
	intMaxWidth = intCurrentWidth
```
```
End Sub
```
```
 
```
```
 
```
```
Function Min( varA, varB )
```
```
	If varA > varB Then
```
```
		Min = varB
```
```
	Else
```
```
		Min = varA
```
```
	End If
```
```
End Function
```
```
 
```
```
 
```
```
Sub ShowHelp( )
```
```
	Dim strHelpText
```

	' Do not add more text, as it might be truncated by MsgBox limitations

	strHelpText = "ResizeVideo.hta,  Version " & strVersion & vbCrLf _

	            & "Resize a video and save it in MP4 format" & vbCrLf & vbCrLf _

	            & "USAGE:" & vbCrLf & vbCrLf _

	            & "* Select a video file by clicking the ""Browse"" button" & vbCrLf _

	            & "* Fill in the required new width" & vbCrLf _

	            & "* Click the ""Start Conversion"" button" & vbCrLf & vbCrLf _

	            & "The resized video file will be saved in the same directory where the selected video file is located, with "".resized**x**byffmpeg"" appended to its name, where **x** is the new width and height." & vbCrLf & vbCrLf _

	            & "Regardless of the input video format, the resized video will always be in MP4 format" & vbCrLf & vbCrLf _

	            & "REQUIREMENTS:" & vbCrLf & vbCrLf _

	            & "This HTA is just a front-end to FFMPEG which performs the resizing. It also uses FFPROBE if available." & vbCrLf _

	            & "FFMPEG and FFPROBE must both be located in the HTA's directory, or in a directory in the PATH." & vbCrLf & vbCrLf _

	            & "FFMPEG and FFPROBE can be downloaded at https://www.gyan.dev/ffmpeg/builds/" & vbCrLf & vbCrLf _

	            & "If at startup this HTA cannot find FFMPEG, you will be prompted to open its download URL." & vbCrLf & vbCrLf _

	            & "CREDITS:" & vbCrLf & vbCrLf _

	            & "Commands to probe and resize video:" & vbCrLf _

	            & "https://ottverse.com/change-resolution-resize-scale-video-using-ffmpeg/"

	MsgBox strHelpText, vbOKOnly, "Help for ResizeVideo.hta Version " & strVersion

```
End Sub
```
```
 
```
```
 
```
```
Sub StartConversion( )
```
```
	Dim arrVideoTypes
```
```
	Dim blnValidType
```
```
	Dim i, intAnswer, intWidth
```

	Dim strCommand, strConverted, strResize, strVideoInputType

```
 
```

	strVideoInputFile = document.getElementById( "VideoFile" ).value

```
 
```

	strVideoInputType = objFso.GetExtensionName( strVideoInputFile )

```
	blnValidType      = False
```

	arrVideoTypes     = Split( "mov;mp4", ";" ) ' may be extended, but must be tested for each video type

```
	For i = 0 To UBound( arrVideoTypes )
```

		If UCase( arrVideoTypes(i) ) = UCase( strVideoInputType ) Then

```
			blnValidType = True
```
```
			Exit For
```
```
		End If
```
```
	Next
```
```
 
```

	If Not blnValidType Or Trim( strVideoInputFile ) = "" Or Not objFso.FileExists( strVideoInputFile ) Then

		intAnswer = MsgBox( "Missing or invalid video file specification", vbRetryCancel, "Specify File" )

```
		If intAnswer = vbCancel Then
```
```
			AbortProgram
```
```
			Exit Sub
```
```
		End If
```
```
	End If
```
```
 
```

	intWidth = CInt( document.getElementById( "NewWidth" ).value )

```
	If intWidth = intCurrentWidth Then
```
```
		strConverted = ".convertedbyffmpeg"
```
```
		strResize    = ""
```
```
	Else
```
```
		' "scale='min(320,iw)':'min(240,ih)'"
```

		strConverted = ".resized" & intWidth & "x" & CInt( intCurrentHeight * intWidth / intCurrentWidth ) & "byffmpeg"

		strResize    = "-vf scale=" & intWidth & ":" & CInt( intCurrentHeight * intWidth / intCurrentWidth )

```
	End If
```
```
 
```
```
	With objFso
```

		strVideoOutputFile = .BuildPath( .GetParentFolderName( strVideoInputFile ), .GetBaseName( strVideoInputFile ) & strConverted & ".mp4" )

```
	End With
```
```
 
```

	If objFso.FileExists( strVideoOutputFile ) Then

		intAnswer = MsgBox( "Target file """ & 	strVideoOutputFile & """ already exists, do you want to delete it?", vbYesNoCancel + vbExclamation, "Existing File" )

```
		If intAnswer = vbYes Then
```

			objFso.DeleteFile strVideoOutputFile, True

			If objFso.FileExists( strVideoOutputFile ) Then

				MsgBox "Unable to delete the target file """ & strVideoOutputFile & """, try removing or renaming it manually", vbOKOnly, "Manual Intervention Required"

```
				Exit Sub
```
```
			End If
```
```
		ElseIf intAnswer = vbCancel Then
```
```
			AbortProgram
```
```
			Exit Sub
```
```
		Else
```

			MsgBox "Rename or remove the target file """ & strVideoOutputFile & """ manually and try again", vbOKOnly, "Manual Intervention Required"

```
			Exit Sub
```
```
		End If
```
```
	End If
```
```
 
```

	strCommand = """" & strFFMPEG & """ -i """ & strVideoInputFile & """ " & strResize & " -preset slow -crf 18 """ & strVideoOutputFile & """"

```
	wshShell.Run strCommand, 1, True
```
```
 
```

	If objFso.FileExists( strVideoOutputFile ) Then

		wshShell.Run """" & strVideoOutputFile & """", 0, False

		MsgBox "Converted video file saved as """ & strVideoOutputFile & """", vbOKonly, "Converted Video Saved"

```
	Else
```

		intAnswer = MsgBox( "Something went wrong, do you want to retry?", vbYesNoCancel + vbCritical, "Error" )

```
		If intAnswer = vbYes Then
```

			strCommand = "CMD.EXE /K " & strCommand

```
			wshShell.Run strCommand, 1, True
```

			If objFso.FileExists( strVideoOutputFile ) Then

				wshShell.Run """" & strVideoOutputFile & """", 0, False

```
			Else
```

				MsgBox "Something went wrong, check FFMPEG's console output to find the cause", vbOK + vbCritical, "Error"

```
			End If
```
```
		ElseIf intAnswer = vbCancel Then
```
```
			AbortProgram
```
```
		End If
```
```
	End If
```
```
End Sub
```
```
 
```
```
 
```
```
Sub ValidateWidth( )
```
```
	Dim objRE, strInput
```

	strInput = Trim( document.getElementById( "NewWidth" ).value )

```
	If strInput <> "" Then
```
```
		Set objRE = New RegExp
```
```
		objRE.Global  = True
```
```
		objRE.Pattern = "[^\d]+"
```
```
		If objRE.Test( strInput ) Then
```

			strInput = objRE.Replace( strInput, "" )

```
		End If
```
```
		Set objRE = Nothing
```

		If Len( strInput ) > Len( CStr( intMaxWidth ) ) Then strInput = Left( strInput, Len( CStr( intMaxWidth ) ) )

		If CLng( strInput ) > intMaxWidth Then

```
			strInput = CStr( intMaxWidth )
```

			document.getElementById( "NewWidth" ).value = intMaxWidth

```
		End If
```

		' New dimensions must be within boundaries, and if scale equals 1 and input video is MP4 then nothing will be done

		document.GetElementById( "StartButton" ).disabled = ( ( CLng( strInput ) < intMinWidth ) Or ( CLng( strInput ) > intMaxWidth ) Or ( ( CLng( strInput ) = intMaxWidth ) And ( LCase( objFso.GetExtensionName( strVideoInputFile ) ) = "mp4" ) ) )

```
	End If
```

	document.getElementById( "NewWidth" ).value = strInput

```
	If strInput = "" Then
```

		document.getElementById( "NewHeight" ).value = ""

	ElseIf intCurrentWidth > 0 And intCurrentHeight > 0 Then

		document.getElementById( "NewHeight" ).value = CLng( strInput ) * intCurrentHeight / intCurrentWidth

```
	End If
```
```
End Sub
```
```
 
```
```
 
```
```
Sub window_onunload()
```
```
	On Error Resume Next
```
```
	Set wshShell = Nothing
```
```
	Set objFso   = Nothing
```
```
	On Error GoTo 0
```
```
End Sub
```