'RecursiveFolders 'Returns an arraylist of all subfolders within a specified folder

Imports System.IO

'*** EncrytDecrypt Class **************************

Imports System.Security.Cryptography

Imports System.Text 'for UnicodeEncoding

Imports System.Threading 'for Thread.Sleep

'**************************************************

'********** FolderBrowser Class *************

Imports System.Runtime.InteropServices

Imports System.Diagnostics

'*******************************************

Public Class FunctionsAndSubs

'RecursiveFolders 'Returns an arraylist of all subfolders within a specified folder.

'RecursiveFiles 'Returns an arraylist of all files,(with path), within a folder structure.

'EncryptDecryptFile 'Encrypts or Decrypts Files.

'EncryptString 'Returns an encrypted string.

'DecryptString 'Returns a decrypted string.

'Right 'Returns the right portion of a string.

'AppPath 'Returns the application path as a string.

'FolderBrowser 'Returns a "browsed to" folder.

'PreviousInstance 'Returns True if there is a previous instance of the appliation running.

'FillDataTable ‘Returns a DataTable From A DataReader

'*******************************************************************************************************

Function RecursiveFolders(ByVal vFolder As String) As ArrayList

'Function Returns a Sorted ArrayList of Folders

'How To Use This Function....

'*********************************************************

'Dim dirs As ArrayList

'dirs = RecursiveFolders("c:\Program Files")

'Dim files As Array = Directory.GetFiles(dirs(0))

'MsgBox("There Are " & UBound(files) + 1 & " Files In The " & dirs(0) & " Folder")

'Dim i As Integer

'For i = 0 To UBound(files)

' MsgBox(files(i))

'Next

'***************************************************************************************

Dim strSourcePath As String = vFolder

Dim intCounter As Integer = 0

'for string list

Dim lstStringFolders As New ArrayList()

Dim strSubFolders As String()

'for sorted object list

Dim lstSortedFolders As New ArrayList()

'seed string list

lstStringFolders.Add(strSourcePath)

'as a string list - just gives you a list of the folders that exist in the path

Do Until intCounter = lstStringFolders.Count

strSubFolders = System.IO.Directory.GetDirectories(lstStringFolders.Item(intCounter))

lstStringFolders.AddRange(strSubFolders)

intCounter += 1

Loop

'sorts the folders so that related folders (parent/child) are together

lstStringFolders.Sort()

Return lstStringFolders

End Function

'*****************************************************************************************************

'*******************************************************************************************************

Function RecursiveFiles(ByVal vPath As String) As ArrayList

'Sample:

' Dim alst As ArrayList

' alst = RecursiveFiles("c:\program files\")

' Dim i As Integer

' For i = 0 To alst.Count - 1

' If InStr(UCase(alst(i)), "EXCEL.EXE") > 0 Then

' MsgBox("Found " & alst(i))

' End If

' Next

'*****************************************************

Dim strSourcePath As String = vPath

Dim intCounter As Integer = 0

Dim lstFiles As New ArrayList()

'for string list

Dim lstStringFolders As New ArrayList()

Dim strSubFolders As String()

'for sorted object list

Dim lstSortedFolders As New ArrayList()

'seed string list

lstStringFolders.Add(strSourcePath)

'as a string list - just gives you a list of the folders that exist in the path

Do Until intCounter = lstStringFolders.Count

Try

strSubFolders = System.IO.Directory.GetDirectories(lstStringFolders.Item(intCounter))

lstStringFolders.AddRange(strSubFolders)

Catch

'Skipt

End Try

intCounter += 1

Loop

'sorts the folders so that related folders (parent/child) are together

lstStringFolders.Sort()

For intCounter = 0 To lstStringFolders.Count - 1

Try

lstFiles.AddRange(System.IO.Directory.GetFiles(lstStringFolders(intCounter)))

Catch

'Do nothing

End Try

Return lstFiles

End Function

'*****************************************************************************************************

'=== Class Name: EncryptDecrypt =============================================

' Description: Cryptography class for encrypting Files, Strings, Streams

' Project: Cryptography Component - VSM Getting Started, January 2003

' Date Created: 2002.08.28

' Revision History

' Who Date CodeVersion - Comments

' Discussion:

'- This VB.NET component encrypts/decrypts files, strings, and streams, and

' provides password validation via hashing.

