Xpounded Automate AnaStereo

3d Image Scripting Stereo to Anaglyph Automation

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.
This is the Book automation monitor script modified to automate AnaStereo

Even more fun with automation!

With this script you select a folder to watch and every file sent to that folder is given to the AnaStereo script as an argument.

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

You use the script by double clicking on it to start the monitoring process. Then, any stereo images (24-bit bmp) you drop into the folder will be fed to the AnaStereo script where it is processed.
First make a folder to monitor and modify the monitor script making sure the variable monitoredFolder is set its path
Second, modify the monitor script making sure the variable scriptApplication points to the AnaStereo script.
Third, double click the monitor script to run it.
It will wait for a file to dropped into the monitored folder (so make sure you only drop 24-bit stereo bmp's), and when a file is dropped the monitor script will automatically start the AnaStereo script with the dropped file as its argument.
The AnaStereo script will do its thing (see AnaStereo for details) and a new anaglyph will be created in a subfolder of the folder holding the AnaStereo script.
Last, the monitor will return resume monitoring the folder until you manually stop it.

Stop the monitor: Open the task manager (right-click on task bar, or ALT+CTRL+DEL) and End the Process for the wscript.exe process under your username

There is a modified AnaStereo script below called AutoAnaStereo.vbs that is setup for the monitor.
compare it to the normal AnaStereo.vbs to learn how to set up a script for automation.

One last point. You can comment out the popups in AutoAnaStereo.vbs to make it run sillent (best for autamtion).

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

Select All

'rdspoons sbcglobal.net
'Xpounded 2004-2006
'
'This is a true automation script. When run, it will run in the 
'background until its process is manually ended.
'
'This file monitors a folder watching for a new file to be created.
'It then actions the newly creted file with a specified 
'script/application 
'
'To use, you must set values for the vairables monitoredFolder and 
'scriptApplication at the end of this file, and then un-comment one 
'of the actions in the Action method.
' 
'The Monitor method was modified from a script freely avilable 
'from Microsoft.
'
'===================================================================
'===================================================================
'   The Monitor
'===================================================================
Sub startMontoringFileCreation(sFolder)
	Dim sComputer, sPath
	sPath = chr(34) & Replace(sFolder,"\","\\\\") & chr(34)
	If sPath = Null Then Exit Sub
	sComputer = "."
	Set oService = GetObject("winmgmts:" _
	& "{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2")
	Set oMonitorEvents = oService.ExecNotificationQuery _
	("SELECT * FROM __InstanceCreationEvent WITHIN 10 WHERE " _
	& "Targetinstance ISA 'CIM_DirectoryContainsFile' AND " _
	& "TargetInstance.GroupComponent= " _
	& "'Win32_Directory.Name=" & sPath & "'")
	Do
		Set oLastEvent = oMonitorEvents.NextEvent
		Action oLastEvent.TargetInstance.PartComponent	'Action for file created
	Loop
End Sub
'===================================================================
'===================================================================
'  The Action
'===================================================================
Sub Action(pc)
	Dim v
	'Run this script/application with the created file path as argument
	'Un-comment the following two lines to use an argument
	v=Split(pc,"=")
	runWithArg scriptApplication, v(1)

'Or use the following for a script/application with no arguments
	'Un-comment the following line to use no argument
	'run scriptApplication
End Sub

Sub run(sApplication)
	Set runWshShell = WScript.CreateObject ("WSCript.shell")
	runWshShell.run chr(34) & sApplication & chr(34)
	Set runWshShell = Nothing
End Sub

Sub runWithArg(sApplication, sArgument)
	Dim rws
	Set runWithWshShell = WScript.CreateObject ("WSCript.shell")
	rws = chr(34) & sApplication & chr(34) & " " & chr(34) & chr(34) & Replace(sArgument,"\\","\") & chr(34) & chr(34)
	runWithWshShell.run rws
	Set runWithWshShell = Nothing
End Sub
'==================================================================================
'   Initailize
'==================================================================================
'    Change someFolderPath to the actual folder to monitor. e/g "C:\Automated"
'    Also,
'    change someOtherPath to the path you save the bookParser script to. e.g. "c:\parser"
'    IMPORTANT: The script/application really should not have any GUI elements
'==================================================================================
set WshShell = WScript.CreateObject("WScript.Shell")
desktop = WshShell.SpecialFolders("Desktop")
Set WshShell = Nothing
monitoredFolder= desktop & "\MMe"
scriptApplication = desktop & "\SImages\AutoAnaStereo.vbs"
msgbox "Monitoring " & monitoredFolder
startMontoringFileCreation monitoredFolder

No HTML to View

Save this file to your system as AutoAnaStereo.vbs

Select All

'
' AutoAnaStereo.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.
'
'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.
'The usual suspects have been exhausted:
'javascript.internet.com
'www.scriptsearch.com
'
'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." & vbcrlf & a(0),2
		Set fso = createObject("Scripting.FileSystemObject")
		nx = a(0)

n = nx
		gn = getName(n)
		n = WScript.ScriptFullName
		
		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
WshShell.popup m, 2
Set WshShell = Nothing
Set a = Nothing
'
' ... Ends Here
' Program Anaglyph From Stereo Image
'************************************************************

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