Xpounded Thumbnail Maker

with Constant Aspect Ration

This code is copyright Robert Spoons 2006 (give credit - Thanks)
Same as previous thumbnail generator, but adjusted for contant aspect ratio

This script shows how to make a 100 x n, or a m x 100 thumbnail of an image depending on the dominate dimension.

USE:

You use the script by dragging and dropping a 24-bit non-compressed bmp file onto it.
Works the same as other image manipulation scripts on this site.

It works well enough for script - the thumbnail will have the aspect ratio of the original image.

Requirements: Windows 98+, WSH 5.6+ (VBS), Image File in 24-bit non-compressed BMP format.

Tested on XP Home edition SP2, IE6 installed. (Not tested with IE7 installed)

Save this file to your system as ThumbMakerAspect.vbs

Select All

'******************************************************************************
'Thumb Maker with constant Aspect Ratio
'Only works on 24 bit bmp's with no compression
'
'Requires Windows, WSH 5.6+
'
Dim g_args, WshShell, fso, g_msg
set WshShell = WScript.CreateObject("WScript.Shell")
desktop = WshShell.SpecialFolders("Desktop")
Set g_args = WScript.Arguments
Set fso = createObject("Scripting.FileSystemObject")
g_msg = "Problems. Now Closing"
'.............................................................
Function getArgs()
	Set a = WScript.Arguments
	gatArgs = a
	Set a = Nothing
End Function
'................................................................................
Function folderExists(sFolderPath)
	Dim bReturn
	bReturn =  fso.FolderExists(sFolderPath)
	folderExists = bReturn
End Function
'................................................................................
Function makeFolder(sPath)
	Dim objFolder
	Set objFolder = fSO.CreateFolder(sPath)
	makeFolder = objFolder
