BreadCrumbs: Visual Basic Script

Visual Basic Script

From Luke Jackson

(Difference between revisions)

Revision as of 03:25, 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 Fso
Dim Files
Dim sFilter
Dim sFolder
Dim File
Dim sPath
Dim FileInfo
Dim ImgInfo
Dim ImgDims
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
'sFolder = oWSHShell.ExpandEnvironmentStrings("%TEMP%")
'Set sFolder = Fso.GetSpecialFolder(TemporaryFolder)
sFolder = "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 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(sFolder, 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
    	'Get File Info
        FileInfo = GetFileInfo(File)
        'Get Picture Info
        'If GetImgInfo(sFolder, File) <> -1 Then
            ImgInfo = GetImgInfo(sFolder, File)
            ImgDims = GetImgDimURI(ImgInfo)
        'End If
        'Create HTTP Connection
        Set http = CreateObject("MSXML2.XMLHTTP")
        http.Open "GET", URL & URI & FileInfo & ImgDims, False
        http.Send
        WScript.Sleep(2000) 'Wait 2 Seconds
        If http.Status = 200 And http.StatusText = "OK" Then
            'Fso.DeleteFile (File)
            wLog.WriteLine File & "-" & ImgDims & "-" & 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 GetImgInfo(ByVal Folder, ByVal File)

Dim arrValues(34)
Dim objShell
Dim objFolder
Dim objFolderItem
Dim i
Dim sPath

GetImgInfo = -1

sPath = Split(File, "\") 'Split on Path
If Not IsEmpty(sPath(2)) Then
	Set objShell = CreateObject("Shell.Application")
	Set objFolder = objShell.Namespace(Folder)
	Set objFolderItem = objFolder.ParseName(sPath(2))
	
	For i = 0 To 33
	    arrValues(i) = objFolder.GetDetailsOf(objFolderItem, i)
	Next
	
	If UBound(arrValues) > 0 Then GetImgInfo = arrValues
End If

End Function

Public Function GetImgDimURI(ByVal FileDetails)

Dim w
Dim h
Dim URI

GetImgDimURI = -1

If UBound(Split(FileDetails(27))) = 1 Then w = Split(FileDetails(27))
If UBound(Split(FileDetails(28))) = 1 Then h = Split(FileDetails(28))

If Len(w(0)) > 0 And Len(h(0)) > 0 Then
	URI = "&width=" & w(0) & "&height=" & h(0)
	GetImgDimURI = URI
	Exit Function
End If

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

Retrieved from "http://wiki.ljackson.us/Visual_Basic_Script"

Visual Basic Script

From Luke Jackson

Revision as of 03:25, 16 November 2010

Onyx Registration Script

DD Track Script

Views

Personal tools

Navigation

Search

Toolbox