Xpounded Simple Image Processing

Image Scripting: Area Processing

This code is copyright Robert Spoons 2006 Want to use it - great, give credit. Want to expand upon it - great, give credit. Want to talk about it - great, give credit. Not really asking for much- great, give credit. Thanks.
Processing Simple Image Filers

This script provides 14 convolution filters plus several point processing functions.

USE:

You use the script by dragging and dropping a 24-bit bmp file onto it.
First the script will examine its own parent folder looking for a subfolder with the same name as the dropped file. If it can not find such a folder, it will create one.
Second, the script will do a simple analysis on the dropped image file and report its size, width, and height.
Third, the script will start manipulating the data contained in the dropped image.
It will create 11 new images from the dropped image, each derived from a different area filter.
At all 11 production steps the script will save the filtered image in the folder named after the originating image.

Types of Area Processes (filters) Prodvided:
Blur

Blur More

Sharpen

Sharpen More

Edge Enhance (Horizontal)

Edge Enhance (Verticle)

Edge Enhance (Diagonal)

EdgeDetect (1)

EdgeDetect (2)

EdgeDetect (3)

Embos

EdgeDetect Sobell

EdgeDetect Prewit

EdgeDetect Kirsh

Types of Point Processes (filters) Prodvided:
redChannel

cyanChannel

Paint OR

GrayScale

Invert

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

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

Save this file to your system as ImageProc.vbs

Select All

'This code is copyright Robert Spoons 2006
'Want to use it - great, give credit.
'Want to expand upon it - great, give credit.
'Want to talk about it - great, give credit.
'Not really asking for much- great, give credit.
'Thanks.
'
'******************************************************************************
' Specialized Methods Overhead
' Starts Here .....
'
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
'................................................................................
Sub 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
End Sub
'
' ... Ends Here
' Specialized Methods Overhead
'**************************************************************

'******************************************************************************
' General Methods Overhead
' Starts Here .....
'
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
'
' ... Ends Here
' General Methods Overhead
'**************************************************************

'******************************************************************************
' Image Tinkering (24-Bit bmp ONLY please)
' Starts Here...
'
Sub redChannel(arr,vs)			'Red Filter
	dim W,H,scanline,diff
	W = getByteVal(vs, 19,4)	'Each picture is 1/2 of current image
	H = getByteVal(vs, 23,4)
	scanline = scanlineFromWidth(W)		'length of row of data in original image
	diff = scanline - W*3	'length of data needed to pad row

redim arr(54+scanline*H) 'head + width * height
	for i= 0 to 54
		arr(i) = vs(i)
	next
	newIndex = 1
	stPoint = 54	+ half*3	
	for j = 1 to H
		for i= 1 to w * 3 step 3  
			b = 0
			g = 0 
			r = asc(vs(stPoint + i + 2))
			gy = cint((b+g+r)/3)
			arr(54+newIndex) =   chr(b)
			arr(54+newIndex+1) =   chr(g)
			arr(54+newIndex+2) =   chr(r)
			newIndex = newIndex + 3
		next
		for i=1 to diff				'scanline padding required to get to 4 byte boundary
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
		stPoint = stPoint + scanline
	next
End Sub
'................................................................................
Sub cyanChannel(arr,vs)			'Cyan Filter
	dim W,H,scanline,diff
	W = getByteVal(vs, 19,4)	'Each picture is 1/2 of current image
	H = getByteVal(vs, 23,4)
	scanline = scanlineFromWidth(W)		'length of row of data in original image
	diff = scanline - W*3	'length of data needed to pad row

redim arr(54+scanline*H) 'head + width * height
	for i= 0 to 54
		arr(i) = vs(i)
	next
	newIndex = 1
	stPoint = 54	+ half*3	
	for j = 1 to H
		for i= 1 to w * 3 step 3  
			b = asc(vs(stPoint + i)) 
			g = asc(vs(stPoint + i + 1)) 
			r = 0
			arr(54+newIndex) =   chr(b)
			arr(54+newIndex+1) =   chr(g)
			arr(54+newIndex+2) =   chr(r)
			newIndex = newIndex + 3
		next
		for i=1 to diff				'scanline padding required to get to 4 byte boundary
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
		stPoint = stPoint + scanline
	next