'- Crypto Service Providers for Encryption/Decryption:

' . DES: blocksize=64, keysize=64, IV=64 bits=8 bytes

' . RC2: blocksize=64, keysize=40-128 x8 def=128, IV=64 bits

' . TripleDES: blocksize=64, keysize=128-192 x64 def=192, IV=64 bits

' . Rijndael: blocksize=128-256 x64 def=128, keysize=128-256 x64 def=256, IV=128 bits

'- Crypto Service Providers for hashing:

' . MD5: HashSize = 128 bits (16 bytes)

' . SHA1: 160 bits (20 bytes)

' . SHA256: 256 bits (32 bytes)

' . SHA384: 384 bits (48 bytes)

' . SHA512: 512 bits (64 bytes)

'==========================================================================

Public Class EncryptDecryptFile

'Sample:

' Encrypt A File *******************************************************

' Dim MyPassWord As String

' MyPassWord = "HoopDeDoo!"

' Dim oCrypt As New EncryptDecryptFile(MyPassWord)

' Dim b As Boolean

' b = oCrypt.EncryptFile("C:\autoexec.bat", "c:\autoexec.bat.enc")

' Decrypt A File *******************************************************

' Dim MyPassWord2 As String

' MyPassWord2 = "HoopDeDoo!"

' Dim oCrypt2 As New EncryptDecryptFile(MyPassWord2)

' b = oCrypt.DecryptFile("C:\autoexec.bat.enc", "c:\Unencrypted.txt")

' OR USING THE DLL...

' Encrypt The File...

' Dim o As New FunctionsAndSubs.FunctionsAndSubs.EncryptDecryptFile("Daisy The Dog")

' Dim b As Boolean

' b = o.EncryptFile("c:\Temp.txt", "c:\Stevie.txt")

' Decrypt the file...

' Dim o As New FunctionsAndSubs.FunctionsAndSubs.EncryptDecryptFile("Daisy The Dog")

' Dim b As Boolean

' b = o.DecryptFile("c:\Stevie.txt", "c:\Wow.txt")

'**************************************************************************

Private Const CodeVersion As String = "01.00.00"

'class member variables

Private m_sPassPhrase As String

'class private variables

Private mbytKey() As Byte 'crypto key

Private mbytIV() As Byte 'Initialization Vector

Private mbKeyIsSet As Boolean = False

Private mksKeyNotSetException As String = "Crypto passphrase is not set."

Private mksPassphraseTooSmall As String = "PassPhrase length must be at least {0} characters."

'--- class constructors

Public Sub New()

'no passphrase is useful for GetHashString/ValidPassword methods

End Sub

Public Sub New(ByVal CryptoPassPhrase As String)

PassPhrase = CryptoPassPhrase

End Sub

'--- class public properties

'generate and store encryption key & iv from passphrase

Public Property PassPhrase() As String

Get

Return m_sPassPhrase

End Get

Set(ByVal Value As String)

Const iMinLength As Integer = -1 '-1 disables min length

m_sPassPhrase = Value.Trim

'enforce a rule on minimum length if desired here

If (Value.Length > iMinLength) Or (iMinLength = -1) Then

Dim sha2 As New SHA256Managed()

'256 bits = 32 byte key

mbytKey = sha2.ComputeHash(BytesFromString(m_sPassPhrase))

'convert to Base64 for Initialization Vector, take last 16 chars

Dim sKey As String = Convert.ToBase64String(mbytKey)

mbytIV = Encoding.ASCII.GetBytes(sKey.Remove(0, sKey.Length - 16))

mbKeyIsSet = True

sha2 = Nothing

Else

mbKeyIsSet = False

Throw New Exception(String.Format(mksPassphraseTooSmall, (iMinLength + 1).ToString))

End If

End Set

End Property

'--- class public methods

'decrypt a file - replaces input file

Public Function DecryptFile(ByVal TargetFile As String) As Boolean

If mbKeyIsSet Then

Return _DecryptFile(TargetFile, TargetFile)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'decrypt a file - separate output file

Public Function DecryptFile(ByVal EncryptedFile As String, ByVal PlainFile As String) As Boolean

If mbKeyIsSet Then

Return _DecryptFile(EncryptedFile, PlainFile)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'decrypt a stream

Public Function DecryptStream(ByVal EncryptedStream As MemoryStream) As MemoryStream

