Visual Basic | Blog of Travis Hydzik

Archive for the ‘Visual Basic’ Category

VBA/VB6 functions to return folder or file type and date modified.

Friday, September 2nd, 2011

Here are two quick functions;

The first getType takes in a path of a folder or file and returns the type.

Function getType(ByRef path As String) As String
    On Error Resume Next
    Dim res As Long
    res = GetAttr(path)
    If Err.Number = 0 Then
        If res And vbDirectory Then
            getType = "folder"
        Else
            getType = "file"
        End If
    Else
        getType = "error"
    End If
End Function

The second function getDate takes in a folder or path and returns the date modified. getDate references getType.

Function getDate(ByRef path As String) As Double
    Select Case getType(path)
        Case "file"
            getDate = CreateObject("scripting.filesystemobject").getfile(path).datelastmodified
        Case "folder"
            getDate = CreateObject("scripting.filesystemobject").getfolder(path).datelastmodified
    End Select
End Function

Tags: date, file, folder, modified, type
Posted in Programming, Visual Basic | No Comments »

VB6/VBA functions to convert binary string to Base64 string

Tuesday, August 16th, 2011

Here are some functions to convert a binary string, to a byte array, to a Base64 string and then back to a byte array and binary string. Run tester to see it in action, enjoy.

Private Function encodeBase64(ByRef arrData() As Byte) As String
    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement

    Set objXML = New MSXML2.DOMDocument

    Set objNode = objXML.createElement(&quot;b64&quot;)
    objNode.DataType = &quot;bin.base64&quot;
    objNode.nodeTypedValue = arrData
    encodeBase64 = objNode.Text

    Set objNode = Nothing
    Set objXML = Nothing
End Function

Private Function decodeBase64(ByVal strData As String) As Byte()
    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement

    Set objXML = New MSXML2.DOMDocument
    Set objNode = objXML.createElement(&quot;b64&quot;)
    objNode.DataType = &quot;bin.base64&quot;
    objNode.Text = strData
    decodeBase64 = objNode.nodeTypedValue

    Set objNode = Nothing
    Set objXML = Nothing
End Function

Function bin2Byte(ByVal s As String) As Byte()
    Dim bitsIn As Long
    bitsIn = 8

    Dim i As Long
    'pad with zeros
    If Len(s) Mod bitsIn &lt;&gt; 0 Then
        For i = 1 To bitsIn - Len(s) Mod bitsIn
            s = &quot;0&quot; &amp; s
        Next i
    End If

    i = Len(s)
    Dim bytes() As Byte
    Dim byteCount As Long
    byteCount = -1
    Dim sByte As String
    Do While LenB(s) &gt; 0
        byteCount = byteCount + 1
        ReDim Preserve bytes(byteCount)

        sByte = Mid$(s, Len(s) - bitsIn + 1)
        'sByte = Mid$(s, 1, bitsIn)
        For i = 0 To 7 Step 1
            bytes(byteCount) = bytes(byteCount) + CLng(Mid$(sByte, 8 - i, 1)) * 2 ^ i
        Next i
        s = Mid$(s, 1, Len(s) - bitsIn)
        's = Mid$(s, bitsIn + 1)
    Loop
    bin2Byte = bytes
End Function

Function byte2Bin(ByRef bytes() As Byte) As String
    Dim i As Long, j As Long
    Dim bin As String
    For i = 0 To UBound(bytes)
        bin = Space$(8)

        For j = 0 To 7
            If bytes(i) And 2 ^ j Then
                Mid(bin, 8 - j, 1) = &quot;1&quot;
            Else
                'Mid(bin, 8 - j, 1) = &quot;0&quot;
            End If
        Next j

        byte2Bin = bin &amp; byte2Bin
    Next i
    byte2Bin = LTrim$(byte2Bin)
    byte2Bin = Replace(byte2Bin, &quot; &quot;, &quot;0&quot;, 1, -1, vbBinaryCompare)
End Function

Sub tester()
    'note we can't add any 0 padding to the test binary string
    Dim bin As String
    bin = &quot;111101000001100010101&quot;
    Dim binOut As String
    binOut = byte2Bin(decodeBase64(encodeBase64(bin2Byte(bin))))

    MsgBox binOut = bin
End Sub

Thanks to Tim Hastings for the Base64 functions.

Tags: Base64, binary, byte array, function
Posted in Programming, Visual Basic | 1 Comment »

Photoshop VBScript to automatically resize images

Saturday, June 25th, 2011

Decided to learn Photoshop VBScripting, don’t know why I didn’t do this sooner, I now have scripts to automatically generate my blog thumbnails (as below), and add little Google Maps markers on them (see here).

A few constants to change in the script (edit with Notepad);

RESIZEWIDTH – thumbnail width
RESIZEHEIGHT – thumbnail height
IGNOREVERTICAL – should vertical (portrait0 images be ignored (I like to do these manually as I crop them to landscape)
SUFFIX – thumbnail suffix

To run it, simply place the script in your image folder (make sure to take a backup) and execute the file.
auto-resize-images-v0.1.vbs

Public Const RESIZEWIDTH = 150
Public Const RESIZEHEIGHT = 113

Public Const IGNOREVERTICAL = True
Public Const SUFFIX = "-th"

Dim spath
spath = Mid(WScript.ScriptFullName, 1, InStrRev(WScript.ScriptFullName, "\", -1, vbBinaryCompare))

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Dim foldero
Set foldero = fso.GetFolder(spath)

Dim fileo
Dim sfile

For Each fileo In foldero.Files
    'only modify jpg files
    sfile = fileo.Name
    If InStrRev(sfile, ".jpg", -1, vbTextCompare) = Len(sfile) - 3 Then
        resize spath & sfile
    End If
Next

MsgBox "Complete."

Sub resize(sfilename)

    Set WshShell = WScript.CreateObject("WScript.Shell")
    Set colProcessList = GetObject("Winmgmts:").ExecQuery("Select * from Win32_Process")

    Dim found
    found = False

    For Each objProcess In colProcessList
        If StrComp(objProcess.Name, "photoshop.exe", vbTextCompare) = 0 Then
            found = True
            Exit For
        End If
    Next

    Dim appRef
    If found Then
        Set appRef = GetObject(, "Photoshop.Application")
    Else
        Set appRef = CreateObject("Photoshop.Application")
    End If

    Do While appRef.documents.Count
       appRef.activeDocument.Close 2 'dont' save
    Loop

    Dim originalRulerUnits
    originalRulerUnits = appRef.Preferences.RulerUnits
    appRef.Preferences.RulerUnits = 1 'pixels

    Dim docRef
    Set docRef = appRef.Open(sfilename)

    Dim modified
    modified = False

    If docRef.Width >= docRef.Height Then 'horizontal photo
            If docRef.Width <> RESIZEWIDTH Then 'proceed if not already resized
                docRef.ResizeImage RESIZEWIDTH 'preserves aspect ratio
                modified = True
            End If
    Else 'verticle photo
        If Not IGNOREVERTICAL Then 'proceed
            If docRef.Height <> RESIZEHEIGHT Then 'proceed if not already resized
                docRef.ResizeImage , RESIZEHEIGHT 'preserves aspect ratio
                modified = True
            End If
        End If
    End If

    If modified Then 'only save if the image was modified
        Dim jpgSaveOptions
        Set jpgSaveOptions = CreateObject("Photoshop.JPEGSaveOptions")
        jpgSaveOptions.Quality = 8

        'calculate the new file name
        Dim newfilename
        newfilename = Mid(sfilename, 1, Len(sfilename) - 4) & SUFFIX & ".jpg"

        docRef.SaveAs newfilename, jpgSaveOptions, True, 2 'for psLowercase
    End If

    docRef.Close 2 'dont' save

    appRef.Preferences.RulerUnits = originalRulerUnits

End Sub

Tags: automatic, Photoshop, resize, script, VBS, Visual Basic
Posted in Programming, Visual Basic | No Comments »

Simple Ping function VBScript

Monday, November 15th, 2010

I was after a ping function that met the following constraints;

Didn’t use GetObject.
Didn’t display any command (cmd) prompt.
Didn’t use a temporary files.

Here is what I found;

<br />
Function ping(node)<br />
    Set WshShell = CreateObject(&quot;WScript.Shell&quot;)<br />
    ping = Not CBool(WshShell.Run(&quot;ping -n 1 &quot; &amp; node, 0, True))<br />
End Function<br />

I was looking at a way to timeout the ping function after 1 second using Threading but this didn’t quite make it so simple. Whilst ping offers a timeout value if you ping an incorrect hostname it will hang for a little while.

Tags: cmd, function, ping, timeout
Posted in Programming, Visual Basic | No Comments »

Decimal to Binary functions in Visual Basic

Sunday, November 7th, 2010

Here are functions to perform decimal to/from binary conversion.

CBin – converts a decimal integer to binary string.
CDeci – converts a binary string to decimal integer.
CBinS16 – converts a decimal signed integer to 16 bit binary string.
CdecS16 – converts a 16 bit binary string to decimal signed integer.

'converts an integer to binary string
Function CBin(ByVal n As Double) As String
    On Error Resume Next 'caters for 0 values
    Dim i As Double
    i = 2 ^ Int(Log(n) / Log(2))
    Do While i >= 1
        CBin = CBin & Fix(n / i)
        n = n - i * Fix(n / i)
        i = i / 2
    Loop
End Function

'converts a binary string to integer
Function CDeci(ByRef s As String) As Double
    Dim i As Long
    CDeci = 0
    For i = 0 To Len(s) - 1
        CDeci = CDeci + (Mid$(s, Len(s) - i, 1) * 2 ^ i)
    Next i
End Function

'converts an integer to 16 bit signed binary string
Function CBinS16(ByVal n As Double) As String
    Dim i As Double

    CBinS16 = vbNullString
    If n < -2 ^ 15 Then
        CBinS16 = "0"
        n = n + 2 ^ 16
        i = 2 ^ 14
    ElseIf n < 0 Then
        CBinS16 = "1"
        n = n + 2 ^ 15
        i = 2 ^ 14
    Else 'not negative
        i = 2 ^ 15
    End If

    Do While i >= 1
        CBinS16 = CBinS16 & Fix(n / i)
        n = n - i * Fix(n / i)
        i = i / 2
    Loop
End Function

'converts 16 bit signed binary string to integer
Function CDecS16(ByRef s As String) As Double
    Dim i As Long
    CDecS16 = 0
    For i = 0 To Len(s) - 1
        CDecS16 = CDecS16 + (Mid$(s, Len(s) - i, 1) * 2 ^ i)
    Next i
    If CDecS16 >= 2 ^ 15 Then 'negative number
        CDecS16 = CDecS16 - 2 ^ 16
    End If
End Function

Tags: 16 bit, binary, convert, decimal, signed integer, string
Posted in Programming, Visual Basic | No Comments »

SQL Server Quickest way to Insert Multiple Rows with VB

Saturday, October 30th, 2010

Having to parse huge amounts of data from xml files to an SQL Server database, I needed to greatly optimise my code. Here are some tests to insert 10000 rows into table TABLETESTER.

First, using the standard INSERT INTO without specifying column names. TickCount of 70547.

For i = 1 To 10000
	Connection.Execute &quot;INSERT INTO TABLETESTER VALUES (1, 'abcdefghijklmnopqrstuvwxyz')&quot;
Next i

Specifying the column names is actually marginally faster. TickCount of 66782.

For i = 1 To 100000
    Connection.Execute &quot;INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')&quot;
Next i

Removing the optional INTO is a little faster still. TickCount 64843.

For i = 1 To 100000
	Connection.Execute &quot;INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')&quot;
Next i

Now lets try some of the methods to combine multiple inserts.

Bunching multiple statements in a single Execute increases the speed by 2. TickCount 35391.

For i = 1 To 100000 / 100
	s = vbNullString
	For j = 1 To 100
		s = s &amp; &quot;INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz');&quot;
	Next j
	Connection.Execute = s
Next i

Using UNION ALL increases it by a whopping 10 fold. TickCount 2781.

For i = 1 To 100000 / 100
	s = &quot;INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) SELECT  1, 'abcdefghijklmnopqrstuvwxyz'&quot;
	For j = 2 To 100
		s = s &amp; &quot; UNION ALL SELECT  1, 'abcdefghijklmnopqrstuvwxyz'&quot;
	Next j
	Connection.Execute = s
Next i

Increasing the inner loop count. TickCount 3125.

For i = 1 To 100000 / 1000
	s = &quot;INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) SELECT  1, 'abcdefghijklmnopqrstuvwxyz'&quot;
	For j = 2 To 1000
		s = s &amp; &quot; UNION ALL SELECT  1, 'abcdefghijklmnopqrstuvwxyz'&quot;
	Next j
	Connection.Execute = s
Next i

Decreasing the inner loop count. TickCount 8235.

For i = 1 To 100000 / 10
	s = &quot;INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) SELECT  1, 'abcdefghijklmnopqrstuvwxyz'&quot;
	For j = 2 To 10
		s = s &amp; &quot; UNION ALL SELECT  1, 'abcdefghijklmnopqrstuvwxyz'&quot;
	Next j
	Connection.Execute = s
