Show a list View in Group

This will show the list view Group

Dim ObjListItem As ListViewItem

Dim ObjListViewGroup As ListViewGroup

ObjListViewGroup = New ListViewGroup("File Name :" & FileName)

LvwBills.Groups.Add(ObjListViewGroup)

For iCount = 0 To 10                

                ObjListItem = New ListViewItem(ObjListViewGroup)

                ObjListItem.SubItems.Add("ABCD"              

                LvwBills.Items.Add(ObjListItem)

                PFileProcessBar.Value = iCount

Next

File opertation in VB.Net

imports system.io

Public Class Form1

    Public Sub MaintainintoFile(Optional ByVal StringtoWrite As String = "Error Not Trapped")

        Try

            Dim StartLog As Boolean

            Dim FName As String

            Dim LogDirName As String

            Dim BaseErr As String = ""

            Dim fs As FileStream

            Dim fileWrite As StreamWriter

            Dim dir As String

            StartLog = True

            dir = Application.StartupPath

            LogDirName = dir & "\Log\"

            If Not Directory.Exists(LogDirName) Then Directory.CreateDirectory(LogDirName)

            FName = LogDirName & "Log.log"

            If File.Exists(FName) Then

                fs = New FileStream(FName, FileMode.Append, FileAccess.Write, FileShare.Read)

                fileWrite = New StreamWriter(fs)

            Else

                fs = New FileStream(FName, FileMode.OpenOrCreate, FileAccess.Write, FileShare.Read)

                fileWrite = New StreamWriter(fs)

            End If

            fileWrite.Write(vbNewLine & CStr(Now) & ":" & StringtoWrite)

            fileWrite.Close()

            Exit Sub

        Catch ex As Exception

            MsgBox(Err.Description)

        End Try

    End Sub

End Class

Download a File From an URL

Imports System
Imports System.Configuration
Imports System.Resources ' Resource readers
Imports System.Net.WebClient
Imports System.IO

Public Class Form1

Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

Dim flag As Boolean = False
Dim name As String = ""
Dim number As Integer = 0
Dim FTPC As New System.Net.WebClient
Dim callerFilename As String
Dim Downloadto As String
Dim DownloadtoFolder As String
callerFilename = "default.aspx"
DownloadtoFolder = Application.StartupPath & "\"
Downloadto = DownloadtoFolder & "\" & callerFilename
Dim strURL = "http://www.yourwebsite.in/default.aspx"
MsgBox(strURL)
Dim sysWebClient As System.Net.WebClient = New System.Net.WebClient
If Not Directory.Exists(DownloadtoFolder) Then
Directory.CreateDirectory(DownloadtoFolder)
End If
sysWebClient.DownloadFile(strURL, Downloadto)
End Sub
End Class

Get the name and type of column of a table

   Public sub GetColumns(ByVal sTableName As String, ByVal ListBoxObject As ListView) 

               

                Dim iCount As Integer

                Dim ObjListviewItem As ListViewItem

                Dim sSQL As String = "Select * From " & sTableName & " Where 1 = 2"

                Dim oCmd As Odbc.OdbcCommand = New OdbcCommand(sSQL, ObjCon)               

                Dim oRS As Odbc.OdbcDataReader = oCmd.ExecuteReader

                ListBoxObject.Items.Clear()

                For iCount = 0 To oRS.FieldCount - 1

                    ObjListviewItem = ListBoxObject.Items.Add(oRS.GetName(iCount), 0)

                    ObjListviewItem.SubItems.Add(oRS.GetFieldType(iCount).ToString)

                Next iCount

                oRS.Close()              

            Catch ex As Exception

               msgbox( Err.Description)

            End Try

        End Function

    End Class

List Of Table

 Private sub GetTables(ByVal sDatabaseName As String, ByVal ListBoxObject As ListBox)

            Try

               

                Dim sSQL As String = "show tables in " & sDatabaseName

                Dim oCmd As Odbc.OdbcCommand = ObjCon.CreateCommand

                oCmd.CommandText = sSQL

                Dim oRS As Odbc.OdbcDataReader = oCmd.ExecuteReader

                Do While oRS.Read

                    ListBoxObject.Items.Add(oRS(0))

                Loop

                oRS.Close()

               

            Catch ex As Exception

                msgbox(err.description)

            End Try

     End Function

List of Databse

How To List the Databse

Public sub DatabaseList(ByVal ListBoxObject As Object)

Try

If ObjCon.State = ConnectionState.Open Then

Dim sSQL As String = "show databases"

Dim oCmd As Odbc.OdbcCommand = ObjCon.CreateCommand

oCmd.CommandText = sSQL

Dim oRS As Odbc.OdbcDataReader = oCmd.ExecuteReader

Do While oRS.Read

ListBoxObject.Items.Add(oRS(0))

Loop

oRS.Close()

End If

Catch ex As Exception

msgbox( Err.Description)

End Try

End Function

Registry access

Created By Kumar

Get Device Info vb.net

Get Process ID ,MAC Address ,Volume Serial No.,Mother Board ID

Imports System.Management

Private Function GetProcessorId() As String
Dim strProcessorId As String = String.Empty
Dim query As New SelectQuery("Win32_processor")
Dim search As New ManagementObjectSearcher(query)
Dim info As ManagementObject

For Each info In search.Get()
strProcessorId = info("processorId").ToString()
Next
Return strProcessorId
End Function

Private Function GetMACAddress() As String
Dim mc As ManagementClass = New ManagementClass("Win32_NetworkAdapterConfiguration")
Dim moc As ManagementObjectCollection = mc.GetInstances()
Dim MACAddress As String = String.Empty
For Each mo As ManagementObject In moc
If (MACAddress.Equals(String.Empty)) Then
If CBool(mo("IPEnabled")) Then MACAddress = mo("MacAddress").ToString()
mo.Dispose()
End If
MACAddress = MACAddress.Replace(":", String.Empty)
Next
Return MACAddress
End Function



Private Function GetVolumeSerial(Optional ByVal strDriveLetter As String = "C") As String
Dim disk As ManagementObject = New ManagementObject(String.Format("win32_logicaldisk.deviceid=""{0}:""", strDriveLetter))
disk.Get()
Return disk("VolumeSerialNumber").ToString()
End Function
Private Function GetMotherBoardID() As String
Dim strMotherBoardID As String = String.Empty
Dim query As New SelectQuery("Win32_BaseBoard")
Dim search As New ManagementObjectSearcher(query)
Dim info As ManagementObject
For Each info In search.Get()
strMotherBoardID = info("SerialNumber").ToString()
Next
Return strMotherBoardID
End Function


Convert text to Image in vb.net


Imports System.Drawing
Imports System.Drawing.Bitmap
Imports System.Drawing.Graphics
Imports System.Drawing.Drawing2D
Imports System.Drawing.Imaging
Imports System.Drawing.Image


Private Sub a()
Dim Text As String = "Rajiv Ranjan"
Dim FontColor As Color = Color.Red
Dim FileName As String = "Image1"
Dim objBitmap As New Bitmap(Width, Height)
Dim objGraphics As Graphics = Graphics.FromImage(objBitmap)
Dim objColor As Color
Dim objFont As New Font(FontName, FontSize)

Dim objBrushForeColor As New SolidBrush(FontColor)
Dim objBrushBackColor As New SolidBrush(BackColor)

objGraphics.FillRectangle(objBrushBackColor, 0, 0, Width, Height)
objGraphics.DrawString(TextBox1.Text.ToString, objFont, objBrushForeColor, objPoint)
objBitmap.Save(Application.StartupPath & FileName & ".JPG", ImageFormat.Jpeg)



How to Delete Shortcut


Private Sub DeleteShortCut()
Dim fso As New Scripting.FileSystemObject
Dim DPath As String = Environment.GetFolderPath(Environment.SpecialFolder.Desktop)
Try
fso.DeleteFile(DPath & "\ABC.lnk", True)
Catch ex As Exception
Try
dpath = Strings.Left(dpath, 26)
fso.DeleteFile(DPath & "All Users\Desktop\ABC.lnk", True)
Catch
End Try
End Try
end Sub


Some Namespaces and their use

Some Namespaces and their use:
System: Includes essential classes and base classes for commonly used data types, events, exceptions and so on(Base Class of all)

System.XML: Includes classes for XML support

System.Windows.Forms: Includes classes for creating Windows based forms

System.IO: Includes classes for data access with Files(Input and Output Operation)

System.Data.OleDb: Includes classes that support the OLEDB .NET

System.Data.SqlClient: Includes classes that support the SQL Server .NET provider

How to create a function

How to create a function
public function functionname(argument ) returntype

end function

Get OS information in VB.Net

?How to Get OS Version in VB.Net
'''' This Function Is written in vb.net Which will return the version of OS

Public Function GetOSVersion() As String
Dim osInfo As OperatingSystem
Dim sAns As String
osInfo = System.Environment.OSVersion
With osInfo
Select Case .Platform
Case .Platform.Win32Windows
Select Case (.Version.Minor)
Case 0
sAns = "Windows 95"
Case 10
If .Version.Revision.ToString() = "2222A" Then
sAns = "Windows 98 Second Edition"
Else
sAns = "Windows 98"
End If
Case 90
sAns = "Windows Me"
End Select
Case .Platform.Win32NT

Select Case (.Version.Major)
Case 3
sAns = "Windows NT 3.51"
Case 4
sAns = "Windows NT 4.0"
Case 5

If .Version.Minor = 0 Then
sAns = "Windows 2000"
ElseIf .Version.Minor = 1 Then
sAns = "Windows XP"
ElseIf .Version.Minor = 2 Then
sAns = "Windows Server 2003"
Else 'Future version maybe update 'as needed sAns = "Unknown Version"
End If
Case 6
sAns = "Windows Vista"
End Select
End Select
End With
Return sAns
End Function

instance of an application in VB.Net

?How to Check the instance of an application in VB.Net

''' Check whether the instance of an application is running or not

Private Function CheckInstanceOfApplication() As Boolean

        CheckInstanceOfApplication= False

Dim AllProcesses As Process()
AllProcesses = Process.GetProcessesByName(Process.GetCurrentProcess.ProcessName)
If (AllProcesses.Length > 1) Then
Return True
End If
End Function

'''''''''''''''' End Here

Get O.S. Information

''How to get OS Info in VB ?

Option Explicit
Private Type OSVERSIONINFO

dwOSVersionInfoSize As Long

dwMajorVersion As Long

dwMinorVersion As Long

dwBuildNumber As Long

dwPlatformId As Long

szCSDVersion As String * 128

End Type

'in module or gen decl.
Public Declare Function GetVersionExA Lib "kernel32" _(lpVersionInformation As OSVERSIONINFO) As Integer
' function to get OS Version
Public Function getosVersion() As String
Dim osInfo As OSVERSIONINFODim lRV As Integer
osInfo.dwOSVersionInfoSize = 148
osInfo.szCSDVersion = Space$(128)
lRV = GetVersionExA(osInfo)
With osInfo
Select Case .dwPlatformId
Case 1
If .dwMinorVersion = 0
Then getosVersion = "95"
ElseIf .dwMinorVersion = 10
Then getosVersion = "98"
End
IfCase 2
If .dwMajorVersion = 3 Then
getosVersion = "3.51"
ElseIf .dwMajorVersion = 4 Then
getosVersion = "4.0"
ElseIf .dwMajorVersion = 5 Then
If .dwMinorVersion = 0 Then
getosVersion = "2000"
ElseIf .dwMinorVersion = 1 Then
getosVersion = "WinXP/.NET Server"
End If
End If
Case Else getosVersion = "Failed"
End Select
End With
End Function

''End here

Use of Internet Explorer and MSHTML object

How to use Internet Explorer controls in vb ?
Dim ie As New InternetExplorer
Dim hdoc As mshtml.IHTMLDocument
Dim iHTMLCol As IHTMLElementCollection
Dim iHTMLEle As IHTMLElement

ie.navigate ("about:blank")
ie.Visible = False
Do

Loop Until Not ie.Busy
str = ie.document.body.innerText
If str Like "*cannot be*" Then
msgbox "Check For Internet Connection"
End If

str = ie.document.body.innerText
If str Like "*cannot be*" Then
ValidatePANInformation = "Check For Internet Connection"
Exit Function
End If

Set hdoc = ie.document
Set iHTMLCol = hdoc.getElementsByTagName("input")
Do
For Each iHTMLEle In iHTMLCol
If iHTMLEle.name = "abc" Then
iHTMLEle.innerText = " "
End If

If iHTMLEle.name = "XYZ" Then
iHTMLEle.Click
End If
Next
Loop While SetValue <> True

Do

Loop Until Not ie.Busy

Set iHTMLCol = hdoc.getElementsByTagName("span")
Do

For Each iHTMLEle In iHTMLCol
If iHTMLEle.id = "nameofcontrol" Then
'MsgBox iHTMLEle.innerText
End If
Next
Loop While SetValue <> True
ie.Quit

How To Register an Extension

How to Register an Extension in VB 6.0 ?


Public Sub RegisterRJVExtension()

On Error Resume Next

Dim reg As Registry

Set reg = New Registry

Call reg.UpdateKey(REGToolRootTypes.HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\.rjv", "Application", "RJVOpener.exe")

Call reg.UpdateKey(REGToolRootTypes.HKEY_CLASSES_ROOT, "Applications\RJVOpener.exe\Shell\open\command", "", App.Path & "\RJVOpener.exe %1")

Set reg = Nothing

End Sub

How to register an extension in vb.net?
Public Sub RegExtension() Dim reg As Microsoft.Win32.Registry Dim regkey As Microsoft.Win32.RegistryKey regkey = Microsoft.Win32.Registry.CurrentUser regkey = Microsoft.Win32.Registry.CurrentUser.CreateSubKey("Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\.lux", Microsoft.Win32.RegistryKeyPermissionCheck.ReadWriteSubTree) regkey.SetValue("Application", "ShowMessage.exe", Microsoft.Win32.RegistryValueKind.String) Dim regkey1 As Microsoft.Win32.RegistryKey regkey1 = Microsoft.Win32.Registry.ClassesRoot regkey1 = Microsoft.Win32.Registry.ClassesRoot.CreateSubKey("Applications\ShowMessage.exe\Shell\open\command", Microsoft.Win32.RegistryKeyPermissionCheck.ReadWriteSubTree) regkey1.SetValue("", Application.StartupPath & "\ShowMessage.exe %1", Microsoft.Win32.RegistryValueKind.String)
End Sub

Register a Port and Exe



Public Sub RegisterportandSoftware()
Dim reg As Registry
'''' Register Your Port ( No need to off your firewall)
Set reg = New Registry
Call reg.UpdateKey(REGToolRootTypes.HKEY_LOCAL_MACHINE, "SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile\GloballyOpenPorts\List", "3306:TCP", "3306:TCP:*:Enabled:EnterYourText")
Call reg.UpdateKey(REGToolRootTypes.HKEY_LOCAL_MACHINE, "SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile\GloballyOpenPorts\List", "1412:TCP", "1412:TCP:*:Enabled:EnteryourPortName")
'''''' Reg ister Your Application
Call reg.UpdateKey(REGToolRootTypes.HKEY_LOCAL_MACHINE, "SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\StandardProfile\AuthorizedApplications\List", App.Path, App.Path & ":*:Enabled:EnteryourApplicationName")
Set reg = Nothing
End Sub


Get Process Id/ Thread ID In Visual Basic

How to get Process id and Thread id in Visual Basic?

Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long


Public Property Get ThreadID() As VariantThreadID = GetCurrentThreadIdEnd Property Public Property Get ProcessID() As Variant ProcessID = GetCurrentProcessId End Property

Get User Name

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _ (ByVal lpBuffer As String, nSize As Long) As Long
Public Property Get UserName() As Variant Dim sBuffer As String Dim lSize As Long sBuffer = Space$(255) lSize = Len(sBuffer) Call GetUserName(sBuffer, lSize) UserName = Left$(sBuffer, lSize) End Property

Get Computer Name

Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal sBuffer As String, lSize As Long) As Long
Public Function NameOfPC(MachineName As String) As Long Dim NameSize As Long Dim X As Long MachineName = Space$(16) NameSize = Len(MachineName) X = GetComputerName(MachineName, NameSize)End Function

