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