PhotoResizer HTA

Forums

My Profile

Inbox

Address Book

My Subscription

My Forums

PhotoResizer HTA

Logged in as: Guest

arrSession:exec spGetSession 2,16,53434

	Active Users: There are 0 members and 0 guests.
	Users viewing this topic: none

Printable Version

All Forums >> [Scripting] >> Post a VBScript >> PhotoResizer HTA
Do you like VisualBasicScript.com? Link to us and help spread the word about our forum. Thanks!

Page: [1]

Message

<< Older Topic Newer Topic >>

PhotoResizer HTA - 11/10/2007 5:32:52 PM

Meg

Posts: 125
Score: 2
Joined: 7/13/2006
From: Australia
Status: offline

This is script that resizes images (written for fun)

rOOs wrote almost exactly the same script (German UI) and posted on this forum.

http://www.visualbasicscript.com/m_32218/mpage_1/key_imageresizer/tm.htm#32218
This one has an English UI and a few more features, but we obviously both had the same idea.
I am not a plagiarists honest, I didn't see rOOs script until I finished mine

<html>
<head>
<title>PhotoResizer</title>
<HTA:APPLICATION 
   ID="objPhotoResizer"
   APPLICATIONNAME="PhotoResizer"
   SCROLL="yes"
   SINGLEINSTANCE="yes"
   WINDOWSTATE="maximize"
>
<style>
body,td,a {font-family:Tahoma, Veranda, Arial; font-size:12px; text-decoration:none; color:black;}
a:link { color : blue; background : transparent ;   text-decoration: underline}
a:visited { color : black; background : transparent ;   text-decoration: none}
a:Hover { color : red; background : transparent ;   text-decoration: none}
</style>
</head>
<SCRIPT Language="VBScript">
Dim x
Dim ImgDir, ResDir, Pwidth, Pheight, Append
Dim objPath
strVer = "1.00"
'**********************************************************
Sub Window_Onload
document.title = document.title & " | Version: "&strVer
'check screen resolutionb is not too small and resize application
Swidth = screen.width
Sheight = screen.height
if Sheight < 768 then
  msgbox "Srcript works best with a screen resolution of 1024/768 or better"
end if
window.resizeTo 1000,730
runbutton3.disabled = true
'Check if WIAAut.dll is installed 
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists("C:\Windows\System32\WIAAut.dll") Then
  If not IsRegistered() then
preview.innerhtml="Windows Image Acquisition Library dll is not registered<br><br>From a Command Prompt in the System32 directory run the following command: <br><br>RegSvr32 WIAAut.dll  "
  end if
else
  preview.innerhtml="Microsoft's Windows Image Acquisition Library is not installed<br><br>download from here:<br> <a href='http://www.microsoft.com/downloads/details.aspx?FamilyID=a332a77a-01b8-4de6-91c2-b7ea32537e29&DisplayLang=en'>http://www.microsoft.com/downloads/details.aspx?FamilyID=a332a77a-01b8-4de6-91c2-b7ea32537e29&DisplayLang=en</a>"
end if
end sub
'**********************************************************
Function IsRegistered()
'Check if WIAAut.dll is registered
On Error Resume Next
Set obj = Nothing
Set obj = CreateObject("WIA.ImageFile")
If obj Is Nothing Then
   IsRegistered = False
Else
   IsRegistered = True
   Set obj = Nothing