Next i

SQL Server 2008 has a new method of combining multiple inserts. TickCount 3282.

For i = 1 To 100000 / 100
	s = &quot;INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')&quot;
	For j = 2 To 100
		s = s &amp; &quot;, (1, 'abcdefghijklmnopqrstuvwxyz')&quot;
	Next j
	Connection.Execute = s
Next i

Increasing the inner loop count, note 1000 is the maximum allowed. TickCount 2859.

For i = 1 To 100000 / 1000
	s = &quot;INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')&quot;
	For j = 2 To 1000
		s = s &amp; &quot;, (1, 'abcdefghijklmnopqrstuvwxyz')&quot;
	Next j
	Connection.Execute = s
Next i

Finally, not a SQL syntax change, but compacting the strings. TickCount 2453.

For i = 1 To 100000 / 1000
	s = &quot;INSERT TABLETESTER (NUMBERVAL,STRINGVAL) VALUES (1,'abcdefghijklmnopqrstuvwxyz')&quot;
	For j = 2 To 1000
		s = s &amp; &quot;,(1,'abcdefghijklmnopqrstuvwxyz')&quot;
	Next j
	Connection.Execute = s
Next i

So from our original method at 66782 to our optimised method at 2453, we get a 97% speed saving!

Tags: INSERT, optimise, quickest, speed, SQL Server, TickCount
Posted in Programming, Visual Basic | 2 Comments »