End Sub
'................................................................................
Sub PaintOr(arr,vs1,vs2)		'Combining Images
	if (getByteVal(vs1,19,4) <> getByteVal(vs2,19,4)) Or (getByteVal(vs1,23,4) <> getByteVal(vs2,23,4)) Then
		msgbox "Picture Dimensions Do Not Match"
		Exit Sub
	End If
	redim arr(ubound(vs1))
	for i= 0 to 54
		arr(i) = vs1(i)
	next
	for i= 55 to ubound(vs1)  - 3 step 3
		b = asc(vs1(i)) Or  asc(vs2(i))
		g = asc(vs1(i+1)) Or  asc(vs2(i+1))
		r = asc(vs1(i+2)) Or  asc(vs2(i+2))
		arr(i) =   chr(b)
		arr(i+1) =   chr(g)
		arr(i+2) =   chr(r)
	next
End Sub
'................................................................................
Sub HalfLeft(arr,vs)			'Copy Image Part
	dim W, H, half,h1,newIndex,stPoint,scanline,newscanline
	W = getByteVal(vs, 19,4)	'Each picture is 1/2 of current image
	H = getByteVal(vs, 23,4)

half = cint(W/2)	'Each picture width is 1/2 width of current image
	h1 = half		'Used to set new image dimension properties

scanline = scanlineFromWidth(w)		'length of row of data in original image
	newscanline = scanlineFromWidth(half)	'length of row of data in new image
	diff = newscanline - half*3	'length of data needed to pad row

redim arr(54+newscanline*H) 'head + width * height

bp4 = 256^3	'16777216 Why not use a few more cycles
	bp3 = 256^2	'65536 
	bp2 = 256 	'256
	k4 = 0
	if h1=>bp4 then
		k4 = cint(h1/bp4)
		h1 = h1 - k4*bp4
	end if
	k3 = 0
	if h1=>bp3 then
		k3 = cint(h1/bp3)
		h1 = h1 - k3*bp3
	end if
	k2 = 0
	if h1=>bp2 then
		k2 = cint(h1/bp2)
		h1 = h1 - k2*bp2
	end if
	k1 = h1

for i= 0 to 54		'copy bmp header info (most of info will be duplicate anyeay)
		arr(i) = vs(i)
	next
	arr(19) = chr(k1)	'Adjust image width in header (19,20,21,22) Only modifcation needed for header
	arr(20) = chr(k2)
	arr(21) = chr(k3)
	arr(22) = chr(k4)

newIndex = 1		'used to index new image
	stPoint = 54		' last byte of header (24 bit bitmap image)
	for j = 1 to H
		for i= 1 to half * 3 step 3  		'1/2 of each old image scanline is new image scanline
			b = asc(vs(stPoint + i)) 
			g = asc(vs(stPoint + i + 1))
			r = asc(vs(stPoint + i + 2))
			arr(54+newIndex) =   chr(b)
			arr(54+newIndex+1) =   chr(g)
			arr(54+newIndex+2) =   chr(r)
			newIndex = newIndex + 3
		next
		for i=1 to diff				'scanline padding required to get to 4 byte boundary
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
		stPoint = stPoint + scanline
	next
End Sub
'................................................................................
Sub HalfRight(arr,vs)			'Copy Image Part
	dim W, H, half,h1,newIndex,stPoint,scanline,newscanline
	W = getByteVal(vs, 19,4)	'Each picture is 1/2 of current image
	H = getByteVal(vs, 23,4)

half = cint(W/2)	'Each picture width is 1/2 width of current image
	h1 = half		'Used to set new image dimension properties

redim arr(54+newscanline*H) 'head + width * height

newIndex = 1		'used to index new image
	stPoint = 54	+ half*3	
	for j = 1 to H
		for i= 1 to half * 3 step 3  		'1/2 of each old image scanline is new image scanline
			b = asc(vs(stPoint + i)) 
			g = asc(vs(stPoint + i + 1))
			r = asc(vs(stPoint + i + 2))
			arr(54+newIndex) =   chr(b)
			arr(54+newIndex+1) =   chr(g)
			arr(54+newIndex+2) =   chr(r)
			newIndex = newIndex + 3
		next
		for i=1 to diff				'scanline padding required to get to 4 byte boundary
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
		stPoint = stPoint + scanline
	next
End Sub
'
' ... Ends Here
' Image Tinkering (24-Bit bmp ONLY please)
'************************************************************

'******************************************************************************
' Image Overhead (24-Bit bmp ONLY please)
' Starts Here...
'
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
'
' ... Ends Here
' Image Overhead (24-Bit bmp ONLY please)
'************************************************************
'******************************************************************************
' Clamp Value
' Starts Here...
'
'................................................................................
function Clamp(val,lowBound,highBound)
	dim ret
	ret = val
	if ret < lowBound Then ret = lowBound
	if ret > highBound Then ret = highBound
	Clamp = ret
End Function
'
' ... Ends Here
' Clamp Value
'************************************************************
'******************************************************************************
' Vector and Matrix Multiplication (and vector addition)
' Starts Here...
'
Function VecMat(v1,m1)
	'new array dimensions are 1 x ubound(m1,2)
	dim ret
	dim nm()
	ret = "Error"
	VecCols = ubound(v1)
	MatRows = ubound(m1,1)
	MatCols = ubound(m1,2)
	if VecCols = MatRows then
		redim nm(MatCols)
		for j = 0 to MatCols -1
			for k = 0 to MatRows -1
				nm(j) = nm(j) + v1(k)*m1(k,j)
			next
		next
		ret = nm
	end if
	VecMat = ret
End Function
'................................................................................
Function MatVec(m1,v1)
	'new array dimensions are 1 x ubound(v1)
	dim ret
	dim nm()
	ret = "Error"
	VecCols = ubound(v1)
	MatRows = ubound(m1,1)
	MatCols = ubound(m1,2)
	if MatCols = VecCols then
		redim nm(MatCols)
		for j = 0 to MatCols -1
			for k = 0 to MatRows -1
				nm(j) = nm(j) + m1(j,k)*v1(k)
			next
		next
		ret = nm
	end if
	MatVec = ret
End Function
'................................................................................
Function AddVec(v1,v2)
	'new array dimensions are 1 x ubound(v1)
	dim ret
	dim nm()
	ret = "Error"
	VecCols1 = ubound(v1)
	VecCols2 = ubound(v2)
	if VecCols1 = VecCols2 then
		redim nm(VecCols1)
		for i = 0 to VecCols1 -1
			nm(i) = v1(i) + v2(i)
		next
		ret = nm
	end if
	AddVec = ret
End Function
'
' ... Ends Here
' Vector and Matrix Multiplication (and vector addition)
'************************************************************

'******************************************************************************
' Area Processing
' Starts Here...
'
Dim kernel,divisor,offset
'................................................................................
Sub Sharpen(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= -1
	kernel(0,1)= -1
	kernel(0,2)= -1
	kernel(1,0)= -1
	kernel(1,1)= 9
	kernel(1,2)= -1
	kernel(2,0)= -1
	kernel(2,1)= -1
	kernel(2,2)= -1
	divisor = 1
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub SharpenMore(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= 0
	kernel(0,1)= -1
	kernel(0,2)= 0
	kernel(1,0)= -1
	kernel(1,1)= 5
	kernel(1,2)= -1
	kernel(2,0)= 0
	kernel(2,1)= -1
	kernel(2,2)= 0
	divisor = 1
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub Blur(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= 1
	kernel(0,1)= 1
	kernel(0,2)= 1
	kernel(1,0)= 1
	kernel(1,1)= 1
	kernel(1,2)= 1
	kernel(2,0)= 1
	kernel(2,1)= 1
	kernel(2,2)= 1
	divisor = 9
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub BlurMore(arr,vs)
	kernel(0,0)= 1
	kernel(0,1)= 2
	kernel(0,2)= 1
	kernel(1,0)= 2
	kernel(1,1)= 4
	kernel(1,2)= 2
	kernel(2,0)= 1
	kernel(2,1)= 2
	kernel(2,2)= 1
	divisor = 16
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub EdgeEnhanceLeftRight(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= 0
	kernel(0,1)= 0
	kernel(0,2)= 0
	kernel(1,0)= -1
	kernel(1,1)= 1
	kernel(1,2)= 0
	kernel(2,0)= 0
	kernel(2,1)= 0
	kernel(2,2)= 0
	divisor = 1
	offset = 127
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub EdgeEnhanceUpDown(arr,vs)
	kernel(0,0)= 0
	kernel(0,1)= -1
	kernel(0,2)= 0
	kernel(1,0)= 0
	kernel(1,1)= 1
	kernel(1,2)= 0
	kernel(2,0)= 0
	kernel(2,1)= 0
	kernel(2,2)= 0
	divisor = 1
	offset = 127
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub EdgeEnhanceDiag(arr,vs)
	kernel(0,0)= -1
	kernel(0,1)= 0
	kernel(0,2)= 0
	kernel(1,0)= 0
	kernel(1,1)= 1
	kernel(1,2)= 0
	kernel(2,0)= 0
	kernel(2,1)= 0
	kernel(2,2)= 0
	divisor = 1
	offset = 127
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub EdgeDetect1(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= 0
	kernel(0,1)= 1
	kernel(0,2)= 0
	kernel(1,0)= 1
	kernel(1,1)= -4
	kernel(1,2)= 1
	kernel(2,0)= 0
	kernel(2,1)= 1
	kernel(2,2)= 0
	divisor = 1
	offset = 127
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub EdgeDetect2(arr,vs)
	kernel(0,0)= -1
	kernel(0,1)= -1
	kernel(0,2)= -1
	kernel(1,0)= -1
	kernel(1,1)= 8
	kernel(1,2)= -1
	kernel(2,0)= -1
	kernel(2,1)= -1
	kernel(2,2)= -1
	divisor = 1
	offset = 127
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
 Sub EdgeDetect3(arr,vs)
	kernel(0,0)= 1
	kernel(0,1)= -2
	kernel(0,2)= 1
	kernel(1,0)= -2
	kernel(1,1)= 4
	kernel(1,2)= -2
	kernel(2,0)= 1
	kernel(2,1)= -2
	kernel(2,2)= 1
	divisor = 1
	offset = 127
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub Embos(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= -2
	kernel(0,1)= -1
	kernel(0,2)= 0
	kernel(1,0)= -1
	kernel(1,1)= 1
	kernel(1,2)= 1
	kernel(2,0)= 0
	kernel(2,1)= 1
	kernel(2,2)= 2
	divisor = 1
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub Sobell(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= 1
	kernel(0,1)= 2
	kernel(0,2)= 1
	kernel(1,0)= 0
	kernel(1,1)= 0
	kernel(1,2)= 0
	kernel(2,0)= -1
	kernel(2,1)= -2
	kernel(2,2)= -1
	divisor = 1
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub Prewit(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= 1
	kernel(0,1)= 1
	kernel(0,2)= 1
	kernel(1,0)= 0
	kernel(1,1)= 0
	kernel(1,2)= 0
	kernel(2,0)= -1
	kernel(2,1)= -1
	kernel(2,2)= -1
	divisor = 1
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub Kirsh(arr,vs)
	Redim kernel(3,3)
	kernel(0,0)= 5
	kernel(0,1)= 5
	kernel(0,2)= 5
	kernel(1,0)= -3
	kernel(1,1)= -3
	kernel(1,2)= -3
	kernel(2,0)= -3
	kernel(2,1)= -3
	kernel(2,2)= -3
	divisor = 1
	offset = 0
	ApplyFilter arr,vs,divisor,offset
End Sub
'................................................................................
Sub ApplyFilter(arr,vs,iDivisor,iOffset)
	dim W,H,scanline,diff
	W = getByteVal(vs, 19,4)
	H = getByteVal(vs, 23,4)
	scanline = scanlineFromWidth(W)	
	diff = scanline - W*3	'length of data needed to pad row

redim arr(ubound(vs))
	for i= 0 to 54
		arr(i) = vs(i)
	next
	newIndex = 1
	stPoint = 54
	for j = 1 to H
		for i= 1 to w * 3 step 3

if (j>(H-4)) then
				b = asc(vs(stPoint + i)) 
				g = asc(vs(stPoint + i + 1)) 
				r = asc(vs(stPoint + i + 2)) 
			else	
				b = asc(vs(stPoint + i)) * kernel(0,0)
				b = b + asc(vs(stPoint + i + 3)) * kernel(0,1)
				b = b + asc(vs(stPoint + i + 6)) * kernel(0,2)
				b = b + asc(vs(stPoint + scanline + i)) * kernel(1,0)
				b = b + asc(vs(stPoint + scanline + i + 3)) * kernel(1,1)
				b = b + asc(vs(stPoint + scanline + i + 6)) * kernel(1,2)
				b = b + asc(vs(stPoint + 2*scanline + i)) * kernel(2,0)
				b = b + asc(vs(stPoint + 2*scanline + i + 3)) * kernel(2,1)
				b = b + asc(vs(stPoint + 2*scanline + i + 6)) * kernel(2,2)
				b = CInt(b/iDivisor + iOffset)

g = asc(vs(stPoint + i + 1)) * kernel(0,0)
				g = g + asc(vs(stPoint + i + 3 + 1)) * kernel(0,1)
				g = g + asc(vs(stPoint + i + 6 + 1)) * kernel(0,2)
				g = g + asc(vs(stPoint + scanline + i + 1)) * kernel(1,0)
				g = g + asc(vs(stPoint + scanline + i + 3 + 1)) * kernel(1,1)
				g = g + asc(vs(stPoint + scanline + i + 6 + 1)) * kernel(1,2)
				g = g + asc(vs(stPoint + 2*scanline + i + 1)) * kernel(2,0)
				g = g + asc(vs(stPoint + 2*scanline + i + 3 + 1)) * kernel(2,1)
				g = g + asc(vs(stPoint + 2*scanline + i + 6 + 1)) * kernel(2,2)
				g = CInt(g/iDivisor + iOffset)

r = asc(vs(stPoint + i + 2)) * kernel(0,0)
				r = r + asc(vs(stPoint + i + 3 + 2)) * kernel(0,1)
				r = r + asc(vs(stPoint + i + 6 + 2)) * kernel(0,2)
				r = r + asc(vs(stPoint + scanline + i + 2)) * kernel(1,0)
				r = r + asc(vs(stPoint + scanline + i + 3 + 2)) * kernel(1,1)
				r = r + asc(vs(stPoint + scanline + i + 6 + 2)) * kernel(1,2)
				r = r + asc(vs(stPoint + 2*scanline + i + 2)) * kernel(2,0)
				r = r + asc(vs(stPoint + 2*scanline + i + 3 + 2)) * kernel(2,1)
				r = r + asc(vs(stPoint + 2*scanline + i + 6 + 2)) * kernel(2,2)
				r = CInt(r/iDivisor + iOffset)
			end if
			arr(54+newIndex) =   chr(clamp(b,0,255))
			arr(54+newIndex+1) =   chr(clamp(g,0,255))
			arr(54+newIndex+2) =   chr(clamp(r,0,255))
			newIndex = newIndex + 3
		next
		for i=1 to diff
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
		stPoint = stPoint + scanline
	next
End Sub
'
' ... Ends Here
' Area Processing
'************************************************************

'******************************************************************************
' Point Processing
' Starts Here...
'
Sub Invert(arr,vs)			'Invert Filter
	dim W,H,scanline,diff
	W = getByteVal(vs, 19,4)
	H = getByteVal(vs, 23,4)
	scanline = scanlineFromWidth(W)	
	diff = scanline - W*3

redim arr(ubound(vs)) 
	for i= 0 to 54
		arr(i) = vs(i)
	next
	newIndex = 1
	stPoint = 54
	for j = 1 to H
		for i= 1 to w * 3 step 3  
			b = 255 - asc(vs(stPoint + i ))
			g = 255 - asc(vs(stPoint + i + 1)) 
			r = 255 - asc(vs(stPoint + i + 2))
			arr(54+newIndex) =   chr(b)
			arr(54+newIndex+1) =   chr(g)
			arr(54+newIndex+2) =   chr(r)
			newIndex = newIndex + 3
		next
		for i=1 to diff	
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
		stPoint = stPoint + scanline
	next
End Sub
'................................................................................
Sub GrayScale(arr,vs)			'Invert Filter
	dim W,H,scanline,diff,gy
	W = getByteVal(vs, 19,4)
	H = getByteVal(vs, 23,4)
	scanline = scanlineFromWidth(W)	
	diff = scanline - W*3

redim arr(ubound(vs)) 
	for i= 0 to 54
		arr(i) = vs(i)
	next
	newIndex = 1
	stPoint = 54
	for j = 1 to H
		for i= 1 to w * 3 step 3  
			gy = asc(vs(stPoint + i ))
			gy = gy + asc(vs(stPoint + i + 1)) 
			gy = gy + asc(vs(stPoint + i + 2))
			gy = CInt(gy/3)
			arr(54+newIndex) =   chr(gy)
			arr(54+newIndex+1) =   chr(gy)
			arr(54+newIndex+2) =   chr(gy)
			newIndex = newIndex + 3
		next
		for i=1 to diff	
			arr(54+newIndex) =   chr(0)
			newIndex = newIndex + 1
		next
		stPoint = stPoint + scanline
	next
End Sub
'
' ... Ends Here
' Point Processing
'************************************************************

'******************************************************************************
' Program Anaglyph From Stereo Image
' Starts Here...
'
set WshShell = WScript.CreateObject("WScript.Shell")
desktop = WshShell.SpecialFolders("Desktop")

Dim fso,m
m="Problems. Now Closing"
Set a = WScript.Arguments
u = a.Count
dim qw()
If u > 0  Then
	WshShell.popup "Anaglyph From Stereo.",2
		Set fso = createObject("Scripting.FileSystemObject")
		nx = a(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

'*********************************************
		Embos qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_emboss"
		WshShell.popup "Embos is ready", 2

Sharpen qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_sharp"
		WshShell.popup "Sharpen is ready", 2

SharpenMore qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_sharpMore"
		WshShell.popup "Sharpen2 is ready", 2

Blur qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_blur"
		WshShell.popup "Blur is ready", 2

BlurMore qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_blurMore"
		WshShell.popup "BlurMore is ready", 2

EdgeEnhanceLeftRight qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_ee_lr"
		WshShell.popup "EdgeEnhance Left Right is ready", 2

EdgeEnhanceUpDown qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_ee_ud"
		WshShell.popup "EdgeEnhance Up Down is ready", 2

EdgeEnhanceDiag qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_ee_diag"
		WshShell.popup "EdgeEnhance Diag is ready", 2

EdgeDetect1 qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_ed1"
		WshShell.popup "EdgeDetect1 is ready", 2

EdgeDetect2 qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_ed2"
		WshShell.popup "EdgeDetect2 is ready", 2

EdgeDetect3 qw, t
		n=newSaveFile
		saveFileFromArray n, qw, "_ed3"
		WshShell.popup "EdgeDetect3 is ready", 2
		'*********************************************

Set fso = Nothing

m = "Done" & vbcrlf
	'end if
End If
WshShell.popup m
Set WshShell = Nothing
Set a = Nothing
'
' ... Ends Here
' Program Anaglyph From Stereo Image
'************************************************************
'msgbox 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