If mbKeyIsSet Then

Try

'create Crypto Service Provider, set key, transform and crypto stream

Dim oCSP As New RijndaelManaged()

oCSP.Key = mbytKey

oCSP.IV = mbytIV

Dim ct As ICryptoTransform = oCSP.CreateDecryptor()

Dim cs As CryptoStream = New CryptoStream(EncryptedStream, ct, CryptoStreamMode.Read)

'get bytes from encrypted stream

Dim byteArray(EncryptedStream.Length - 1) As Byte

Dim iBytesIn As Integer = cs.Read(byteArray, 0, EncryptedStream.Length)

cs.Close()

'create and write the decrypted output stream

Dim plainStream As New MemoryStream()

plainStream.Write(byteArray, 0, iBytesIn)

Return plainStream

Catch ex As Exception

Debug.WriteLine("DecryptStream Error: " & ex.ToString)

Return Stream.Null

End Try

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'decrypt a string - wrapper without Base64 flag (True by default)

Public Function DecryptString(ByVal EncryptedString As String) As String

If mbKeyIsSet Then

Return _DecryptString(EncryptedString, True)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'decrypt a string - wrapper with Base64 flag

Public Function DecryptString(ByVal EncryptedString As String, ByVal Base64 As Boolean) As String

If mbKeyIsSet Then

Return _DecryptString(EncryptedString, Base64)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'encrypt a file - replaces input file

Public Function EncryptFile(ByVal TargetFile As String) As Boolean

If mbKeyIsSet Then

Return _EncryptFile(TargetFile, TargetFile)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'encrypt a file - separate output file

Public Function EncryptFile(ByVal PlainFile As String, ByVal EncryptedFile As String) As Boolean

If mbKeyIsSet Then

Return _EncryptFile(PlainFile, EncryptedFile)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'encrypt a stream

Public Function EncryptStream(ByVal PlainStream As MemoryStream) As MemoryStream

If mbKeyIsSet Then

Try

'open stream for encrypted data

Dim encStream As New MemoryStream()

'create Crypto Service Provider, set key, transform and crypto stream

Dim oCSP As New RijndaelManaged()

oCSP.Key = mbytKey

oCSP.IV = mbytIV

Dim ct As ICryptoTransform = oCSP.CreateEncryptor()

Dim cs As CryptoStream = New CryptoStream(encStream, ct, CryptoStreamMode.Write)

'get input stream into byte array

Dim byteArray() As Byte = PlainStream.ToArray()

'write input bytes to crypto stream and close up

cs.Write(byteArray, 0, PlainStream.Length)

cs.FlushFinalBlock()

cs.Close()

Return encStream

Catch ex As Exception

Debug.WriteLine("EncryptStream Error: " & ex.ToString)

Return Stream.Null

End Try

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'encrypt a string - wrapper without Base64 flag (True by default)

Public Function EncryptString(ByVal PlainText As String) As String

If mbKeyIsSet Then

Return _EncryptString(PlainText, True)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'encrypt a string - wrapper with Base64 flag

Public Function EncryptString(ByVal PlainText As String, ByVal Base64 As Boolean) As String

If mbKeyIsSet Then

Return _EncryptString(PlainText, Base64)

Else

Throw New Exception(mksKeyNotSetException)

End If

End Function

'calculates the hash of InputValue, returns a string

'- SHA1 hash is always 20 bytes (160 bits)

Public Function GetHashString(ByVal InputValue As String) As String

Try

Dim inputBytes() As Byte = BytesFromString(InputValue)

Dim hashValue() As Byte = New SHA1Managed().ComputeHash(inputBytes)

Return BytesToHexString(hashValue)

Catch ex As Exception

Debug.WriteLine("GetHashString Error: " & ex.ToString)

Return String.Empty

End Try

End Function

'returns True if hash of Passphrase matches HashValue

Public Function ValidPassword(ByVal Passphrase As String, ByVal HashValue As String) As Boolean

Return (GetHashString(Passphrase) = HashValue)

End Function

'--- class private methods

'internal file decryption method

Private Function _DecryptFile(ByVal EncryptedFile As String, ByVal PlainFile As String) As Boolean

Try

'set flag for replacement if filenames are the same, open input file

Dim bReplaceFile As Boolean = (EncryptedFile.ToLower.Trim = _

PlainFile.ToLower.Trim)