Visual Basic 6 – quickest way to find first/last character in string

Friday, October 29th, 2010

When you are parsing large amounts of data, the way you code string matching can make a huge difference. In one case I needed to find if a string was contained within quotes, here are the test results from quickest to slowest.

The test situation was to find if the last character in the string ‘abcdefghijklmnopqrstuvwxyz’ is ‘z’ and iterated 100000000 times.

First, the most intuitive which most would use. TickCount of 49546.

Right(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;, 1) = &amp;quot;z&amp;quot;

Function Right takes in a Variant by default, by succeeding it with a dollar sign it accepts Strings by default. TickCount of 22828, a significant saving.

Right$(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;, 1) = &amp;quot;z&amp;quot;

Using the equals sign would be seem the norm, but what if the String Compare function was used. TickCount of 18047.

StrComp(Right$(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;, 1), &amp;quot;z&amp;quot;, vbBinaryCompare) = 0

What if Mid was used to extract the last character instead of Right. TickCount of 28391.

StrComp(Mid$(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;, Len(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;), 1), &amp;quot;z&amp;quot;) = 0

Now what if we use the In String function. String length binary is faster than standard String length. TickCount of 14516.

InStrRev(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;, &amp;quot;z&amp;quot;, -1, vbBinaryCompare) = LenB(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;) / 2

