Xpounded Thumbnails Maker

Image Scripting: Creating thumbnails of images in a folder (image reduction)

Using nothing but script to manipulate images...

This script shows how to make a 100 x 100 thumbnail of all bmp images in a folder.

USE:

You use the script by dragging and dropping folder that holds 24-bit non-compressed bmp files onto it. To repeat, drag and drop a folder on the script.

The script will examine its own parent folder looking for a subfolder with the name Thumbs If it can not find such a folder, it will create one.
The script will itterate through all the files in the dropprd folder looking for files with a bmp extension.
With each bmp file it locates, the script will do a simple analysis on the dropped image file.
The script will start manipulating the data contained in the current image file.
It will create a new thumbnail image from the image.

The Code used in the reduction process is the same as the Thumb Maker Code. See the Thumb Maker page for why the thumbnails look as they do.

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)

Multiple Thumb Maker Sorce Code:

Save this file to your system as ThumbsMaker.vbs

Select All

'******************************************************************************
'Thumbs Maker
'Applies Thumb Maker Code to files in a folder
'Processor intensive - if you get impatient you can use the taskmanager to kill the wscript process. 
'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"
'.............................................................
Sub ForAllFiles(path,func)
	Dim folder, f, sRet
	Set folder = fso.GetFolder(path)
	For Each f In folder.Files
		s = func & " f"
		execute s
	Next
End Sub
'.............................................................
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 getExtension(sPath)
	Dim g1,pPath
	pPath = sPath
	g1 = InStrRev(sPath,".")
	If g1 > 0 Then
		pPath = Right(pPath,Len(pPath)-g1)
	Else
		pPath = ""
	End If
	getExtension = pPath
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

W = getByteVal(vs1, 19,4)	
	H = getByteVal(vs1, 23,4)
	scanline = scanlineFromWidth(W)
	diff = scanline - W*3

'All thumbs will be 100 x 100
	newWidth = 100
	newHeight = 100
	
	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
'************************************************************
Sub MakeThumbs(f)
	nx = f
	n = nx
	if getExtension(f) <> "bmp" then exit sub
	gn = getName(n)
	n = nx
	gp = getPath(n)
	newpth = gp & "\Thumbs"
	if Not folderExists(newpth) then
		makeFolder newpth
	end if
	n = nx
	newSaveFile = newpth & "\" & getFile(n)
	t = readFileIntoArray(nx)
	WshShell.popup "Calculating Thumb for" & vbcrlf & f, 2
	makeThumb qw, t
	n=newSaveFile
	saveFileFromArray n, qw, "th"
	glb_count = glb_count + 1
End Sub
'.............................................................
'-------------------------------------------------------------
' YOUR CODE GOES HERE
Dim glb_count
u = g_args.Count
dim qw()
If u > 0  Then
	WshShell.popup "Thumb Maker.",2
	'*********************************************
	ForAllFiles g_args(0),"MakeThumbs"
	'*********************************************
	m = "Created " & glb_count & " Thumbs" & vbcrlf & "Done" & vbcrlf
End If
WshShell.popup m
'************************************************************

Xpounded Thumbnails Maker

Image Scripting: Creating thumbnails of images in a folder (image reduction)

USE:

Multiple Thumb Maker Sorce Code:

Save this file to your system as ThumbsMaker.vbs

Code Samples:

Services:

Sites: