Xpounded AnaStereo

3d Image Scripting Stereo to Anaglyph

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.
Using nothing but script to manipulate images...

This example demonstrates 24-bit bmp formated image manipulation through script.

This is a working vbs script for image analysis, modification, and creation. As far as I know, it is the first publically available script of its kind.

I have looked long, far, deep, and wide for any such simmilar script including commercial and non-commercial web searchs, library searchs, and university searchs. (I have exhausted all available scripting, programming and image resources including but not limited to, photogrammeteric, stereographic, anaglyphic and their relations such as lenticular, popup, and into the picture resources) I was unable to locate even one stand-alone script that only required an image to operate on. --- Well, because I was unable to unearth such a script, I have made one ---- And here it is. (I wouldn't have made this if pre-made script existed).

The example use I give here is creating an anaglyphic image from a stereograph. (you can find stereographs on the web, or you can make your own by hand, or with a LOREO 123 or LOREO MKII)

What this script does and how to use it...

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 2 new images from the dropped image. (a right and left view)
Then, it will create 2 more new images from the new images previously created. (a red and cyan filter)
Last, it will combine the filter images into an anaglyph.
At each step, the script will save the imtermediate image in the folder named after the originating image.
Hope this is clearer than mud.

You can do a lot more with images through script - grey scale, Sobel edging, etc One point to remember - it is script - it's not so fast. A 512x218, 344kb image can take several seconds to complete.

One nice advantage - you can drop the image and walk away, letting the script do the work. Another advantage is no imaging software is required to do the operations - just script and the OS.

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 AnaStereo.vbs

Select All

'
' AnaStereo.vbs
'
'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.
'
'You can reach me @sbcglobal.net as rdspoons
'
'Using nothing but script to manipulate images...
'
'This example demonstrates 24-bit bmp formated image manipulation through script.
'
'This is a working vbs script for image analysis, modification, and creation.
'As far as I know, it is the first publically available script of its kind.
'
'I have looked long, far, deep, and wide for any such simmilar script 
'including commercial and non-commercial web searchs, library searchs, and university searchs. 
'(I have exhausted all available scripting, programming and image resources including but not limited to, 
'
' photogrammeteric, stereographic, anaglyphic and their relations such as lenticular, popup, and into the picture resources) 
'I was unable to locate even one stand-alone script that only required an image to operate on.
' --- Well, because I was unable to unearth such a script, I have made one ---- 
'And here it is. (I wouldn't have made this if pre-made script existed). 
'
'The example use I give here is creating an anaglyphic image from a stereograph. 
'(you can find stereographs on the web, or you can make your own by hand, or with a LOREO 123 or LOREO MKII)
'
'What this script does and how to use it...
'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 2 new images from the dropped image. (a right and left view)
'Then, it will create 2 more new images from the new images previously created. (a red and cyan filter)
'Last, it will combine the filter images into an anaglyph.
'At each step, the script will save the imtermediate image in the folder named after the originating image.
'Hope this is clearer than mud.
'
'You can do a lot more with images through script - grey scale, Sobel edging, etc
'One point to remember - it is script - it's not so fast. A 512x218, 344kb image can take several seconds to
'complete.
'
'One nice advantage - you can drop the image and walk away, letting the script do the work.
'Another advantage is no imaging software is required to do the operations - just script and the OS.
'
'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)
'
'The Code...
'(This script works ONLY with 24-bit BMP format files PERIOD)
'(This script is designed for Left-Right Standard Stereographs - cross-eyed viewing)
'******************************************************************************
' 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)
'************************************************************

'******************************************************************************
' 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)
		'msgbox "Image:" & vbcrlf & nx & vbcrlf & "Size: " & ubound(t) & " BYTES" & vbcrlf & "WIDTH:" & cstr(getByteVal(t,19,4)) & vbcrlf & "HEIGHT: " & cstr(getByteVal(t,23,4))
		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

'*********************************************
		' Start Anaglyph From Stereo
		'
		HalfLeft qwl, t			'Make a new image from left half of a stero image
		n=newSaveFile
		saveFileFromArray n, qwl, "HL"

cyanChannel qar1, qwl		'Run a Cyan Filter on the new image
		n=newSaveFile
		saveFileFromArray n, qar1, "RC"

HalfRight qwr, t		'Make a new image from right half of a stero image
		n=newSaveFile
		saveFileFromArray n, qwr, "HR"

redChannel qal1, qwr		'Run a Red Filter on the new image
		n=newSaveFile
		saveFileFromArray n, qal1, "CC"

PaintOr qw, qar1, qal1		'Combine the two new images for an anaglyph
		n=newSaveFile
		saveFileFromArray n, qw, "Por"
		'
		' End Anaglyph From Stereo
		'*********************************************

Set fso = Nothing

m = "Done" & vbcrlf
	'end if
End If
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
Feedback