Finally, with out String length binary. TickCount of 11312.

InStrRev(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;, &amp;quot;z&amp;quot;, -1, vbBinaryCompare) = Len(&amp;quot;abcdefghijklmnopqrstuvwxyz&amp;quot;)

So using In String Reverse is 77% faster.

UPDATE next day: Three that I totally forgot about

In String starting at last character, TickCount 11266.

InStr(Len(&quot;abcdefghijklmnopqrstuvwxyz&quot;), &quot;abcdefghijklmnopqrstuvwxyz&quot;, &quot;z&quot;, vbBinaryCompare) = Len(&quot;abcdefghijklmnopqrstuvwxyz&quot;)

And In String Binary which is naturally fast. TickCount 6672.

InStrB(LenB(&quot;abcdefghijklmnopqrstuvwxyz&quot;) - 1, &quot;abcdefghijklmnopqrstuvwxyz&quot;, &quot;z&quot;, vbBinaryCompare) = LenB(&quot;abcdefghijklmnopqrstuvwxyz&quot;) - 1

So using In String Binary is 70% faster.

Tags: compare, faster, InStrRev, optimise, Right, StrComp, strings
Posted in Programming, Visual Basic | No Comments »

Base64/sexatrigesimal encoding/decoding in VBA/VB6/Visual Basic

Sunday, October 10th, 2010

Here is an implementation of Base 36 enconding/decoding functions is VB6.

'Convert positive integer to a base36 string.
Function base36encode(ByRef number As Long) As String

    Dim alphabet As String
    alphabet = &quot;0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ&quot;
    If number = 0 Then
        base36encode = &quot;0&quot;
        Exit Function
    End If
    base36encode = vbNullString
    Do While number &lt;&gt; 0
        base36encode = Mid(alphabet, number Mod 36 + 1, 1) &amp; base36encode
        number = number \ 36
    Loop

End Function

'Convert base36 string to positive integer.
Function base36decode(ByRef base36 As String) As Long

    Dim alphabet As String
    alphabet = &quot;0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ&quot;

    base36decode = InStr(1, alphabet, Right(base36, 1), vbTextCompare) - 1 'get the last character
    For i = Len(base36) - 1 To 1 Step -1
        base36decode = base36decode + 36 ^ (Len(base36) - i) * (InStr(1, alphabet, Mid(base36, i, 1), vbTextCompare) - 1)
    Next i

End Function

Tags: Base36, decoding, encoding, functions, sexatrigesimal, Visual Basic
Posted in Programming, Visual Basic | No Comments »

Blog of Travis Hydzik

Archive for the ‘Visual Basic’ Category

VBA/VB6 functions to return folder or file type and date modified.

VB6/VBA functions to convert binary string to Base64 string

Photoshop VBScript to automatically resize images

Simple Ping function VBScript

Decimal to Binary functions in Visual Basic

SQL Server Quickest way to Insert Multiple Rows with VB

Visual Basic 6 – quickest way to find first/last character in string

Base64/sexatrigesimal encoding/decoding in VBA/VB6/Visual Basic

Donate

Twitter

Categories

Blogroll

Contact

Pages

Tags

Hydzik.com

SonyaandTravis.com