Dim fsIn As FileStream = File.OpenRead(EncryptedFile)

'create Crypto Service Provider, set key, transform and crypto stream

Dim oCSP As New RijndaelManaged()

oCSP.Key = mbytKey

oCSP.IV = mbytIV

Dim ct As ICryptoTransform = oCSP.CreateDecryptor()

Dim cs As CryptoStream = New CryptoStream(fsIn, ct, _

CryptoStreamMode.Read)

'get bytes from encrypted file

Dim bytesPlain(fsIn.Length - 1) As Byte

Dim iBytesIn As Integer = cs.Read(bytesPlain, 0, fsIn.Length)

cs.Close()

fsIn.Close()

'create and write the decrypted output file

Dim sPlainFile As String

If bReplaceFile Then

'file is in Windows Temp dir

sPlainFile = Path.GetTempFileName()

Else

sPlainFile = PlainFile

End If

Dim fsOut As FileStream = File.OpenWrite(sPlainFile)

fsOut.Write(bytesPlain, 0, iBytesIn)

fsOut.Close()

'replace input file if flag set

If bReplaceFile Then

Return ReplaceFile(sPlainFile, EncryptedFile)

Else

Return True

End If

Catch ex As Exception

Debug.WriteLine("_DecryptFile Error: " & ex.ToString)

Return False

End Try

End Function

'internal string decryption

Private Function _DecryptString(ByVal EncryptedString As String, ByVal Base64 As Boolean) As String

Try

'put string in byte array depending on Base64 flag

Dim byteArray() As Byte

If Base64 Then

byteArray = Convert.FromBase64String(EncryptedString)

Else

byteArray = BytesFromString(EncryptedString)

End If

'create the streams, decrypt and return a string

Dim msEnc As New MemoryStream(byteArray)

Dim msPlain As MemoryStream = DecryptStream(msEnc)

Return BytesToString(msPlain.GetBuffer)

Catch ex As Exception

Debug.WriteLine("_DecryptString Error: " & ex.ToString)

Return String.Empty

End Try

End Function

'internal file encryption

Private Function _EncryptFile(ByVal PlainFile As String, ByVal EncryptedFile As String) As Boolean

Try

'set flag for replacement if filenames are the same, open files

Dim bReplaceFile As Boolean = (EncryptedFile.ToLower.Trim = PlainFile.ToLower.Trim)

Dim fsIn As FileStream = File.OpenRead(PlainFile)

Dim sEncryptedFile As String

If bReplaceFile Then

sEncryptedFile = Path.GetTempFileName()

Else

sEncryptedFile = EncryptedFile

End If

Dim fsOut As FileStream = File.OpenWrite(sEncryptedFile)

'create Crypto Service Provider, set key, transform and crypto stream

Dim oCSP As New RijndaelManaged()

oCSP.Key = mbytKey

oCSP.IV = mbytIV

Dim ct As ICryptoTransform = oCSP.CreateEncryptor()

Dim cs As CryptoStream = New CryptoStream(fsOut, ct, _

CryptoStreamMode.Write)

'get bytes from input file

Dim bytesPlain(fsIn.Length - 1) As Byte

fsIn.Read(bytesPlain, 0, fsIn.Length)

'write input bytes to crypto stream and close everything

cs.Write(bytesPlain, 0, fsIn.Length)

cs.FlushFinalBlock()

cs.Close()

fsIn.Close()

fsOut.Close()

'replace input file if flag set

If bReplaceFile Then

Return ReplaceFile(sEncryptedFile, PlainFile)

Else

Return True

End If

Catch ex As Exception

Debug.WriteLine("_EncryptFile Error: " & ex.ToString)

Return False

End Try

End Function

'internal string encryption

Private Function _EncryptString(ByVal PlainText As String, ByVal Base64 As Boolean) As String

Try

'put string in byte array

Dim byteArray() As Byte = BytesFromString(PlainText)

'create streams and encrypt

Dim msPlain As New MemoryStream(byteArray)

Dim msEnc As MemoryStream = EncryptStream(msPlain)

'return string depending on Base64 flag

If Base64 Then

Return Convert.ToBase64String(msEnc.ToArray)

Else

Return BytesToString(msEnc.ToArray)

End If

Catch ex As Exception