End If
on error goto 0
End Function
'**********************************************************
function ResizeMe(ImgDir, ImgName, ImgNameCut, Ext, ResDir, Pwidth, Pheight, Append)
'Resize Images function
Dim Img 'As ImageFile
Dim ImgPro 'As ImageProcess
Set Img = CreateObject("WIA.ImageFile")
Set ImgPro = CreateObject("WIA.ImageProcess")
Img.LoadFile ImgDir&"\"&ImgName
ImgPro.Filters.Add ImgPro.FilterInfos("Scale").FilterID
ImgPro.Filters(1).Properties("MaximumWidth") = Pwidth
ImgPro.Filters(1).Properties("MaximumHeight") = Pheight
Set Img = ImgPro.Apply(Img)
Set objFSO=CreateObject("Scripting.FileSystemObject")
if objFSO.FileExists(ResDir&"\"&ImgNameCut&Append&"."&Ext) then
  objFSO.DeleteFile(ResDir&"\"&ImgNameCut&Append&"."&Ext)
end if
Img.SaveFile ResDir&"\"&ImgNameCut&Append&"."&Ext
end function
'**********************************************************
Sub Previewer
'scan every file in image folder
on error resume next
p=0
ImgDir=ImgDirHTML.value
set oShell= createObject("shell.application")
set oFolder = oShell.namespace(ImgDir)
set fso = createObject("scripting.fileSystemObject")
For each i in oFolder.items
  set f = fso.getFile(IMGDir & "\" & i)
  ImgName= oFolder.GetDetailsOf(i,00)
  ImgFullPath= IMGDir & "\" & i
  X=InstrRev(IMGFullPath, ".")
  W=len(IMGFullPath)
  Y=right(IMGFullPath, W-X)
  S=UCASE(Y) 
  'Only interested in images
  if S="JPG" or S="JPEG" or S="TIF" or S="PNG" then
runbutton3.disabled = false
p=p+1
      R="<img src='"&ImgFullPath&"' height=120 width=160>"
      if p>15 then 
          Q=Q&"<br><br><center>Only displaying the first 15 images in this folder</center>"
          Preview.innerhtml="<center>"& ImgDir &"</center><br>"&Q
          Exit Sub
      else
   Q=Q&R 
      End if
  End if
next
If p<=15 then
 Q=Q& "<br><br><center>There are only "&p&" images in this folder.</center>"
end if
Preview.innerhtml="<center>"& ImgDir &"</center><br>"&Q
on error goto 0
if p=0 then 
 Preview.innerhtml="<center>No images in this folder</center>"
 runbutton3.disabled = true
end if
End Sub
'**********************************************************
Sub BrowseFoldera
'Input folder Browse button clicked
BrowseFolder
if objpath="NA" or objpath="Nothing Selected" then
  '
else
  if ResDIRHTML.value="Path to Resized Images" or ResDIRHTML.value="Nothing Selected" then
ResDIRHTML.value=objPath
  end if
end if
ImgDirHTML.value=objPath
Previewer
if not ImgDirHTML.value = ResDirHTML.value then
  ReplaceIMG.innerhtml = " Save images with same file name"
else
  ReplaceIMG.innerhtml = " Replace Original Images"
End if
end sub 
'**********************************************************
Sub BrowseFolderb
'Output folder Browse button clicked
BrowseFolder
ResDirHTML.value=objPath
if not ResDirHTML.value = ImgDirHTML.value then
  ReplaceIMG.innerhtml = " Save images with same file name"
else
  ReplaceIMG.innerhtml = " Replace Original Images"
end if
end sub 
'**********************************************************
Sub BrowseFolder
'Browse local computer for a folder
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
on error resume next
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder _
  (WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, "")       
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
objPath = Replace(objPath, "\", "\\")
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
  & "{impersonationLevel=impersonate}\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
  ("Select * from Win32_Directory where name = '" & objPath & "'")
For Each objFile in colFiles
 Readable =  objFile.Readable
Next

If Err.Number <> 0 Then
  objpath = "Nothing Selected"
  runbutton3.disabled = true
  Err.Clear
  exit sub
End If

on error goto 0
if readable then
  objPath = Replace(objPath, "\\", "\")
else 
  objpath = "NA"
  runbutton3.disabled = true
end if
end sub 
'**********************************************************
Function ImageScan
'scan every file in image folder
set oShell= createObject("shell.application")
set oFolder = oShell.namespace(IMGDir)
set fso = createObject("scripting.fileSystemObject")
For each i in oFolder.items
  set f = fso.getFile(IMGDir & "\" & i)
  ImgName= oFolder.GetDetailsOf(i,00)
  ImgFullPath= IMGDir & "\" & i
  X=InstrRev(IMGFullPath, ".")
  W=len(IMGFullPath)
  Y=right(IMGFullPath, W-X)
  S=UCASE(Y) 
  if S="JPG" or S="JPEG" or S="TIF" or S="PNG" then
U=UCASE(ImgName)
V=Instr(U, S)
ImgNameCut=left(ImgName, V-2)
ResizeMe ImgDir, ImgName, ImgNameCut, Y, ResDir, Pwidth, Pheight, Append
  End if
next
Msgbox "Finished"
end Function
'**********************************************************
Function Convert
'The convert button was pressed
ImgDir=ImgDirHTML.value
ResDir=ResDirHTML.value
Pwidth=WidthHTML.value
Pheight=HeightHTML.value
  If UserOption(0).Checked Then
      Append=""
If not AcceptWarning() then
         msgbox "Aborted"
         Exit Function
      end if
  End If
  If UserOption(1).Checked Then
      Append=AppendHTML.value
  End If
ImageScan
End Function
'**********************************************************
Function AcceptWarning()
'Some error checking, I do my best to stop you overwriting your original images accidently
if ResDirHTML.value = ImgDirHTML.value then
delTaskWarning = MsgBox ("Are you sure you want to REPLACE the images in"&vbcrlf&ImgDir&vbcrlf&"With "&Pwidth&" by "&Pheight&" Versions.", 276, "Warning")
if delTaskWarning = 6 then
  'Continue - you were warned and your images will be REPLACED with a smaller version
  AcceptWarning = True
else
  'Ok you decided not to wipe out your images with new smaller version
  AcceptWarning = False
end if
else
delTaskWarning = MsgBox ("Are you sure you want to SAVE these images into"&vbcrlf&ResDir&vbcrlf&"Any files with the same name will be replaced", 276, "Warning")
if delTaskWarning = 6 then
  'Continue - you were warned and any existing images with the same name will over written
  AcceptWarning = True
else
  'Ok you decided to abort and maybe check what is in the target folder first. 
  AcceptWarning = False
end if
end if
End Function

'**********************************************************
</SCRIPT>
<body>
<center><font face="arial" color=RED size=6><b> PhotoResizer </b></font><br><a href="[link=http://www.painterinfo.com/php2bb/viewtopic.php?t=515]http://www.painterinfo.com/php2bb/viewtopic.php?t=515[/link]" alt="Click here to visit this script's support page">By MJP 2007</a><br><br></center>
<table width="100%" >
<tr>
  <td width="15%" align="right" valign="center">
Input_ Folder
<br>
<br>
Output Folder
  </td>
  <td width="40%" valign="center" border= "black">
<input type="text" name="ImgDirHTML" value="Path to your Folder of images" size="40">
<input id=runbutton1  class="button" type="button" value="Browse" name="run_button1" style="color:black; background-color:#99b3cc" onClick="BrowseFoldera">
<br>
<br>
<input type="text" name="ResDirHTML" value="Path to Resized Images" size="40">
<input id=runbutton2  class="button" type="button" value="Browse" name="run_button2" style="color:black; background-color:#99b3cc" onClick="BrowseFolderb">
  </td>
  <td width="25%" valign="center">
<input type="text" name="WidthHTML" value="640" size="10">Max Width in Pixles
<br>
<input type="text" name="HeightHTML" value="480" size="10">Max Height in Pixles
<br>
<input type="radio" name="UserOption"value="1"><span id=ReplaceIMG> Replace Original Images</span><BR>
<input type="radio" name="UserOption" value="2" CHECKED>Append <input type="text" name="AppendHTML" value="_Resized" size="7"> to file name<BR>
  </td>
  <td width="20%" valign="center">
<input id=runbutton3  class="button" type="button" value="Convert" name="run_button3" style="color:black; background-color:#99b3cc" onClick="Convert">
  </td>
</tr>
</table>
<BR><BR>
<center>
<table width=800 >
<tr>
  <td width=800 valign=top> <span id=Preview><font color="silver"><center><b><i>Preview Area</i></b></center></font></span>
  </td>
</tr>
</table>
</center>
</body>
</html>

< Message edited by Meg -- 11/10/2007 11:25:06 PM >