newscript
dim appVersion = "2023-03-21"
FUNCTION appDescription ()
freestring = "??" & appVersion & "????"
>>Catch a drag'n'dropped file, then use Windows Image Acquisition (WIA)??
>> to get properties of that file.??
>>??
>>Drag'n'drop a file on the coloured area above, or on this display panel.
appDescription = replace ( freestring , "??" , chr(0x0a) )
END Function
' --------------------------------------------------
' useful URLa
' https://www.devhut.net/getting-image-properties-exif-metadata-using-wia-in-vba/
' --------------------------------------------------
FUNCTION toggleWarnColour ( sobid )
IF ( sob (sobId , "GET", "RGB" ) == RGB ( 0xff ,0xbf ,0xbf ) ) then
sob ( sobId , "SET", "RGB" , RGB ( 0xff ,0,0 ) )
ELSE
sob ( sobId , "SET", "RGB" , RGB ( 0xff ,0xbf ,0xbf ) )
END IF
END FUNCTION
FUNCTION toggleOKColour ( sobid )
IF ( sob (sobId , "GET", "RGB" ) == RGB ( 0 ,0xff ,0 ) ) then
sob ( sobId , "SET", "RGB" , RGB ( 0x7f ,0xff ,0x7f ) )
ELSE
sob ( sobId , "SET", "RGB" , RGB ( 0 ,0xff ,0 ) )
END IF
END FUNCTION
' --------------------------------------------------
'Converts numeric Image Property Type values into English terms
FUNCTION GetWiaImagePropertyType( lType )
SELECT CASE lType
CASE 1000
ReturnValue = "Undefined"
CASE 1001
ReturnValue = "Byte"
CASE 1002
ReturnValue = "String"
CASE 1003
ReturnValue = "Unsigned Integer"
CASE 1004
ReturnValue = "Long"
CASE 1005
ReturnValue = "Unsigned Long"
CASE 1006
ReturnValue = "Rational"
CASE 1007
ReturnValue = "Unsigned Rational"
CASE 1100
ReturnValue = "Vector Of Undefined"
CASE 1101
ReturnValue = "Vector Of Bytes"
CASE 1102
ReturnValue = "Vector Of Unsigned"
CASE 1103
ReturnValue = "Vector Of Longs"
CASE 1104
ReturnValue = "Vector Of UnsignedLongs"
CASE 1105
ReturnValue = "Vector Of Rationals"
CASE 1106
ReturnValue = "Vector Of Unsigned Rationals"
CASE ELSE
ReturnValue = "Unknown Type"
END SELECT
END Function
FUNCTION getOrientation ( val )
SELECT CASE val
case 1
ReturnValue = "0 degrees"
case 2
ReturnValue = "0 degrees, mirrored: image has been flipped back-to-front"
case 3
ReturnValue = "180 degrees: image is upside down"
case 4
ReturnValue = "180 degrees, mirrored: image has been flipped back-to-front and is upside down"
case 5
ReturnValue = "90 degrees: image has been flipped back-to-front and is on its side"
case 6
ReturnValue = "90 degrees, mirrored: image is on its side"
case 7
ReturnValue = "270 degrees: image has been flipped back-to-front and is on its far side"
case 8
ReturnValue = "270 degrees, mirrored: image is on its far side"
case else
ReturnValue = "?"
END SELECT
END FUNCTION
FUNCTION handleFile ( filePathName )
dim fs, folder
dim FilePath = Left ( filePathName , inStrRev ( filePathName , "\\" ) - 1)
dim FileName = Left ( filePathName , -1 * inStrRev ( filePathName , "\\" ) )
dim objIF = CreateObject("WIA.ImageFile")
dim objV = CreateObject("WIA.Vector")
sob ( AppDisplay,"ADD", "ROW", "Path " & FilePath & chr(0x0a) )
sob ( AppDisplay,"ADD", "ROW", "File " & FileName & chr(0x0a) & chr(0x0a) )
TRY
objIF.LoadFile ( filePathName )
CATCH
sob ( AppDisplay,"ADD", "ROW", "File error, or file not supported by WIA.IMAGEFILE" & chr(0x0a) & chr(0x0a) )
EXIT function
END try
dim txt , limit , name
dim prop , i = 0 ,j , oV
FOR each prop in objIF.properties
i++
' sob ( AppDisplay,"ADD", "ROW", right( "0000" & i , 4) & " " & right( "000000" & .PropertyID , 6) & " " & GetWiaImagePropertyType(.Type) & " " & .name & " " )
WITH prop
If( ( .PropertyID <> 20507) And ( .PropertyID <> 20624) And ( .PropertyID <> 20625)) Then
name = .name
' ----------------------------------------------
' align the text using TABs
SELECT case length(name)
CASE 0 to 6
name = name & chr(0x09) & chr(0x09)& chr(0x09)& chr(0x09)
CASE 6 to 13
name = name & chr(0x09) & chr(0x09) & chr(0x09)
CASE 12 to 20
name = name & chr(0x09) & chr(0x09)
CASE else
name = name & chr(0x09)
END select
sob ( AppDisplay,"ADD", "ROW", name )
' ----------------------------------------------
IF .IsVector = False Then
IF .type = 1006 Then
TRY
sob ( AppDisplay,"ADD", "ROW", .Value & " " & .Value.Numerator & "/" & .Value.Denominator & " " & chr(0x0a) )
CATCH
sob ( AppDisplay,"ADD", "ROW", "1066 " & .Value & chr(0x0a) )
END TRY
ELSE
TRY
if ( .PropertyID == 274 ) then
sob ( AppDisplay,"ADD", "ROW", .Value & " " & getOrientation ( .Value ) & chr(0x0a) )
Else
sob ( AppDisplay,"ADD", "ROW", .Value & chr(0x0a) )
End if
CATCH
sob ( AppDisplay,"ADD", "ROW", " .Value ?? " & chr(0x0a) )
END try
END If
ELSE
' isVector
oV = .Value
txt = ""
limit = oV.Count
if ( limit > 64 ) then limit = 64
FOR j = 1 To limit
IF ( j == 1 ) then
txt = txt & istype(ov.item(j) ) & " "
END if
TRY
txt = txt & hex( oV.Item(j) ) & " "
CATCH
txt = txt & " ? "
END try
NEXT j
if ( oV.Count > 64 ) then txt = txt & "..."
txt = Trim(txt)
sob ( AppDisplay,"ADD", "ROW", GetWiaImagePropertyType(.Type) & " " & txt & chr(0x0a) )
END If
END iF
END with
NEXT prop
SOB ( AppDisplay , "SET" , "ROW" , "TOP" , 1 )
END function
' --------------------------------------------------
' create a window to contain some SOBs
'
dim myWindow = sob ("application","NEW","Image properties using WIA")
'
' Define a callback to handle a click on the TOP Right "X"
FUNCTION XmyWindow ( sobid )
sob ( sobid, "delete")
END function
'
' Associate the callback with myWindow
sob ( myWindow,"ON","CLICK", "XmyWindow")
' sob ( myWindow , "SET" , "STRETCH" , 1 )
' sob ( myWindow , "SET" , "TITLE" , "Replace text in all PPTs" )
' -----------------------------------------------------
' Define a callback to handle a click on the TOP Right "X"
' Callbacks are discussed in detail in the CALLBACK help option
FUNCTION ClickMyWindow ( sobid )
' delete the SOB myWindow , automatically deletes all of its child SOBs
sob ( myWindow, "delete")
END function
'
' -----------------------------------------------------
' add a menu bar myWindow
dim myMenuBar = sob (myWindow , "add" , "menu" , "bar" )
' ( target , action , qualifier , qualifier )
'
' add two horizonal menus to myMenuBar
dim myMenuFile = sob (myMenuBar , "add" , "menu" , "Horizontal" , "File" )
' ( target , action , qualifier , qualifier , parameter )
'
dim myMenuOptions = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Input Options" )
' ( target , action , qualifier , qualifier , parameter )
'
dim myMenuTools = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Tools" )
' ( target , action , qualifier , qualifier , parameter )
'
dim myMenuHelp = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Help" )
' ( target , action , qualifier , qualifier , parameter )
'
' -----------------------------------------------------
' add a menu item to the FILE menu
' Note: we are not going to explicitly remember the ID of the menu SOB we are about to create.
' This is a trick, see comment in about 4 lines!
sob ( myMenuFile , "add" , "menu" , "Vertical" , "Exit" )
' target , action , qualifier , qualifier , parameter )
' Associate a click / press on the File.Exit menu option with a callback handler
' Note: a SOB id of -1 always refers to the SOB used in the last SOB command
' If we did not have this, then we would have had to have a DIM in the previous SOB command line
sob ( -1 , "ON" , "CLICK" , "ClickMyWindow")
' ( target , action , qualifier , parameter )
' -----------------------------------------------------
' Define a callback to handle a click on the Help.About menu option (not yet defined)
FUNCTION ClickAbout ( sobid )
sob ( AppDisplay, "EMPTY")
sob ( AppDisplay, "ADD", "ROW", appDescription() )
toggleOKColour ( AppCatchArea )
END Function
' add an ABOUT menu item to the HELP menu
sob ( myMenuHelp , "add" , "menu" , "Vertical", "About" )
' ( target , action , qualifier , qualifier , parameter )
' Associate the callback with the Help.About menu option
' Note: we use the -1 trick again
sob ( -1 , "ON" , "CLICK" , "ClickAbout" )
' ( target , action , qualifier , parameter )
' -----------------------------------------------------
' Define a callback to handle a click on the Help.Contact menu option (not yet defined)
FUNCTION ClickContact ( sobid )
sob ( AppDisplay, "EMPTY")
sob ( AppDisplay, "ADD", "ROW", "E-Mail: George.Salisbury@RipeTech.com" & chr(0x0a) )
toggleOKColour ( AppCatchArea )
END Function
'
' add a CONTACT menu item to the HELP menu
sob ( myMenuHelp , "add" , "menu" , "Vertical" , "Contact" )
' ( target , action , qualifier , qualifier , parameter )
' Associate the callback with the Help.Contact menu option
' Note: we use the -1 trick again
sob ( -1 ,"ON","CLICK", "ClickContact")
' -----------------------------------------------------
FUNCTION CbClearAppDisplay ( sobid )
sob ( AppDisplay, "EMPTY")
END Function
' -----------------------------------------------------
sob ( myMenuTools , "add" , "menu" , "Vertical", "Clear display area" )
sob ( -1 , "ON" , "CLICK" , "CbClearAppDisplay" )
dim wideColumn = sob ( myWindow , "ADD" , "CONTAINER" , "COLUMN.W")
sob ( wideColumn , "SET" , "STRETCH" , 1 )
' --------------------------------------------------
dim FolderPath = sob ( wideColumn , "ADD" , "LABEL" , " ")
SOB ( "OVERRIDE" , "STYLE+" , 0x00002000)
>??
>>Drag'n'drop a file here??
dim AppCatchArea = sob ( wideColumn , "ADD" , "BUTTON" , "PUSH" , replace ( freestring, "??", chr(0x0a)) )
dim AppDisplay = sob ( wideColumn , "ADD" , "EDIT.ROWS" , " " , 3 )
font("RESET")
font("SET" ,"FaceName" , "Courier New" )
dim myFont = Font("CREATE")
sob ( AppDisplay , "SET", "FONT" , myFont )
FUNCTION handleFolder ( sobId )
IF ( isFile ( getDropData(1) ) == -1 ) THEN
' handleFolder (getDropData(1) & "\\")
END IF
END FUNCTION
FUNCTION cbCatchDroppedObject ( sobId )
sob ( AppDisplay, "empty")
IF ( isFile ( getDropData(1) ) == 1 ) THEN
' file
handleFile (getDropData(1) )
toggleOKColour ( AppCatchArea)
ELSEIF ( isFile ( getDropData(1) ) == -1 ) THEN
' folder
sob ( AppDisplay,"ADD", "ROW", "Sorry, no handler for a folder(s) " & chr(0x0a) )
ELSE
' error
sob ( AppDisplay,"ADD", "ROW", "Invalid file path/ name" & chr(0x0a) & getDropData(1) & chr(0x0a) )
END IF
END FUNCTION
' --------------------------------------------------------------------
sob ( AppCatchArea ,"ON" ,"DROP.FILE", "cbCatchDroppedObject")
sob ( AppDisplay ,"ON" ,"DROP.FILE", "cbCatchDroppedObject")
toggleOKColour ( AppCatchArea )
sob ( AppDisplay, "empty")
sob ( AppDisplay,"ADD", "ROW", appDescription() )