Debug.WriteLine("_EncryptString Error: " & ex.ToString)

Return String.Empty

End Try

End Function

'returns a Unicode byte array from a string

Private Function BytesFromString(ByVal StringValue As String) As Byte()

Return (New UnicodeEncoding()).GetBytes(StringValue)

End Function

'returns a hex string from a byte array

Private Function BytesToHexString(ByVal byteArray() As Byte) As String

Dim sb As New StringBuilder(40)

Dim bValue As Byte

For Each bValue In byteArray

sb.AppendFormat(bValue.ToString("x2").ToUpper)

Return sb.ToString

End Function

'returns a Unicode string from a byte array

Private Function BytesToString(ByVal byteArray() As Byte) As String

Return (New UnicodeEncoding()).GetString(byteArray)

End Function

'replace a file with the contents of another

Private Function ReplaceFile(ByVal TempFile As String, ByVal TargetFile As String) As Boolean

Dim bStatus As Boolean = False

If CheckWriteAccess(TargetFile) Then

'replace the target file with the temp file

File.Copy(TempFile, TargetFile, True)

bStatus = True

End If

'delete the temp file

File.Delete(TempFile)

Return bStatus

End Function

'Return True when the file is available for writing

'- returns False if output file locked, for example

Private Function CheckWriteAccess(ByVal FileName As String) As Boolean

'2 second delay with 10,200

Dim iCount As Integer = 0 'retry count

Const iLimit As Integer = 10 'retries

Const iDelay As Integer = 200 'msec

While (iCount < iLimit)

Try

Dim fs As FileStream

fs = New FileStream(FileName, FileMode.Append, _

FileAccess.Write, FileShare.None)

fs.Close()

Return True

Catch ex As Exception

Thread.Sleep(iDelay)

Finally

iCount += 1

End Try

End While

Return False

End Function

End Class 'EncryptDecryptFile

'***********************************************************************************************************

'Sample:

' Dim s As String

' s = "Hello World"

' s = EncryptString(s, "mypassword")

' MsgBox("Encrypted Text = " & s)

' MsgBox("Decrypted Text = " & DecryptString(s, "mypassword"))

'*************************************************************************

Private bytIV() As Byte = {121, 241, 10, 1, 90, 74, 11, 39, 9, 91, 45, 78, 189, 211, 133, 62}

'128 bit IV key must be provided

'here a constant is used

Public Function EncryptString(ByVal sValue As String, ByVal sKey As String) As String

Dim bytValue() As Byte

Dim bytKey() As Byte

Dim bytEncoded() As Byte

Dim iLen As Integer, iRemaining As Integer

Dim objMS As New MemoryStream()

Dim objCrypt As CryptoStream

'Value must be within ASCII range (i.e., no DBCS chars)

bytValue = Encoding.ASCII.GetBytes(sValue.ToCharArray)

'key must be 256 bits

iLen = Len(sKey)

If iLen >= 32 Then

sKey = Strings.Left(sKey, 32)

Else

iLen = Len(sKey)

iRemaining = 32 - iLen

sKey = sKey & Strings.StrDup(iRemaining, "X")

End If

bytKey = Encoding.ASCII.GetBytes(sKey.ToCharArray)

Dim objRM As New RijndaelManaged()

Try

'Create the encryptor and write value

'(converted into bytearray) to it

objCrypt = New CryptoStream(objMS, _

objRM.CreateEncryptor(bytKey, bytIV), _

CryptoStreamMode.Write)

objCrypt.Write(bytValue, 0, bytValue.Length)

objCrypt.FlushFinalBlock()

bytEncoded = objMS.ToArray

objMS.Close()

objCrypt.Close()

Catch

End Try

'return encoded value

' (converted from byte Array to base64 string)

Return Convert.ToBase64String(bytEncoded)

End Function 'Encrypt String

'****************************************************************************************************

Public Function DecryptString(ByVal sEncryptedValue As String, ByVal sKey As String) As String

'Sample:

' Dim s As String

' s = "Hello World"

' s = EncryptString(s, "mypassword")

' MsgBox("Encrypted Text = " & s)

' MsgBox("Decrypted Text = " & DecryptString(s, "mypassword"))

'OR

' Dim f As New FunctionsAndSubs.FunctionsAndSubs()

' Dim strE As String 'Encrypted String