End Function
'................................................................................
Function getName(sPath)
	Dim g1, g2
	g1 = InStrRev(sPath,"\")
	If g1 > 0 Then
		sPath = Right(sPath,Len(sPath)-g1)
	End IF
	g2 = InStr(sPath,".")
	If g2 > 0 Then
		sPath = Left(sPath,g2-1)
	End If
	getName = sPath
End Function
'................................................................................
Function getFile(sPath)
	Dim g1
	g1 = InStrRev(sPath,"\")
	If g1 > 0 Then
		sPath = Right(sPath,Len(sPath)-g1)
	End IF
	getFile = sPath
End Function
'................................................................................
Function getPath(sPath)
	Dim g1
	g1 = InStrRev(sPath,"\")
	If g1 > 0 Then
		sPath = Left(sPath,g1)
	End If
	If Right(sPath,1) = "\" Then
		sPath = Left(sPath,Len(sPath)-1)
	End If
	getPath = sPath
End Function
'.............................................................
function getByteVal(ar, startByte,numBtyes)
	dim ret
	ret = 0
	d= 1
	for i = startByte to startByte + numBtyes - 1
		ret = ret + d * cint(asc(ar(i)))
		d = d*256
	next
	getByteVal = ret
end function
'................................................................................
Function readFileIntoArray(path)
	Dim f,r(),counter1
	counter1=0
	Set f = fso.OpenTextFile(path, 1)
	Do until f.atendofstream
		counter1=counter1+1
		redim preserve r(counter1+1)
		r(counter1)=f.read(1)
	Loop	
	readFileIntoArray=r
	f.Close 
	Set f = Nothing
End Function
'................................................................................
Function saveFileFromArray(tname,r,newStuff)
	Dim result,s,gpos
	gpos=InstrRev(tname,".")
	tname = left(tname,gpos-1) & "_" & newStuff & right(tname,len(tname)-gpos+1)
	Set result = fso.createTextFile(tname,True)
	for i=0 to ubound(r)
		result.Write r(i)
	next
	result.Close
	Set result = Nothing
	saveFileFromArray = tname
End Function
'.............................................................
Function scanlineFromImage(vs)
	dim W, H,lscanline
	W = getByteVal(vs, 19,4)	'Each picture is 1/2 of current image
	lscanline = w*3		'length of row of data in original image
	for i=0 to 3
		if ((lscanline+i) mod 4 = 0) then
			lscanline=lscanline+i
			exit for
		end if
	next
	scanlineFromImage = lscanline
End Function
'................................................................................
Function scanlineFromWidth(widthval)
	dim lscanline
	lscanline = widthval*3		'length of row of data in original image
	for i=0 to 3
		if ((lscanline+i) mod 4 = 0) then
			lscanline=lscanline+i
			exit for
		end if
	next
	scanlineFromWidth = lscanline
End Function
'.............................................................
Sub Set4ByteNumber(startByte,arr1,val)
	Dim h1,h2,h3,h4
	h1 = cInt(val/16777216)
	h2 = cInt((val - h1*16777216)/65536)
	h3 = cInt((val - h1*16777216 - h2*65536)/256)
	h4 = val - h1*16777216 - h2*65536 - h3*256
	
	arr1(startByte) = chr(h4)
	arr1(startByte+1) = chr(h3)
	arr1(startByte+2) = chr(h2)
	arr1(startByte+3) = chr(h1)
	'msgbox h4 & vbcrlf & h3 & vbcrlf & h2 & vbcrlf & h1
End Sub
'******************************************************************************
Sub makeThumb(arr,vs1)
	Dim j, i
	Dim x1, x2, y1, y2, X, Y, r, g, b, num_pixels
	dim W, H, scanline, diff, newIndex, stPoint
	dim newHeight, newWidth, newScanline, newDiff, newFilsize
	dim pxl, x_scale, y_scale

WshShell.popup "Calculating Thumb", 2

W = getByteVal(vs1, 19,4)	
	H = getByteVal(vs1, 23,4)

scanline = scanlineFromWidth(W)
	diff = scanline - W*3

'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
	'The only change from Thumbmaker.vbs is here vvvvvvvv
	'(very easy to keep aspect ratio of image)
	if W > H then
		newWidth = 100
		newHeight = Int(H*newWidth/W)
	else
		newHeight = 100
		newWidth = Int(W*newHeight/H)
	end if
	WshShell.popup "Old Width: " & W & vbcrlf & "New Width: " & newWidth & vbcrlf & vbcrlf & "Old Height: " & H & vbcrlf & "New Height: " & newHeight, 2
	'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

newScanline = scanlineFromWidth(newWidth)
	newDiff = newScanline - newWidth*3
	newFilsize = 54 + newScanline * (newWidth)

redim arr(54 + newScanline*(newHeight))

for i= 0 to 54								'copy header
		arr(i) = vs1(i)
	next
	Set4ByteNumber 3, arr, newFilsize					'adjust file Size
	Set4ByteNumber 19, arr, newWidth					'adjust Width
	Set4ByteNumber 23, arr, newHeight					'adjust Height
	
    	x_scale = W / newWidth							'used to locate pixels while sampling
    	y_scale = H / newHeight

newIndex = 1								'used to set pixels in new image
	For j = 0 To newHeight - 1
		For i = 0 To newWidth - 1
           		x1 = int(i * x_scale)					'get sample pixel location
            		x2 = Int(i * x_scale+1)
            		y1 = Int(j * y_scale)
            		y2 = Int(j * y_scale+1)
           		r = 0
            		g = 0
            		b = 0
			if x1<0 then x1=0					'ensure sample is in bounds
			if y1<0 then y1=0
			if x2>W-1 then x2 = w-1
			if y2>H-1 then y2 = h-1
			stPoint = 55			'make sure we're in data area (24-bit bmp with no compression)
			pxl = 0					'count of pixels used while averaging sampled pixels
			stPoint = stPoint + scanline * y1			'start on samples lowest scanline
			For Y = y1 To y2					'sample pixels and total
       				For X = x1 To x2 
					b = b + asc(vs1(stPoint + X*3))
                       			g = g + asc(vs1(stPoint + X*3 + 1))
                       			r = r + asc(vs1(stPoint + X*3 + 2))
					pxl = pxl + 1
               			Next
				stPoint = stPoint + scanline
       			Next
			num_pixels = pxl
			if num_pixels = 0 then					'ensure character is in bounds
				arr(54 + newIndex) = chr(255)
				arr(54 + newIndex + 1) = chr(255)
				arr(54 + newIndex + 2) = chr(255)
			else							'store averaged sample
				arr(54 + newIndex) = chr(int(b / num_pixels))
				arr(54 + newIndex + 1) = chr(int(g / num_pixels))
				arr(54 + newIndex + 2) = chr(int(r / num_pixels))
			end if
			newIndex = newIndex + 3
	       	Next
		for i=1 to newDiff
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
    	Next
End Sub
'************************************************************
'.............................................................
'-------------------------------------------------------------
' YOUR CODE GOES HERE
u = g_args.Count
dim qw()
If u > 0  Then
	WshShell.popup "Thumb Maker.",2
		nx = g_args(0)
		n = nx
		gn = getName(n)
		n = nx
		gp = getPath(n)
		newpth = gp & "\" & gn
		if Not folderExists(newpth) then
			makeFolder newpth
		end if
		n = nx
		newSaveFile = newpth & "\" & getFile(n)
		t = readFileIntoArray(nx)
		WshShell.popup "Image:" & vbcrlf & nx & vbcrlf & "Size: " & ubound(t) & " BYTES" & vbcrlf & "WIDTH:" & cstr(getByteVal(t,19,4)) & vbcrlf & "HEIGHT: " & cstr(getByteVal(t,23,4)), 2
		'*********************************************
		makeThumb qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "th"
		'*********************************************
		m = "Done" & vbcrlf
End If
WshShell.popup m
'************************************************************

No HTML to View

- Copyright 2006 Xpounded -
All JS code developed by Xpounded is developed in RHSCoder.
All VBS code developed by Xpounded is developed in VBS QuickDev IDE, or RHSCoder.
Privacy Statement