BreadCrumbs: Visual Basic Script
Visual Basic Script
From Luke Jackson
(Difference between revisions)
| Revision as of 00:35, 16 November 2010 (edit) Ljackson (Talk | contribs) ← Previous diff |
Revision as of 00:35, 16 November 2010 (edit) Ljackson (Talk | contribs) (→DD Track Script) Next diff → |
||
| Line 85: | Line 85: | ||
| - | === DD Track Script === | + | == DD Track Script == |
| <pre> | <pre> | ||
Revision as of 00:35, 16 November 2010
Onyx Registration Script
Dim oWSHShell
Dim oWSHEnvironment
Dim Processes
Dim Process
Dim isAlive
Dim retCode
Dim RegItm1
Dim RegItm2
Dim CurApp
Set oWSHShell = WScript.CreateObject("WScript.Shell")
Set objWMIService = GetObject("winmgmts:")
Set Processes = objWMIService.InstancesOf("Win32_Process")
'Set oWSHEnvironment = oWSHShell.Environment("windir")
RegItm1 = "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\ProductKey"
RegItm2 = "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup\ProductKey"
For each Process in Processes
'WScript.Echo Process.Name
'WScript.Echo Process.ProcessId
Select Case LCase(Process.Name)
Case "postershop.exe" 'Onyx ProductionHouse
'retCode = oWSHShell.Popup(Process.Name & " will Close in 30 seconds.", 30, "Onyx Registration Script", 4 + 16)
'Select Case retCode
'case 6, -1
'Process.Terminate(0) 'Yes or timeout was chosen
'case 7
'WScript.quit(1) 'No was chosen
'End Select
Process.Terminate(0)
End Select
Next
Set isAlive = objWMIService.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'Postershop.exe'")
If isAlive.Count = 0 Then
If keyExists(RegItm1) = True Then oWSHShell.RegDelete RegItm1
If keyExists(RegItm2) = True Then oWSHShell.RegDelete RegItm2
WScript.Sleep 20000 'Wait 20 seconds.
oWSHShell.Run """E:\Onyx Graphics\ProductionHouse\server\Postershop.exe""", 5, False
WScript.Sleep 30000 'Wait 30 seconds.
oWSHShell.AppActivate "Enter"
WScript.Sleep 5000 'Wait 5 seconds.
oWSHShell.SendKeys "{TAB}{ENTER}" 'Close the registration screen.
'oWSHShell.Run "C:\DD\Scripts\close.register.onyx.vbs", 8, False
Else
MsgBox "Onyx is still running. Please close the application and attempt registration again.", vbCritical, "Onyx Registration Script"
Set oWSHShell = Nothing
WScript.Quit
End If
Set oWSHShell = Nothing
WScript.Quit
'Start Functions
function KeyExists(byval sKeyPath)
keyExists= false
sKeyPath= trim(sKeyPath): if (sKeyPath="") then exit function
if not (right(sKeyPath, 1)="\") then sKeyPath= sKeyPath & "\"
on error resume next
createobject("wscript.shell").regRead sKeyPath
select case err
case 0: keyExists= true
case &h80070002: dim sErrMsg
sErrMsg= replace(err.description, sKeyPath, "")
err.clear
createobject("wscript.shell").regRead "HKEY_ERROR\"
keyExists= not (sErrMsg=replace(err.description, _
"HKEY_ERROR\", ""))
end select
on error goto 0
end function
DD Track Script
Option Explicit
TrackDD()
Public Function TrackDD()
'Spreadshirt DD Track v1
Dim oWSHShell
Dim http
Dim Tmp
Dim Fso
Dim Folder
Dim Files
Dim sFilter
Dim File
Dim sPath
Dim FileInfo
Dim objNetwork
Dim CompName
Dim UserName
Dim PrintNum
Dim URL
Dim URI
Dim key
Dim wLog
Dim lDate
Set oWSHShell = CreateObject("WScript.Shell")
Set Fso = CreateObject("Scripting.FileSystemObject")
'Computer Info
'Tmp = oWSHShell.ExpandEnvironmentStrings("%TEMP%")
'Set Tmp = Fso.GetSpecialFolder(TemporaryFolder)
Tmp = "C:\Temp"
sFilter = "*.bmp"
Set objNetwork = CreateObject("WScript.Network")
CompName = objNetwork.ComputerName
UserName = objNetwork.UserName
Set wLog = Fso.CreateTextFile("D:\Scripts\track.log.txt", True)
'Returns "Wednesday, Jan 27 1993 17:04:03"
lDate = vbsFormat(Now, "dddd, MMM dd yyyy h:mm:ss")
'Write Dese Log Header
wLog.WriteLine "################################# Spreadshirt DD Track Log - " & UserName & "@" & CompName & " - " & lDate & " #################################"
'Tracking Configuration
key = "ba7893e62fc5e3cb5324626c2f332847"
PrintNum = "054"
URL = "http://track.io85.com/"
URI = "?key=" & key & "&compname=" & CompName & "&username=" & UserName & "&printnum=" & PrintNum
'List BMPs in Temp Dir
Files = ListDir(Tmp, sFilter)
If UBound(Files) = -1 Then
wLog.WriteLine "No files found!"
Exit Function
End If
For Each File In Files
If GetFileInfo(File) <> -1 Then
FileInfo = GetFileInfo(File)
'Create HTTP Connection
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", URL & URI & FileInfo, False
http.send
WScript.Sleep(1000) 'Wait 1 Seconds
If http.Status = 200 And http.StatusText = "OK" Then
'Fso.DeleteFile (File)
wLog.WriteLine File & "-" & http.Status & "-" & http.StatusText
End If
Else
wLog.WriteLine "Not a printout! - " & File
End If
Next
Set oWSHShell = Nothing
End Function
Public Function GetFileInfo(ByVal File)
Dim Files
Dim sPath
Dim FileInfo
Dim Info
Dim Hexs
Dim URI
GetFileInfo = -1
sPath = Split(File, "\") 'Split on Path
If Not IsEmpty(sPath(2)) Then
FileInfo = Split(sPath(2), "_") 'Split on Underscore
Select Case UBound(FileInfo)
Case 7
'2624941_846337_109_L_FFFFFF_white_1_Preview.bmp
'1111111_222222_333_4_555555_66666_7_88888888888
URI = "&config=" & FileInfo(0) _
& "&trans=" & FileInfo(1) _
& "&product=" & FileInfo(2) _
& "&size=" & FileInfo(3) _
& "&hex=" & FileInfo(4) _
& "&color=" & FileInfo(5)
GetFileInfo = URI
Exit Function
Case 8
'Distingish between dual color products or two word color names
Hexs = 0
For Each Info In FileInfo
If IsHex(Info, 6) Then Hexs = Hexs + 1
Next
Select Case Hexs
Case 2
'23824549_845933_111_S_32409A_royal_blue_1_Preview.bmp
'00000000_111111_222_3_444444_55555_6666_7_88888888888
URI = "&config=" & FileInfo(0) _
& "&trans=" & FileInfo(1) _
& "&product=" & FileInfo(2) _
& "&size=" & FileInfo(3) _
& "&hex=" & FileInfo(4) _
& "&color=" & FileInfo(5) & "%20" & FileInfo(6)
Case 3
'2007771_845904_121_L_FFFFFF_000000_white-black_1_Preview.bmp
'0000000_111111_222_3_444444_555555_66666666666_7_88888888888
URI = "&config=" & FileInfo(0) _
& "&trans=" & FileInfo(1) _
& "&product=" & FileInfo(2) _
& "&size=" & FileInfo(3) _
& "&hex=" & FileInfo(4) _
& "&hex2=" & FileInfo(5) _
& "&color=" & FileInfo(6)
Case Else
URI = "&config=" & FileInfo(0) _
& "&trans=" & FileInfo(1) _
& "&product=" & FileInfo(2) _
& "&size=" & FileInfo(3) _
& "&hex=Unknown" _
& "&color=Unknown"
End Select
GetFileInfo = URI
Exit Function
Case 9
'23830562_846334_402_M_B8C3DB_melange_sky_blue_1_Preview.bmp
'00000000_111111_222_3_444444_5555555_666_7777_8_99999999999
URI = "&config=" & FileInfo(0) _
& "&trans=" & FileInfo(1) _
& "&product=" & FileInfo(2) _
& "&size=" & FileInfo(3) _
& "&hex=" & FileInfo(4) _
& "&color=" & FileInfo(5) & "%20" & FileInfo(6) & "%20" & FileInfo(7)
GetFileInfo = URI
Exit Function
Case 11
'20018688_846664_48_L__14-16_yrs__FFFFFF_white_1_Preview.bmp
'00000000_111111_22_3_4_5555_666_7_88888_99999_10_1111111111
URI = "&config=" & FileInfo(0) _
& "&trans=" & FileInfo(1) _
& "&product=" & FileInfo(2) _
& "&size=" & FileInfo(3) & "%20" & FileInfo(5) & "%20" & FileInfo(6) _
& "&hex=" & FileInfo(8) _
& "&color=" & FileInfo(9)
GetFileInfo = URI
Exit Function
Case 12
'20307736_843436_48_L__14-16_yrs__1E9658_kelly_green_1_Preview.bmp
'00000000_111111_22_3_4_5555_666_7_88888_99999_10101_11_1212121212
URI = "&config=" & FileInfo(0) _
& "&trans=" & FileInfo(1) _
& "&product=" & FileInfo(2) _
& "&size=" & FileInfo(3) & "%20" & FileInfo(5) & "%20" & FileInfo(6) _
& "&hex=" & FileInfo(8) _
& "&color=" & FileInfo(9) & "%20" & FileInfo(10)
GetFileInfo = URI
Exit Function
Case Else
Exit Function
End Select
Else
Exit Function
End If
End Function
Public Function IsHex(ByVal strInput, ByVal sLimit)
Dim I
Dim j
Dim m
Dim sHexValue
Dim sHexValues
Dim aHexValues
strInput = UCase(strInput)
sHexValues = "0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F"
aHexValues = Split(sHexValues, ",")
IsHex = False
If LenB(strInput) = 0 Then Exit Function
I = 1
j = Len(strInput)
m = 0
Do Until I > j
'If (Mid(strInput, i, 1) Like "[0-9A-Fa-f]") Then m = m + 1
For Each sHexValue In aHexValues
Dim d: d = UCase(Mid(strInput, I, 1))
If UCase(Mid(strInput, I, 1)) = sHexValue Then
m = m + 1
Exit For
End If
Next
I = I + 1
Loop
If m = j And m = sLimit Then IsHex = True
End Function
Public Function ListDir(ByVal Path, ByVal sFilter)
' Returns an array with the file names that match Path.
' The Path string may contain the wildcard characters "*"
' and "?" in the file name component. The same rules apply
' as with the MSDOS DIR command.
' If Path is a directory, the contents of this directory is listed.
' If Path is empty, the current directory is listed.
' Author: Christian d'Heureuse (www.source-code.biz)
Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
If Path = "" Then Path = "*.*"
Dim Parent
If Fso.FolderExists(Path) Then ' Path is a directory
Parent = Path
If sFilter = "" Then sFilter = "*"
Else
Parent = Fso.GetParentFolderName(Path)
If Parent = "" Then If Right(Path, 1) = ":" Then Parent = Path Else Parent = "."
sFilter = Fso.GetFileName(Path)
If sFilter = "" Then sFilter = "*"
End If
ReDim a(10)
Dim n: n = 0
Dim Folder: Set Folder = Fso.GetFolder(Parent)
Dim Files: Set Files = Folder.Files
Dim File
For Each File In Files
If CompareFileName(File.Name, sFilter) Then
If n > UBound(a) Then ReDim Preserve a(n * 2)
a(n) = File.Path
n = n + 1
End If
Next
ReDim Preserve a(n - 1)
ListDir = a
End Function
Private Function CompareFileName(ByVal Name, ByVal sFilter) ' (recursive)
CompareFileName = False
Dim np, fp: np = 1: fp = 1
Do
If fp > Len(sFilter) Then CompareFileName = np > Len(Name): Exit Function
If Mid(sFilter, fp) = ".*" Then ' special case: ".*" at end of filter
If np > Len(Name) Then CompareFileName = True: Exit Function
End If
If Mid(sFilter, fp) = "." Then ' special case: "." at end of filter
CompareFileName = np > Len(Name): Exit Function
End If
Dim fc: fc = Mid(sFilter, fp, 1): fp = fp + 1
Select Case fc
Case "*"
CompareFileName = CompareFileName2(Name, np, sFilter, fp)
Exit Function
Case "?"
If np <= Len(Name) And Mid(Name, np, 1) <> "." Then np = np + 1
Case Else
If np > Len(Name) Then Exit Function
Dim nc: nc = Mid(Name, np, 1): np = np + 1
If StrComp(fc, nc, vbTextCompare) <> 0 Then Exit Function
End Select
Loop
End Function
Private Function CompareFileName2(ByVal Name, ByVal np0, ByVal sFilter, ByVal fp0)
Dim fp: fp = fp0
Dim fc2
Do ' skip over "*" and "?" characters in filter
If fp > Len(sFilter) Then CompareFileName2 = True: Exit Function
fc2 = Mid(sFilter, fp, 1): fp = fp + 1
If fc2 <> "*" And fc2 <> "?" Then Exit Do
Loop
If fc2 = "." Then
If Mid(sFilter, fp) = "*" Then ' special case: ".*" at end of filter
CompareFileName2 = True: Exit Function
End If
If fp > Len(sFilter) Then ' special case: "." at end of filter
CompareFileName2 = InStr(np0, Name, ".") = 0: Exit Function
End If
End If
Dim np
For np = np0 To Len(Name)
Dim nc: nc = Mid(Name, np, 1)
If StrComp(fc2, nc, vbTextCompare) = 0 Then
If CompareFileName(Mid(Name, np + 1), Mid(sFilter, fp)) Then
CompareFileName2 = True: Exit Function
End If
End If
Next
CompareFileName2 = False
End Function
Public Function vbsFormat(Expression, Format)
vbsFormat = CoreFormat("{0:" & Format & "}", Expression)
End Function
' Allows more of the .NET formatting functionality to be used directly if required
Public Function CoreFormat(Format, Expression)
CoreFormat = Expression
On Error Resume Next
With CreateObject("System.Text.StringBuilder")
.AppendFormat Format, Expression
If Err=0 Then CoreFormat = .toString
End With
End Function