' Dim strD As String 'Decrypted String

' strE = f.EncryptString("Steve", "Daisy The Dog")

' strD = f.DecryptString(strE, "Daisy The Dog")

'*****************************************************************

Dim bytValue() As Byte

Dim bytTemp() As Byte

Dim objRM As New RijndaelManaged()

Dim objMS As MemoryStream

Dim objCs As CryptoStream

Dim bytKey() As Byte

Dim iLen As Integer

Dim iRemaining As Integer

Dim intCtr As Integer

'convert base64 encrypted value to byte array

bytValue = Convert.FromBase64String(sEncryptedValue)

'ensure key is 256 bits

iLen = Len(sKey)

If iLen >= 32 Then

sKey = Strings.Left(sKey, 32)

Else

iLen = Len(sKey)

iRemaining = 32 - iLen

sKey = sKey & Strings.StrDup(iRemaining, "X")

End If

bytKey = Encoding.ASCII.GetBytes(sKey.ToCharArray)

ReDim bytTemp(bytValue.Length)

objMS = New MemoryStream(bytValue)

Try

'create decryptor and write value to it

objCs = New CryptoStream(objMS, _

objRM.CreateDecryptor(bytKey, bytIV), _

CryptoStreamMode.Read)

objCs.Read(bytTemp, 0, bytTemp.Length)

objCs.FlushFinalBlock()

objMS.Close()

objCs.Close()

Catch

End Try

'return decypted value

Return Encoding.ASCII.GetString(bytTemp)

End Function 'Decrypt String

'***************************************************************************************************************

Function Right(ByVal s As String, ByVal n As Integer) As String

'************************************************************

'Sample:

' MsgBox(myRight("Steve", 2)) 'Returns ve

'************************************************************

Try

s = s.Substring(s.Length - n)

Catch

s = ""

End Try

Return s

End Function 'Right

'****************************************************************************************************************

'******************************************************************************************

Public Function AppPath() As String

'Sample:

' 'MsgBox(AppPath) 'Returns c:\temp\FunctionsAndSubs\bin\

'*************************************************************

'Returns the current application path, with a trailing slash

Dim strPath As String

strPath = StrReverse(Application.ExecutablePath)