Zip And UnZip in VB 6.0

Call ZipFile("targetPath","SourcePath")
Call UnzipFile("targetPath","SourcePath")
''''''''' For Zip
Private Sub ZipFile(ByVal strTargetPath As String, ByVal strSourcePath As String)
Dim oZip As CGZipFiles
Set oZip = New CGZipFiles
With oZip
.ZipFileName = strTargetPath
.UpdatingZip = False
.AddFile(strSourcePath)
If .MakeZipFile <> 0 Then
MsgBox.GetLastMessage() ' any errors
End If
End With
Set oZip = Nothing
Exit Sub
End Sub

''' for UnZip
Private Sub UnzipFile(ByVal strZipName As String, ByVal strExtractDir As String)
Dim oUnZip As CGUnzipFiles
oUnZip = New CGUnzipFiles
With oUnZip
.ZipFileName = strZipName
.ExtractDir = strExtractDir
.HonorDirectories = False
If .Unzip <> 0 Then
MsgBox.GetLastMessage()
End If
End With
oUnZip = Nothing
Exit Sub
End Sub
''''' Class For Ziping
Option Explicit
Public Enum ZTranslate
CRLFtoLF = 1
LFtoCRLF = 2
End Enum
Private mCollection As Collection
Private miRecurseFolders As Integer
Private msZipFileName As String
Private miEncrypt As Integer
Private miSystem As Integer
'
Private msRootDirectory As String
Private miVerbose As Integer
Private miQuiet As Integer
Private miTranslateCRLF As ZTranslate
'
Private miUpdateZip As Integer
Private Sub Class_Initialize()
Set mCollection = New Collection
mCollection.Add("querty", "querty")
miEncrypt = 0
miSystem = 0
msRootDirectory = "\"
miQuiet = 0
miUpdateZip = 0
End Sub
Private Sub Class_Terminate()
Set mCollection = Nothing
End Sub
Public Property Get RecurseFolders() As Boolean
RecurseFolders = miRecurseFolders = 1
End Property
Public Property Let RecurseFolders(ByVal bRecurse As Boolean)
miRecurseFolders = IIf(bRecurse, 1, 0)
End Property
Public Property Get ZipFileName() As String
ZipFileName = msZipFileName
End Property
Public Property Let ZipFileName(ByVal sZipFileName As String)
msZipFileName = sZipFileName '& vbNullChar
End Property
Public Property Get Encrypted() As Boolean
Encrypted = miEncrypt = 1
End Property
Public Property Let Encrypted(ByVal bEncrypt As Boolean)
miEncrypt = IIf(bEncrypt, 1, 0)
End Property
Public Property Get IncludeSystemFiles() As Boolean
IncludeSystemFiles = miSystem = 1
End Property
Public Property Let IncludeSystemFiles(ByVal bInclude As Boolean)
miSystem = IIf(bInclude, 1, 0)
End Property
Public Property Get ZipFileCount() As Long
If mCollection Is Nothing Then
ZipFileCount = 0
Else
ZipFileCount = mCollection.Count - 1
End If
End Property

Public Property Get RootDirectory() As String
RootDirectory = msRootDirectory
End Property
Public Property Let RootDirectory(ByVal sRootDir As String)
msRootDirectory = sRootDir ' & vbNullChar
End Property
Public Property Get UpdatingZip() As Boolean
UpdatingZip = miUpdateZip = 1
End Property
Public Property Let UpdatingZip(ByVal bUpdating As Boolean)
miUpdateZip = IIf(bUpdating, 1, 0)
End Property
Public Function AddFile(ByVal sFileName As String)
Dim lCount As Long
Dim sFile As String
On Error Resume Next
sFile = mCollection.Item(sFileName)
If Len(sFile) = 0 Then
Err.Clear
On Error GoTo 0
mCollection.Add sFileName, sFileName
Else
On Error GoTo 0
Err.Raise vbObjectError + 2001, "CGZip::AddFile", "File is already in Zip List"
End If
End Function
Public Function RemoveFile(ByVal sFileName As String)
Dim lCount As Long
Dim sFile As String
On Error Resume Next
sFile = mCollection.Item(sFileName)
If Len(sFile) = 0 Then
Err.Raise vbObjectError + 2002, "CGZip::RemoveFile", "File is not in Zip List"
Else
mCollection.Remove sFileName
End If
End Function
Public Function MakeZipFile() As Long
Dim zFileArray As ZIPnames
Dim sFileName As Variant
Dim lFileCount As Long
Dim iIgnorePath As Integer
Dim iRecurse As Integer
On Error GoTo vbErrorHandler

lFileCount = 0
For Each sFileName In mCollection
zFileArray.s(lFileCount) = sFileName
lFileCount = lFileCount + 1
Next
MakeZipFile = VBZip(CInt(lFileCount), msZipFileName, _
zFileArray, iIgnorePath, _
miRecurseFolders, miUpdateZip, _
0, msRootDirectory)
Exit Function
vbErrorHandler:
MakeZipFile = -99
Err.Raise Err.Number, "CGZipFiles::MakeZipFile", Err.Description
End Function
Public Function GetLastMessage() As String
GetLastMessage = msOutput
End Function
Private Sub cmdZip_Click()
Dim oZip As CGZipFiles

Set oZip = New CGZipFiles
With oZip
.ZipFileName = App.Path & "\ZIPTEST.ZIP"

.UpdatingZip = False
.AddFile App.Path & "\*.*"
If .MakeZipFile <> 0 Then
MsgBox .GetLastMessage ' any errors
End If
End With
Set oZip = Nothing
MsgBox "\ZIPTEST.ZIP Created Successfully"
Exit Sub

End Sub

''''''''''''' Class For Unziping
Option Explicit
'
'
Public Enum ZMessageLevel
All = 0
less = 1
NoMessages = 2
End Enum
Public Enum ZExtractType
Extract = 0
ListContents = 1
End Enum
Public Enum ZPrivilege
Ignore = 0
ACL = 1
Privileges = 2
End Enum
Private miExtractNewer As Integer ' 1 = Extract Only Newer, Else 0
Private miSpaceUnderScore As Integer ' 1 = Convert Space To Underscore, Else 0
Private miPromptOverwrite As Integer ' 1 = Prompt To Overwrite Required, Else 0
Private miQuiet As ZMessageLevel ' 2 = No Messages, 1 = Less, 0 = All
Private miWriteStdOut As Integer ' 1 = Write To Stdout, Else 0
Private miTestZip As Integer ' 1 = Test Zip File, Else 0
Private miExtractList As ZExtractType ' 0 = Extract, 1 = List Contents
Private miExtractOnlyNewer As Integer ' 1 = Extract Only Newer, Else 0
Private miDisplayComment As Integer ' 1 = Display Zip File Comment, Else 0
Private miHonorDirectories As Integer ' 1 = Honor Directories, Else 0
Private miOverWriteFiles As Integer ' 1 = Overwrite Files, Else 0
Private miConvertCR_CRLF As Integer ' 1 = Convert CR To CRLF, Else 0
Private miVerbose As Integer ' 1 = Zip Info Verbose
Private miCaseSensitivity As Integer ' 1 = Case Insensitivity, 0 = Case Sensitivity
Private miPrivilege As ZPrivilege ' 1 = ACL, 2 = Privileges, Else 0
Private msZipFileName As String ' The Zip File Name
Private msExtractDir As String ' Extraction Directory, Null If Current Directory
Public Property Get ExtractNewer() As Boolean
ExtractNewer = miExtractNewer = 1
End Property
Public Property Let ExtractNewer(ByVal bExtractNewer As Boolean)
miExtractNewer = IIf(bExtractNewer, 1, 0)
End Property
Public Property Get SpaceToUnderScore() As Boolean
SpaceToUnderScore = miSpaceUnderScore = 1
End Property
Public Property Let SpaceToUnderScore(ByVal bConvert As Boolean)
miSpaceUnderScore = IIf(bConvert, 1, 0)
End Property
Public Property Get PromptOverwrite() As Boolean
PromptOverwrite = miPromptOverwrite = 1
End Property
Public Property Let PromptOverwrite(ByVal bPrompt As Boolean)
miPromptOverwrite = IIf(bPrompt, 1, 0)
End Property
Public Property Get MessageLevel() As ZMessageLevel
MessageLevel = miQuiet
End Property
Public Property Let MessageLevel(ByVal iLevel As ZMessageLevel)
miQuiet = iLevel
End Property
Public Property Get WriteToStdOut() As Boolean
WriteToStdOut = miWriteStdOut = 1
End Property
Public Property Let WriteToStdOut(ByVal bWrite As Boolean)
miWriteStdOut = IIf(bWrite, 1, 0)
End Property
Public Property Get TestZip() As Boolean
TestZip = miTestZip = 1
End Property
Public Property Let TestZip(ByVal bTest As Boolean)
miTestZip = IIf(bTest, 1, 0)
End Property
Public Property Get ExtractList() As ZExtractType
ExtractList = miExtractList
End Property
Public Property Let ExtractList(ByVal zExType As ZExtractType)
miExtractList = zExType
End Property
Public Property Get ExtractOnlyNewer() As Boolean
ExtractOnlyNewer = miExtractOnlyNewer = 1
End Property
Public Property Let ExtractOnlyNewer(ByVal bOnlyNewer As Boolean)
miExtractOnlyNewer = IIf(bOnlyNewer, 1, 0)
End Property
Public Property Get DisplayComment() As Boolean
DisplayComment = miDisplayComment = 1
End Property
Public Property Let DisplayComment(ByVal bDisplay As Boolean)
miDisplayComment = IIf(bDisplay, 1, 0)
End Property
Public Property Get HonorDirectories() As Boolean
HonorDirectories = miHonorDirectories = 1
End Property
Public Property Let HonorDirectories(ByVal bHonor As Boolean)
miHonorDirectories = IIf(bHonor, 1, 0)
End Property
Public Property Get OverWriteFiles() As Boolean
OverWriteFiles = miOverWriteFiles = 1
End Property
Public Property Let OverWriteFiles(ByVal bOverWrite As Boolean)
miOverWriteFiles = IIf(bOverWrite, 1, 0)
End Property
Public Property Get ConvertCRtoCRLF() As Boolean
ConvertCRtoCRLF = miConvertCR_CRLF = 1
End Property
Public Property Let ConvertCRtoCRLF(ByVal bConvert As Boolean)
miConvertCR_CRLF = IIf(bConvert, 1, 0)
End Property
Public Property Get Verbose() As Boolean
Verbose = miVerbose = 1
End Property
Public Property Let Verbose(ByVal bVerbose As Boolean)
miVerbose = IIf(bVerbose, 1, 0)
End Property
Public Property Get CaseSensitive() As Boolean
CaseSensitive = miCaseSensitivity = 1
End Property
Public Property Let CaseSensitive(ByVal bCaseSensitive As Boolean)
miCaseSensitivity = IIf(bCaseSensitive, 1, 0)
End Property
Public Property Get Privilege() As ZPrivilege
Privilege = miPrivilege
End Property
Public Property Let Privilege(ByVal zPriv As ZPrivilege)
miPrivilege = zPriv
End Property
Public Property Get ZipFileName() As String
ZipFileName = msZipFileName
End Property
Public Property Let ZipFileName(ByVal sZipFileName As String)
msZipFileName = sZipFileName
End Property
Public Property Get ExtractDir() As String
ExtractDir = msExtractDir
End Property
Public Property Let ExtractDir(ByVal sExtractDir As String)
msExtractDir = sExtractDir
End Property
Public Function Unzip(Optional sZipFileName As String, _
Optional sExtractDir As String) As Long
On Error GoTo vbErrorHandler
Dim lRet As Long
If Len(sZipFileName) > 0 Then
msZipFileName = sZipFileName
End If
If Len(sExtractDir) > 0 Then
msExtractDir = sExtractDir
End If
lRet = VBUnzip(msZipFileName, msExtractDir, miExtractNewer, _
miSpaceUnderScore, miPromptOverwrite, CInt(miQuiet), _
miWriteStdOut, miTestZip, CInt(miExtractList), _
miExtractOnlyNewer, miDisplayComment, miHonorDirectories, _
miOverWriteFiles, miConvertCR_CRLF, miVerbose, _
miCaseSensitivity, CInt(miPrivilege))
Unzip = lRet
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "CGUnZipFiles::Unzip", Err.Description
End Function
Private Sub Class_Initialize()
miExtractNewer = 0
miSpaceUnderScore = 0
miPromptOverwrite = 0
miQuiet = NoMessages
miWriteStdOut = 0
miTestZip = 0
miExtractList = Extract
miExtractOnlyNewer = 0
miDisplayComment = 0
miHonorDirectories = 1
miOverWriteFiles = 1
miConvertCR_CRLF = 0
miVerbose = 0
miCaseSensitivity = 1
miPrivilege = Ignore
End Sub
Public Function GetLastMessage() As String
GetLastMessage = msOutput
End Function

Zip & UnZip in vb.net

Module UnZipAndZip
Public Sub WebZip(ByVal FilePath As String, ByVal CompressedFilePath As String)
Dim FL As Scripting.File
Dim FSO As New Scripting.FileSystemObject()
Dim FPstr, CMPstr As String
Dim TS As Scripting.TextStream
FL = FSO.GetFile(FilePath)
FPstr = FL.ShortPath
FL = Nothing
If System.IO.File.Exists(CompressedFilePath) = False Then
TS = FSO.CreateTextFile(CompressedFilePath, True)
FL = FSO.GetFile(CompressedFilePath)
CMPstr = FL.ShortPath
TS.Close()
FL = Nothing
System.IO.File.Delete(CompressedFilePath)
FSO = Nothing
Else
FL = FSO.GetFile(CompressedFilePath)
CMPstr = FL.ShortPath
FL = Nothing
FSO = Nothing
End If
Microsoft.VisualBasic.Interaction.Shell(Application.StartupPath & "\DB1.Exe -a " & CMPstr & " " & FPstr, AppWinStyle.Hide, True)
End Sub
Public Sub WebUnZip(ByVal CompressedFilePath As String, ByVal FilePath As String)
Dim FL As Scripting.File
Dim Fldr As Scripting.Folder
Dim FSO As New Scripting.FileSystemObject()
Dim FPstr, CMPstr As String
Dim TS As Scripting.TextStream
FL = FSO.GetFile(CompressedFilePath)
CMPstr = FL.ShortPath
FL = Nothing
Fldr = FSO.GetFolder(FilePath)
FPstr = Fldr.ShortPath
FSO = Nothing
Microsoft.VisualBasic.Interaction.Shell(Application.StartupPath & "\DB11.exe " & CMPstr & " " & FPstr, AppWinStyle.Hide, True)
End Sub
End Module

Change Date Format +vb.net

Module mdl_ShortDateFormat


Private Const DATE_SHORTDATE = &H1
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
Public Declare Function EnumDateFormats Lib "KERNEL32" Alias "EnumDateFormatsA" (ByVal lpDateFmtEnumProc As Integer, ByVal Locale As Integer, ByVal dwFlags As Integer) As Integer
Public Declare Function GetSystemDefaultLCID Lib "kernel32" Alias "GetSystemDefaultLCID" () As Integer
Public Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Integer, ByVal LCType As Integer, ByVal lpLCData As String) As Integer
Public Function SetShortDateFormat()
Dim xCID As Long
Dim xChangedFormat As String
Try
xCID = GetSystemDefaultLCID()
Catch ex As Exception
End Try
xChangedFormat = "dd/MM/yyyy"
Try
Call SetLocaleInfo(xCID, LOCALE_SSHORTDATE, xChangedFormat)
Catch ex As Exception
End Try

Try
Call PostMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0&, 0&)
Catch ex As Exception
End Try

Try
Call EnumDateFormats(0, xCID, DATE_SHORTDATE)
Catch ex As Exception
End Try

End Function
End Module