strPath = Mid(strPath, InStr(1, strPath, "\"))

strPath = StrReverse(strPath)

Return strPath

End Function 'AppPath

'***********************************************************************************************************

'****************************************************************************************************************

Public Class FolderBrowser

'Sample:

' Dim oBrowse As FolderBrowser = New FolderBrowser(Me.Handle)

' oBrowse.Title = "Title For Browsing"

' oBrowse.NewUI = True

' oBrowse.ShowStatus = True

' Label1.Text = oBrowse.Browse("c:\can")

' OR

' Dim fb As New FunctionsAndSubs.FunctionsAndSubs.FolderBrowser(Me.Handle)

' Dim s As String = fb.Browse("c:\")

'**********************************************************************

Private Const BFFM_INITIALIZED As Integer = 1

Private Const BFFM_SELCHANGED As Integer = 2

Private Const BFFM_VALIDATEFAILED As Integer = 3

Private Const BFFM_ENABLEOK As Integer = &H465

Private Const BFFM_SETSELECTIONA As Integer = &H466

Private Const BFFM_SETSTATUSTEXT As Integer = &H464

Private Const BIF_RETURNONLYFSDIRS As Short = &H1S

Private Const BIF_DONTGOBELOWDOMAIN As Short = &H2S

Private Const BIF_STATUSTEXT As Short = &H4S

Private Const BIF_RETURNFSANCESTORS As Short = &H8S

Private Const BIF_EDITBOX As Short = &H10S

Private Const BIF_VALIDATE As Short = &H20S

Private Const BIF_USENEWUI As Short = &H40S

Private Const BIF_BROWSEFORCOMPUTER As Short = &H1000S

Private Const BIF_BROWSEFORPRINTER As Short = &H2000S

Private Const BIF_BROWSEINCLUDEFILES As Short = &H4000S

Private Const MAX_PATH As Short = 260

Public Enum START_LOCATION

SL_FLAG_CREATE = &H8000

SL_FLAG_DONT_VERIFY = &H4000

SL_ADMINTOOLS = &H30

SL_ALTSTARTUP = &H1D

SL_APPDATA = &H1A

SL_BITBUCKET = &HA

SL_COMMON_ADMINTOOLS = &H2F

SL_COMMON_ALTSTARTUP = &H1D

SL_COMMON_APPDATA = &H23

SL_COMMON_DESKTOPDIRECTORY = &H19

SL_COMMON_DOCUMENTS = &H2E

SL_COMMON_FAVORITES = &H1F

SL_COMMON_PROGRAMS = &H17

SL_COMMON_STARTMENU = &H16

SL_COMMON_STARTUP = &H18

SL_COMMON_TEMPLATES = &H2D

SL_CONTROLS = &H3

SL_COOKIES = &H21

SL_DESKTOP = &H0

SL_DESKTOPDIRECTORY = &H10

SL_DRIVES = &H11

SL_FAVORITES = &H6

SL_FONTS = &H14

SL_HISTORY = &H22

SL_INTERNET = &H1

SL_INTERNET_CACHE = &H20

SL_LOCAL_APPDATA = &H1C

SL_MYPICTURES = &H27

SL_NETHOOD = &H13

SL_NETWORK = &H12

SL_PERSONAL = &H5

SL_PRINTERS = &H4

SL_PRINTHOOD = &H1B

SL_PROFILE = &H28

SL_PROGRAM_FILES = &H26

SL_PROGRAM_FILES_COMMON = &H2B

SL_PROGRAM_FILES_COMMONX86 = &H2C

SL_PROGRAM_FILESX86 = &H2A

SL_PROGRAMS = &H2

SL_RECENT = &H8

SL_SENDTO = &H9

SL_STARTMENU = &HB

SL_STARTUP = &H7

SL_SYSTEM = &H25

SL_SYSTEMX86 = &H29

SL_TEMPLATES = &H15

SL_WINDOWS = &H24

End Enum

' callback delegate

Private Delegate Function BrowseCB(ByVal hWnd As IntPtr, _

ByVal uMsg As Integer, _

ByVal lParam As Integer, _

ByVal lpData As Integer) As Integer

Private Structure BROWSEINFO

Dim hOwner As IntPtr

Dim pidlRoot As Integer

Dim pszDisplayName As String

Dim lpszTitle As String

Dim ulFlags As Integer

Dim lpfn As BrowseCB

Dim lParam As IntPtr

Dim iImage As Integer

End Structure

<DllImport("ole32.dll")> _

Private Shared Sub CoTaskMemFree(ByVal addr As IntPtr)

End Sub

<DllImport("user32.dll")> _

Private Overloads Shared Function SendMessage(ByVal hWnd As IntPtr, ByVal uMsg As Integer, ByVal lParam As Integer, ByVal lpData As Integer) As Integer

End Function

<DllImport("user32.dll")> _

Private Overloads Shared Function SendMessage(ByVal hWnd As IntPtr, ByVal uMsg As Integer, ByVal lParam As Integer, ByVal lpData As String) As Integer

End Function

<DllImport("shell32.dll", CharSet:=CharSet.Ansi)> _

Private Shared Function SHBrowseForFolder(ByRef lpBrowseInfo As BROWSEINFO) As IntPtr

End Function

<DllImport("shell32.dll", CharSet:=CharSet.Ansi)> _

Private Shared Function SHGetPathFromIDList(ByVal pidl As IntPtr, ByVal pszPath As StringBuilder) As Integer

End Function

<DllImport("shell32.dll", CharSet:=CharSet.Ansi)> _

Private Shared Function SHGetSpecialFolderLocation(ByVal hWnd As IntPtr, ByVal nFolder As Integer, ByRef pidl As Integer) As Integer

End Function

Private m_BI As BROWSEINFO

Private m_Init As Boolean

Private m_NewUI As Boolean = False

Private m_ShowStatus As Boolean = False

Public Sub New(ByVal handle As IntPtr)

m_BI.hOwner = handle

m_BI.lpfn = AddressOf BrowseCallbackProc

End Sub

Public Overloads Function Browse() As String

m_BI.pidlRoot = 0

Return DoBrowse("")

End Function

Public Overloads Function Browse(ByVal startPath As String) As String

m_BI.pidlRoot = 0

Return DoBrowse(startPath)

End Function

Public Overloads Function Browse(ByVal SL As START_LOCATION) As String

SHGetSpecialFolderLocation(m_BI.hOwner, SL, m_BI.pidlRoot)

Return DoBrowse("")

End Function

Private Function DoBrowse(ByVal startPath As String) As String

Dim result As IntPtr

Dim sel As String

m_BI.ulFlags = BIF_RETURNONLYFSDIRS

If m_NewUI Then m_BI.ulFlags += BIF_USENEWUI

If m_ShowStatus Then m_BI.ulFlags += BIF_STATUSTEXT

m_BI.lParam = Marshal.StringToHGlobalAnsi(startPath)

m_Init = True

result = SHBrowseForFolder(m_BI)

sel = GetFSPath(result)

Call CoTaskMemFree(result)

Return sel

End Function

Public Property Title() As String

Get

Return m_BI.lpszTitle

End Get

Set(ByVal Value As String)

m_BI.lpszTitle = Value

End Set

End Property

Public Function BrowseCallbackProc(ByVal hWnd As IntPtr, _

ByVal uMsg As Integer, _

ByVal lParam As Integer, _

ByVal lpData As Integer) As Integer

If uMsg = BFFM_INITIALIZED Then

SendMessage(hWnd, BFFM_SETSELECTIONA, 1, lpData)

m_Init = False

ElseIf uMsg = BFFM_SELCHANGED And Not m_Init Then

SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, GetFSPath(New IntPtr(lParam)))

End If

End Function

Private Function GetFSPath(ByVal pidl As IntPtr) As String

Dim sb As New StringBuilder(MAX_PATH)

If pidl.Equals(IntPtr.Zero) Then

Return ""

Else

If SHGetPathFromIDList(pidl, sb) = 1 Then

Return sb.ToString()

End If

End Function

Public Property NewUI() As Boolean

Get

Return m_NewUI

End Get

Set(ByVal Value As Boolean)

m_NewUI = Value

End Set

End Property

Public Property ShowStatus() As Boolean

Get

Return m_ShowStatus

End Get

Set(ByVal Value As Boolean)

m_ShowStatus = Value

End Set

End Property

End Class 'FolderBrowser

'************************************************************************************************

'********* Previous Instance *************************************************************************

'Sample:

'If PrevInstance() = True Then

' Get all previous instances

' Dim Processes() As Process

' Processes = Diagnostics.Process.GetProcessesByName(Diagnostics.Process.GetCurrentProcess.ProcessName)

' Activate the first instance

' AppActivate(Processes(0).Id)

' Exit the current instance

' Application.Exit()

'End If

Function PrevInstance() As Boolean

If Diagnostics.Process.GetProcessesByName(Diagnostics.Process.GetCurrentProcess.ProcessName).Length > 1 Then

Return True

Else

Return False

End If

End Function 'PreviousInstance

' *****************************************************************************************************

'Fill Data Table Function**************************************

' Inputs:DataReader

' Returns:DataTable

' Assumes:Simply pass the function a DataReader object and it will return a DataTable object.

'**************************************

'Example....

'Dim objConn As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & "c:\inetpub\wwwroot\cp\cp.mdb")

'Dim strSQL As String = "Select * From Candidate"

'Dim objCommand As New OleDbCommand(strSQL, objConn)

'objConn.Open()

'Dim objDR As OleDbDataReader = objCommand.ExecuteReader

'Dim dt As DataTable = FillDataTable(objDR)

' MsgBox(dt.Rows(0).Item("Lname"))

Public Function FillDataTable(ByRef dataReader As IDataReader)

Dim i As Integer

Dim intNumCols As Integer

Dim dataTable As New DataTable()

Dim dtCols As New DataTable()

Dim drow As DataRow

'Insert datareader schema into datatable(dtCols)

dtCols = dataReader.GetSchemaTable()

intNumCols = dtCols.Rows.Count - 1

'Loop thru dtCols, inserting columns into dataTable

For i = 0 To intNumCols

dataTable.Columns.Add(dtCols.Rows(i)("ColumnName"))

'Iterate thru datareader, adding rows to datatable

While dataReader.Read

drow = dataTable.NewRow

'Iterate thru columns datatable

For i = 0 To intNumCols

drow(i) = dataReader(dtCols.Rows(i)("ColumnName"))

dataTable.Rows.Add(drow)

End While

dataReader.Close()

dtCols.Rows.Clear()

Return dataTable

End Function

End Class