VB.Net – DorkBrain

WebFileDownloader

September 2, 2017

Imports System.Net
Imports System.IO
 
Public Class WebFileDownloader
    Public Event AmountDownloadedChanged(ByVal iNewProgress As Long)
    Public Event FileDownloadSizeObtained(ByVal iFileSize As Long)
    Public Event FileDownloadComplete()
    Public Event FileDownloadFailed(ByVal ex As Exception)
 
    Private mCurrentFile As String = String.Empty
 
    Public ReadOnly Property CurrentFile() As String
        Get
            Return mCurrentFile
        End Get
    End Property
    Public Function DownloadFile(ByVal URL As String, ByVal Location As String) As Boolean
        Try
            mCurrentFile = GetFileName(URL)
            Dim WC As New WebClient
            WC.DownloadFile(URL, Location)
            RaiseEvent FileDownloadComplete()
            Return True
        Catch ex As Exception
            RaiseEvent FileDownloadFailed(ex)
            Return False
        End Try
    End Function
 
    Private Function GetFileName(ByVal URL As String) As String
        Try
            Return URL.Substring(URL.LastIndexOf("/") + 1)
        Catch ex As Exception
            Return URL
        End Try
    End Function
    Public Function DownloadFileWithProgress(ByVal URL As String, ByVal Location As String) As Boolean
        Dim FS As FileStream
        Try
            mCurrentFile = GetFileName(URL)
            Dim wRemote As WebRequest
            Dim bBuffer As Byte()
            ReDim bBuffer(256)
            Dim iBytesRead As Integer
            Dim iTotalBytesRead As Integer
 
            FS = New FileStream(Location, FileMode.Create, FileAccess.Write)
            wRemote = WebRequest.Create(URL)
            Dim myWebResponse As WebResponse = wRemote.GetResponse
            RaiseEvent FileDownloadSizeObtained(myWebResponse.ContentLength)
            Dim sChunks As Stream = myWebResponse.GetResponseStream
            Do
                iBytesRead = sChunks.Read(bBuffer, 0, 256)
                FS.Write(bBuffer, 0, iBytesRead)
                iTotalBytesRead += iBytesRead
                If myWebResponse.ContentLength < iTotalBytesRead Then
                    RaiseEvent AmountDownloadedChanged(myWebResponse.ContentLength)
                Else
                    RaiseEvent AmountDownloadedChanged(iTotalBytesRead)
                End If
            Loop While Not iBytesRead = 0
            sChunks.Close()
            FS.Close()
            RaiseEvent FileDownloadComplete()
            Return True
        Catch ex As Exception
            If Not (FS Is Nothing) Then
                FS.Close()
                FS = Nothing
            End If
            RaiseEvent FileDownloadFailed(ex)
            Return False
        End Try
    End Function
 
    Public Shared Function FormatFileSize(ByVal Size As Long) As String
        Try
            Dim KB As Integer = 1024
            Dim MB As Integer = KB * KB
            ' Return size of file in kilobytes.
            If Size < KB Then
                Return (Size.ToString("D") & " bytes")
            Else
                Select Case Size / KB
                    Case Is < 1000
                        Return (Size / KB).ToString("N") & "KB"
                    Case Is < 1000000
                        Return (Size / MB).ToString("N") & "MB"
                    Case Is < 10000000
                        Return (Size / MB / KB).ToString("N") & "GB"
                End Select
            End If
        Catch ex As Exception
            Return Size.ToString
        End Try
    End Function
End Class

Imports System.Net

Imports System.IO

Public Class WebFileDownloader

Public Event AmountDownloadedChanged(ByVal iNewProgress As Long)

Public Event FileDownloadSizeObtained(ByVal iFileSize As Long)

Public Event FileDownloadComplete()

Public Event FileDownloadFailed(ByVal ex As Exception)

Private mCurrentFile As String = String.Empty

Public ReadOnly Property CurrentFile() As String

Get

Return mCurrentFile

End Get

End Property

Public Function DownloadFile(ByVal URL As String, ByVal Location As String) As Boolean

Try

mCurrentFile = GetFileName(URL)

Dim WC As New WebClient

WC.DownloadFile(URL, Location)

RaiseEvent FileDownloadComplete()

Return True

Catch ex As Exception

RaiseEvent FileDownloadFailed(ex)

Return False

End Try

End Function

Private Function GetFileName(ByVal URL As String) As String

Try

Return URL.Substring(URL.LastIndexOf("/") + 1)

Catch ex As Exception

Return URL

End Try

End Function

Public Function DownloadFileWithProgress(ByVal URL As String, ByVal Location As String) As Boolean

Dim FS As FileStream

Try

mCurrentFile = GetFileName(URL)

Dim wRemote As WebRequest

Dim bBuffer As Byte()

ReDim bBuffer(256)

Dim iBytesRead As Integer

Dim iTotalBytesRead As Integer

FS = New FileStream(Location, FileMode.Create, FileAccess.Write)

wRemote = WebRequest.Create(URL)

Dim myWebResponse As WebResponse = wRemote.GetResponse

RaiseEvent FileDownloadSizeObtained(myWebResponse.ContentLength)

Dim sChunks As Stream = myWebResponse.GetResponseStream

iBytesRead = sChunks.Read(bBuffer, 0, 256)

FS.Write(bBuffer, 0, iBytesRead)

iTotalBytesRead += iBytesRead

If myWebResponse.ContentLength < iTotalBytesRead Then

RaiseEvent AmountDownloadedChanged(myWebResponse.ContentLength)

Else

RaiseEvent AmountDownloadedChanged(iTotalBytesRead)

End If

Loop While Not iBytesRead = 0

sChunks.Close()

FS.Close()

RaiseEvent FileDownloadComplete()

Return True

Catch ex As Exception

If Not (FS Is Nothing) Then

FS.Close()

FS = Nothing

End If

RaiseEvent FileDownloadFailed(ex)

Return False

End Try

End Function

Public Shared Function FormatFileSize(ByVal Size As Long) As String

Try

Dim KB As Integer = 1024

Dim MB As Integer = KB * KB

' Return size of file in kilobytes.

If Size < KB Then

Return (Size.ToString("D") & " bytes")

Else

Select Case Size / KB

Case Is < 1000

Return (Size / KB).ToString("N") & "KB"

Case Is < 1000000

Return (Size / MB).ToString("N") & "MB"

Case Is < 10000000

Return (Size / MB / KB).ToString("N") & "GB"

End Select

End If

Catch ex As Exception

Return Size.ToString

End Try

End Function

End Class

Tools.Wallpaper

No Comments

Imports System.IO
 
Namespace Tools
	Public Class Wallpaper
		Const SPI_SETDESKWALLPAPER As Integer = 20
		Const SPIF_UPDATEINIFILE As Integer = &H1
		Const SPIF_SENDWININICHANGE As Integer = &H2
 
		Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Integer, ByVal uParam As Integer, ByVal lpvParam As String, ByVal fuWinIni As Integer) As Integer
 
		Private _RegKey As Microsoft.Win32.RegistryKey
		Private _PictureBmp As String
		Private _imgPicture As Image
 
		Public Shared Enum WallpaperStyle
			Centered = 0
			Tiled = 1
			Stretched = 2
		End Enum
 
		Public Function Shared Change(ByVal PicturePath As String, Optional ByVal wpStyle As WallpaperStyle = WallpaperStyle.Centered) As Boolean
			If PicturePath Is Nothing Then Return False ' No picture specfied

			If PicturePath = "" Then
				SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PicturePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
				Return True
			End If
 
			If File.Exists(PicturePath) Then ' Does the file actually exist?
				Try
					' This class doesn't use my registry class so it can remain independant.
					_RegKey = Microsoft.Win32.Registry.CurrentUser.OpenSubKey("Control Panel\Desktop", True)
					Select Case wpStyle
						Case WallpaperStyle.Centered
							_RegKey.SetValue("TileWallpaper", "0")
							_RegKey.SetValue("WallpaperStyle", "0")
						Case WallpaperStyle.Tiled
							_RegKey.SetValue("TileWallpaper", "1")
							_RegKey.SetValue("WallpaperStyle", "0")
						Case WallpaperStyle.Stretched
							_RegKey.SetValue("TileWallpaper", "0")
							_RegKey.SetValue("WallpaperStyle", "2")
					End Select
					_RegKey.Flush()
					_RegKey.Close()
					' If picture not a bitmap then convert it first.
					Dim fi As New FileInfo(PicturePath)
					If fi.Extension.ToLower <> ".bmp" Then
						_imgPicture = Image.FromFile(PicturePath, True)
						_PictureBmp = PicturePath.Substring(0, PicturePath.Length - 3) & "bmp"
						_imgPicture.Save(_PictureBmp, System.Drawing.Imaging.ImageFormat.Bmp)
					Else
						_PictureBmp = PicturePath
					End If
					' Once bitmap, set the the wallpaper.
					SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, _PictureBmp, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
					Return True
				Catch ex As Exception
					Return False
				End Try
			Else
				Return False
			End If
		End Function
	End Class
End Namespace

Imports System.IO

Namespace Tools

Public Class Wallpaper

Const SPI_SETDESKWALLPAPER As Integer = 20

Const SPIF_UPDATEINIFILE As Integer = &H1

Const SPIF_SENDWININICHANGE As Integer = &H2

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Integer, ByVal uParam As Integer, ByVal lpvParam As String, ByVal fuWinIni As Integer) As Integer

Private _RegKey As Microsoft.Win32.RegistryKey

Private _PictureBmp As String

Private _imgPicture As Image

Public Shared Enum WallpaperStyle

Centered = 0

Tiled = 1

Stretched = 2

End Enum

Public Function Shared Change(ByVal PicturePath As String, Optional ByVal wpStyle As WallpaperStyle = WallpaperStyle.Centered) As Boolean

If PicturePath Is Nothing Then Return False ' No picture specfied

If PicturePath = "" Then

SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PicturePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)

Return True

End If

If File.Exists(PicturePath) Then ' Does the file actually exist?

Try

' This class doesn't use my registry class so it can remain independant.

_RegKey = Microsoft.Win32.Registry.CurrentUser.OpenSubKey("Control Panel\Desktop", True)

Select Case wpStyle

Case WallpaperStyle.Centered

_RegKey.SetValue("TileWallpaper", "0")

_RegKey.SetValue("WallpaperStyle", "0")

Case WallpaperStyle.Tiled

_RegKey.SetValue("TileWallpaper", "1")

_RegKey.SetValue("WallpaperStyle", "0")

Case WallpaperStyle.Stretched

_RegKey.SetValue("TileWallpaper", "0")

_RegKey.SetValue("WallpaperStyle", "2")

End Select

_RegKey.Flush()

_RegKey.Close()

' If picture not a bitmap then convert it first.

Dim fi As New FileInfo(PicturePath)

If fi.Extension.ToLower <> ".bmp" Then

_imgPicture = Image.FromFile(PicturePath, True)

_PictureBmp = PicturePath.Substring(0, PicturePath.Length - 3) & "bmp"

_imgPicture.Save(_PictureBmp, System.Drawing.Imaging.ImageFormat.Bmp)

Else

_PictureBmp = PicturePath

End If

' Once bitmap, set the the wallpaper.

SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, _PictureBmp, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)

Return True

Catch ex As Exception

Return False

End Try

Else

Return False

End If

End Function

End Class

End Namespace

Tools.Wait

No Comments

Imports System.Threading.Tasks
 
Namespace Tools
  Public Class Wait
    Public Shared Sub Start(milliseconds As Integer)
      Task.WaitAll(Task.Factory.StartNew(Sub() Threading.Thread.Sleep(milliseconds)))
    End Sub
 
    Public Shared Sub OneSec()
      Tools.Wait.Start(1000)
    End Sub
  End Class
End Namespace

Imports System.Threading.Tasks

Namespace Tools

Public Class Wait

Public Shared Sub Start(milliseconds As Integer)

Task.WaitAll(Task.Factory.StartNew(Sub() Threading.Thread.Sleep(milliseconds)))

End Sub

Public Shared Sub OneSec()

Tools.Wait.Start(1000)

End Sub

End Class

End Namespace

Tools.SortableListView

No Comments

Imports System.Collections
Imports System.Windows.Forms
Namespace Tools
  Public Class SortableListView
    Inherits System.Windows.Forms.ListView
#Region "Constructors"
    Public Sub New()
      MyBase.New()
      LvwColumnSorter = New ListViewColumnSorter(Me)
    End Sub
#End Region
#Region "Data definition"
    Public Property FixedStringForLastItem() As String
      '
      ' Fixed string for the last item, so it will stay the last item
      '
      Get
        Return LvwColumnSorter.FixedStringForLastItem
      End Get
      Set(ByVal Value As String)
        '
        ' The IComparer has to know that
        '
        LvwColumnSorter.FixedStringForLastItem = Value
      End Set
    End Property
    Public Property SortColumn() As Integer
      '
      ' Index of sort column
      '
      Get
        Return LvwColumnSorter.SortColumn
      End Get
      Set(ByVal Value As Integer)
        '
        ' Put it through to IComparer
        '
        LvwColumnSorter.SortColumn = Value
        '
        ' Let's do it
        '
        If LvwColumnSorter.Order = SortOrder.None Then
          MyBase.ListViewItemSorter = Nothing
        Else
          If MyBase.ListViewItemSorter Is Nothing Then
            MyBase.ListViewItemSorter = LvwColumnSorter
          Else
            MyBase.Sort()
          End If
        End If
        '
      End Set
    End Property
    Public Property Order() As SortOrder
      '
      ' Sort order (none, ascending or descending)
      '
      Get
        Return LvwColumnSorter.Order
      End Get
      Set(ByVal Value As SortOrder)
        '
        ' Last information needed for IComparer
        '
        LvwColumnSorter.Order = Value
        If Value = SortOrder.None Then
          If LvwColumnSorter.SortColumn > -1 Then
            '
            ' Setting the text causes a repaint of the header
            '
            MyBase.Columns(LvwColumnSorter.SortColumn).Text = _
                MyBase.Columns(LvwColumnSorter.SortColumn).Text
            '
            ' If there has been a triangle from a previous sorting,
            ' it is now deleted
            '
          End If
          LvwColumnSorter.SortColumn = -1
        End If
        '
        ' Let's do it
        '
        If LvwColumnSorter.SortColumn = -1 Then
          MyBase.ListViewItemSorter = Nothing
        Else
          If MyBase.ListViewItemSorter Is Nothing Then
            MyBase.ListViewItemSorter = LvwColumnSorter
          Else
            MyBase.Sort()
          End If
        End If
        '
      End Set
    End Property
    Private WithEvents LvlListener As LvlListenerClass
    Private WithEvents HdrListener As HdrListenerClass
    Private LvwColumnSorter As ListViewColumnSorter
#End Region
#Region "Event handling"
    Public Event Scroll(ByVal sender As Object, ByVal e As EventArgs)
    Public Shadows Event Paint(ByVal sender As Object, ByVal e As EventArgs)
    Private Class LvlListenerClass
      '
      ' Listen for operating system messages to raise the events
      ' "Scroll" or "Paint" for the ListView
      '
      Inherits NativeWindow
      Public Event Scroll(ByVal sender As Object, ByVal e As EventArgs)
      Public Event Paint(ByVal sender As Object, ByVal e As EventArgs)
      Const WM_HSCROLL = &H114
      Const WM_VSCROLL = &H115
      Const WM_PAINT = &HF
      Private Ctrl As Control
      Public Sub New(ByVal Ctrl As Control)
        AssignHandle(Ctrl.Handle)
      End Sub
      Protected Overrides Sub WndProc(ByRef m As Message)
        MyBase.WndProc(m)
        If m.Msg = WM_HSCROLL Or m.Msg = WM_VSCROLL Then
          RaiseEvent Scroll(Ctrl, New EventArgs())
        End If
        If m.Msg = WM_PAINT Then
          RaiseEvent Paint(Ctrl, New EventArgs())
        End If
      End Sub
      Protected Overrides Sub Finalize()
        ReleaseHandle()
        MyBase.Finalize()
      End Sub
    End Class
    Private Class HdrListenerClass
      '
      ' Listen for operating system messages to raise the event
      ' "HaederPaint", when the column headers are to be painted.
      ' On this event, a triangle, symbolizing sort order and
      ' column is to be drawn.
      '
      Inherits NativeWindow
      Public Event HaederPaint(ByVal sender As Object, ByVal e As EventArgs)
      Const WM_PAINT = &HF
      Private CtrlValue As Control
      Public Sub New(ByVal Ctrl As Control, ByVal HeaderHandle As System.IntPtr)
        AssignHandle(HeaderHandle)
        CtrlValue = Ctrl
      End Sub
      Protected Overrides Sub WndProc(ByRef m As Message)
        MyBase.WndProc(m)
        If m.Msg = WM_PAINT Then
          RaiseEvent HaederPaint(CtrlValue, New EventArgs())
        End If
      End Sub
      Protected Overrides Sub Finalize()
        ReleaseHandle()
        MyBase.Finalize()
      End Sub
    End Class
    Protected Overrides Sub OnHandleCreated(ByVal e As EventArgs)
      '
      ' Now it's the right time to do some initializations
      '
      MyBase.OnHandleCreated(e)
      If Not Me.DesignMode Then
        LvlListener = New LvlListenerClass(Me)
        LvwColumnSorter.GetHeaderHandle()
        HdrListener = New HdrListenerClass(Me, LvwColumnSorter.HeaderHandle)
      End If
    End Sub
    Private Sub LvlListener_Paint(ByVal sender As Object, ByVal e As System.EventArgs) _
            Handles LvlListener.Paint
      '
      ' Make this event public
      '
      RaiseEvent Paint(sender, e)
      '
    End Sub
    Private Sub LvlListener_Scroll(ByVal sender As Object, ByVal e As System.EventArgs) _
            Handles LvlListener.Scroll
      '
      ' Make this event public
      '
      RaiseEvent Scroll(sender, e)
      '
    End Sub
    Private Sub HdrListener_HaederPaint(ByVal sender As Object, _
            ByVal e As System.EventArgs) Handles HdrListener.HaederPaint
      '
      ' The column headers has been painted, so draw the sort triangle
      '
      LvwColumnSorter.VisualizeOrder()
      '
    End Sub
    Private Sub MyBase_ColumnClick(ByVal sender As Object, ByVal e As  _
            System.Windows.Forms.ColumnClickEventArgs) Handles MyBase.ColumnClick
      '
      ' The user wants to sort the list view items
      '
      If (e.Column = SortColumn) Then
        '
        ' The column has been clicked twice, so switch the sort order
        '
        If (Order = SortOrder.Ascending) Then
          Order = SortOrder.Descending
        Else
          Order = SortOrder.Ascending
        End If
      Else
        '
        ' It has to be sort ascending by the column
        '
        SortColumn = e.Column
        Order = SortOrder.Ascending
      End If
      '
    End Sub
#End Region
#Region "API stuff"
    '
    ' The API function ChildWindowFromPoint is used to find out the window handle of
    ' the columns header.
    '
    Private Structure GdiPoint
      Dim x As Integer
      Dim y As Integer
    End Structure
    Private Declare Function ChildWindowFromPoint Lib "user32" _
        (ByVal hWndParent As System.IntPtr, ByVal Point As GdiPoint) As System.IntPtr
    '
#End Region
#Region "Subroutines and functions"
    Private Class ListViewColumnSorter
      Implements System.Collections.IComparer
      '
      ' This class implements an non case sensitve IComparer for
      ' sorting items in a ListView
      '
      Private ColumnToSort As Integer
      Private OrderOfSort As SortOrder
      Private ObjectCompare As CaseInsensitiveComparer
      Private FixedStringForLastItemValue As String
      Private MyListViewValue As SortableListView
      Public Sub New(ByVal MyListView As SortableListView)
        ColumnToSort = 0
        OrderOfSort = SortOrder.None
        ObjectCompare = New CaseInsensitiveComparer()
        MyListViewValue = MyListView
      End Sub
      Public Property FixedStringForLastItem() As String
        '
        ' Fixed string for the last item, so it will stay the last item
        '
        Get
          Return FixedStringForLastItemValue
        End Get
        Set(ByVal Value As String)
          FixedStringForLastItemValue = Value
        End Set
      End Property
      Public Property SortColumn() As Integer
        '
        ' Index of sort column
        '
        Set(ByVal Value As Integer)
          ColumnToSort = Value
        End Set
        Get
          Return ColumnToSort
        End Get
      End Property
      Public Property Order() As SortOrder
        '
        ' Sort order (none, ascending or descending)
        '
        Set(ByVal Value As SortOrder)
          OrderOfSort = Value
          VisualizeOrder()
        End Set
        Get
          Return OrderOfSort
        End Get
      End Property
      Public ReadOnly Property HeaderHandle() As System.IntPtr
        '
        ' The handle of the columns header
        '
        Get
          Return HeaderHandleValue
        End Get
      End Property
      Public Sub GetHeaderHandle()
        '
        ' Find out the handle of the columns header
        '
        Dim TestPoint As GdiPoint
        TestPoint.x = 5
        TestPoint.y = 5
        HeaderHandleValue = _
            ChildWindowFromPoint(MyListViewValue.Handle, TestPoint)
      End Sub
      Public Function Compare(ByVal a As Object, ByVal b As Object) As _
              Integer Implements IComparer.Compare
        '
        ' Using a case insensitive comparer to compare the Text of
        ' two list view items
        '
        If OrderOfSort = SortOrder.None Then
          '
          ' Return 0 means that both items are equal, so no
          ' change of the sequence will occure
          '
          Return 0
          '
        End If
        '
        Dim Result As Integer
        Dim LvIa As ListViewItem = a
        Dim LvIb As ListViewItem = b
        Dim Ca As String = LvIa.SubItems(ColumnToSort).Text
        Dim Cb As String = LvIb.SubItems(ColumnToSort).Text
        '
        ' Compare the two strings
        '
        Result = ObjectCompare.Compare(Ca, Cb)
        If FixedStringForLastItemValue Is Nothing Then
          ' nothing
        Else
          If Cb = FixedStringForLastItemValue Then
            Return -1
          End If
        End If
        '
        ' If the strings contains numbers, correct the sequence. For example:
        ' 3, 20, 1 has to be sorted as 1, 3, 20 and not 1, 20, 3
        '
        If Result <> 0 And IsNumeric(Ca) And IsNumeric(Cb) Then
          If (CDbl(Ca) > CDbl(Cb)) Then
            Result = 1
          Else
            Result = -1
          End If
        End If
        '
        ' The return value depends on the sort order
        '
        Select Case OrderOfSort
          Case SortOrder.Ascending
            '
            ' As ascending sort is desired, return the compare result
            '
            Return Result
            '
          Case SortOrder.Descending
            '
            ' As descending sort is desired, compare result is to be
            ' turned in the negative
            '
            Return -Result
            '
        End Select
        Return Result
      End Function
      Public Sub VisualizeOrder()
        '
        ' The sort column and order are visualized by a little triangle,
        ' which is to be drawn right to the columns name
        '
        If ColumnToSort = -1 Then
          Exit Sub
        End If
        '
        ' Draw the triangle in the header. Before that,
        ' make theold triangle invisible. After that, store the
        ' position of the triangle for usage at the next time.
        '
        If SortColumnOld > -1 And SortColumnOld <> ColumnToSort Then
          '
          ' Setting the text causes a repaint of the header
          '
          MyListViewValue.Columns(SortColumnOld).Text = _
              MyListViewValue.Columns(SortColumnOld).Text.TrimEnd
          '
        End If
        If OrderOfSort = SortOrder.None Then
          SortColumnOld = -1
        Else
          Dim Grx As Graphics
          Grx = Graphics.FromHwnd(HeaderHandle)
          Dim LblMeasureHeader As New Label()
          LblMeasureHeader.Font = MyListViewValue.Font
          LblMeasureHeader.AutoSize = True
          If MyListViewValue.Columns(ColumnToSort).TextAlign <> _
              HorizontalAlignment.Left Then
            If MyListViewValue.Columns(ColumnToSort).Text.TrimEnd = _
                    MyListViewValue.Columns(ColumnToSort).Text Then
              MyListViewValue.Columns(ColumnToSort).Text += Space(5)
            End If
          End If
          LblMeasureHeader.Text = MyListViewValue.Columns(ColumnToSort).Text
          Dim x, y, i As Integer
          Dim Triangle(2) As Point
          '
          ' Evaluate the length of the Name
          '
          x = LblMeasureHeader.Width + 13
          '
          ' Keep a minimum distance of the right bounce
          '
          If x + 15 > MyListViewValue.Columns(ColumnToSort).Width Then
            x = MyListViewValue.Columns(ColumnToSort).Width - 13
          End If
          '
          ' Sum the width of all columns left to the sort column
          '
          For i = 0 To ColumnToSort - 1
            x += MyListViewValue.Columns(i).Width
          Next
          '
          ' Top is determined by the text height
          '
          y = LblMeasureHeader.Height / 2 + 2
          '
          ' The three points of the triangle are depending on
          ' the sort order
          '
          If OrderOfSort = SortOrder.Ascending Then
            Triangle(0).X = x - 1
            Triangle(0).Y = y + 4
            Triangle(1).X = x + 9
            Triangle(1).Y = y + 4
            Triangle(2).X = x + 4
            Triangle(2).Y = y - 2
          Else
            Triangle(0).X = x
            Triangle(0).Y = y - 1
            Triangle(1).X = x + 9
            Triangle(1).Y = y - 1
            Triangle(2).X = x + 4
            Triangle(2).Y = y + 4
          End If
          Grx.FillPolygon(SystemBrushes.ControlDark, Triangle)
          SortColumnOld = ColumnToSort
          Grx.Dispose()
        End If
      End Sub
      Private SortColumnOld As Integer = -1
      Private HeaderHandleValue As System.IntPtr
    End Class
#End Region
  End Class
End Namespace

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

Imports System.Collections

Imports System.Windows.Forms

Namespace Tools

Public Class SortableListView

Inherits System.Windows.Forms.ListView

#Region "Constructors"

Public Sub New()

MyBase.New()

LvwColumnSorter = New ListViewColumnSorter(Me)

End Sub

#End Region

#Region "Data definition"

Public Property FixedStringForLastItem() As String

' Fixed string for the last item, so it will stay the last item

Get

Return LvwColumnSorter.FixedStringForLastItem

End Get

Set(ByVal Value As String)

' The IComparer has to know that

LvwColumnSorter.FixedStringForLastItem = Value

End Set

End Property

Public Property SortColumn() As Integer

' Index of sort column

Get

Return LvwColumnSorter.SortColumn

End Get

Set(ByVal Value As Integer)

' Put it through to IComparer

LvwColumnSorter.SortColumn = Value

' Let's do it

If LvwColumnSorter.Order = SortOrder.None Then

MyBase.ListViewItemSorter = Nothing

Else

If MyBase.ListViewItemSorter Is Nothing Then

MyBase.ListViewItemSorter = LvwColumnSorter

Else

MyBase.Sort()

End If

End Set

End Property

Public Property Order() As SortOrder

' Sort order (none, ascending or descending)

Get

Return LvwColumnSorter.Order

End Get

Set(ByVal Value As SortOrder)

' Last information needed for IComparer

LvwColumnSorter.Order = Value

If Value = SortOrder.None Then

If LvwColumnSorter.SortColumn > -1 Then

' Setting the text causes a repaint of the header

MyBase.Columns(LvwColumnSorter.SortColumn).Text = _

MyBase.Columns(LvwColumnSorter.SortColumn).Text

' If there has been a triangle from a previous sorting,

' it is now deleted

End If

LvwColumnSorter.SortColumn = -1

End If

' Let's do it

If LvwColumnSorter.SortColumn = -1 Then

MyBase.ListViewItemSorter = Nothing

Else

If MyBase.ListViewItemSorter Is Nothing Then

MyBase.ListViewItemSorter = LvwColumnSorter

Else

MyBase.Sort()

End If

End Set

End Property

Private WithEvents LvlListener As LvlListenerClass

Private WithEvents HdrListener As HdrListenerClass

Private LvwColumnSorter As ListViewColumnSorter

#End Region

#Region "Event handling"

Public Event Scroll(ByVal sender As Object, ByVal e As EventArgs)

Public Shadows Event Paint(ByVal sender As Object, ByVal e As EventArgs)

Private Class LvlListenerClass

' Listen for operating system messages to raise the events

' "Scroll" or "Paint" for the ListView

Inherits NativeWindow

Public Event Scroll(ByVal sender As Object, ByVal e As EventArgs)

Public Event Paint(ByVal sender As Object, ByVal e As EventArgs)

Const WM_HSCROLL = &H114

Const WM_VSCROLL = &H115

Const WM_PAINT = &HF

Private Ctrl As Control

Public Sub New(ByVal Ctrl As Control)

AssignHandle(Ctrl.Handle)

End Sub

Protected Overrides Sub WndProc(ByRef m As Message)

MyBase.WndProc(m)

If m.Msg = WM_HSCROLL Or m.Msg = WM_VSCROLL Then

RaiseEvent Scroll(Ctrl, New EventArgs())

End If

If m.Msg = WM_PAINT Then

RaiseEvent Paint(Ctrl, New EventArgs())

End If

End Sub

Protected Overrides Sub Finalize()

ReleaseHandle()

MyBase.Finalize()

End Sub

End Class

Private Class HdrListenerClass

' Listen for operating system messages to raise the event

' "HaederPaint", when the column headers are to be painted.

' On this event, a triangle, symbolizing sort order and

' column is to be drawn.

Inherits NativeWindow

Public Event HaederPaint(ByVal sender As Object, ByVal e As EventArgs)

Const WM_PAINT = &HF

Private CtrlValue As Control

Public Sub New(ByVal Ctrl As Control, ByVal HeaderHandle As System.IntPtr)

AssignHandle(HeaderHandle)

CtrlValue = Ctrl

End Sub

Protected Overrides Sub WndProc(ByRef m As Message)

MyBase.WndProc(m)

If m.Msg = WM_PAINT Then

RaiseEvent HaederPaint(CtrlValue, New EventArgs())

End If

End Sub

Protected Overrides Sub Finalize()

ReleaseHandle()

MyBase.Finalize()

End Sub

End Class

Protected Overrides Sub OnHandleCreated(ByVal e As EventArgs)

' Now it's the right time to do some initializations

MyBase.OnHandleCreated(e)

If Not Me.DesignMode Then

LvlListener = New LvlListenerClass(Me)

LvwColumnSorter.GetHeaderHandle()

HdrListener = New HdrListenerClass(Me, LvwColumnSorter.HeaderHandle)

End If

End Sub

Private Sub LvlListener_Paint(ByVal sender As Object, ByVal e As System.EventArgs) _

Handles LvlListener.Paint

' Make this event public

RaiseEvent Paint(sender, e)

End Sub

Private Sub LvlListener_Scroll(ByVal sender As Object, ByVal e As System.EventArgs) _

Handles LvlListener.Scroll

' Make this event public

RaiseEvent Scroll(sender, e)

End Sub

Private Sub HdrListener_HaederPaint(ByVal sender As Object, _

ByVal e As System.EventArgs) Handles HdrListener.HaederPaint

' The column headers has been painted, so draw the sort triangle

LvwColumnSorter.VisualizeOrder()

End Sub

Private Sub MyBase_ColumnClick(ByVal sender As Object, ByVal e As _

System.Windows.Forms.ColumnClickEventArgs) Handles MyBase.ColumnClick

' The user wants to sort the list view items

If (e.Column = SortColumn) Then

' The column has been clicked twice, so switch the sort order

If (Order = SortOrder.Ascending) Then

Order = SortOrder.Descending

Else

Order = SortOrder.Ascending

End If

Else

' It has to be sort ascending by the column

SortColumn = e.Column

Order = SortOrder.Ascending

End If

End Sub

#End Region

#Region "API stuff"

' The API function ChildWindowFromPoint is used to find out the window handle of

' the columns header.

Private Structure GdiPoint

Dim x As Integer

Dim y As Integer

End Structure

Private Declare Function ChildWindowFromPoint Lib "user32" _

(ByVal hWndParent As System.IntPtr, ByVal Point As GdiPoint) As System.IntPtr

#End Region

#Region "Subroutines and functions"

Private Class ListViewColumnSorter

Implements System.Collections.IComparer

' This class implements an non case sensitve IComparer for

' sorting items in a ListView

Private ColumnToSort As Integer

Private OrderOfSort As SortOrder

Private ObjectCompare As CaseInsensitiveComparer

Private FixedStringForLastItemValue As String

Private MyListViewValue As SortableListView

Public Sub New(ByVal MyListView As SortableListView)

ColumnToSort = 0

OrderOfSort = SortOrder.None

ObjectCompare = New CaseInsensitiveComparer()

MyListViewValue = MyListView

End Sub

Public Property FixedStringForLastItem() As String

' Fixed string for the last item, so it will stay the last item

Get

Return FixedStringForLastItemValue

End Get

Set(ByVal Value As String)

FixedStringForLastItemValue = Value

End Set

End Property

Public Property SortColumn() As Integer

' Index of sort column

Set(ByVal Value As Integer)

ColumnToSort = Value

End Set

Get

Return ColumnToSort

End Get

End Property

Public Property Order() As SortOrder

' Sort order (none, ascending or descending)

Set(ByVal Value As SortOrder)

OrderOfSort = Value

VisualizeOrder()

End Set

Get

Return OrderOfSort

End Get

End Property

Public ReadOnly Property HeaderHandle() As System.IntPtr

' The handle of the columns header

Get

Return HeaderHandleValue

End Get

End Property

Public Sub GetHeaderHandle()

' Find out the handle of the columns header

Dim TestPoint As GdiPoint

TestPoint.x = 5

TestPoint.y = 5

HeaderHandleValue = _

ChildWindowFromPoint(MyListViewValue.Handle, TestPoint)

End Sub

Public Function Compare(ByVal a As Object, ByVal b As Object) As _

Integer Implements IComparer.Compare

' Using a case insensitive comparer to compare the Text of

' two list view items

If OrderOfSort = SortOrder.None Then

' Return 0 means that both items are equal, so no

' change of the sequence will occure

Return 0

End If

Dim Result As Integer

Dim LvIa As ListViewItem = a

Dim LvIb As ListViewItem = b

Dim Ca As String = LvIa.SubItems(ColumnToSort).Text

Dim Cb As String = LvIb.SubItems(ColumnToSort).Text

' Compare the two strings

Result = ObjectCompare.Compare(Ca, Cb)

If FixedStringForLastItemValue Is Nothing Then

' nothing

Else

If Cb = FixedStringForLastItemValue Then

Return -1

End If

' If the strings contains numbers, correct the sequence. For example:

' 3, 20, 1 has to be sorted as 1, 3, 20 and not 1, 20, 3

If Result <> 0 And IsNumeric(Ca) And IsNumeric(Cb) Then

If (CDbl(Ca) > CDbl(Cb)) Then

Result = 1

Else

Result = -1

End If

' The return value depends on the sort order

Select Case OrderOfSort

Case SortOrder.Ascending

' As ascending sort is desired, return the compare result

Return Result

Case SortOrder.Descending

' As descending sort is desired, compare result is to be

' turned in the negative

Return -Result

End Select

Return Result

End Function

Public Sub VisualizeOrder()

' The sort column and order are visualized by a little triangle,

' which is to be drawn right to the columns name

If ColumnToSort = -1 Then

Exit Sub

End If

' Draw the triangle in the header. Before that,

' make theold triangle invisible. After that, store the

' position of the triangle for usage at the next time.

If SortColumnOld > -1 And SortColumnOld <> ColumnToSort Then

' Setting the text causes a repaint of the header

MyListViewValue.Columns(SortColumnOld).Text = _

MyListViewValue.Columns(SortColumnOld).Text.TrimEnd

End If

If OrderOfSort = SortOrder.None Then

SortColumnOld = -1

Else

Dim Grx As Graphics

Grx = Graphics.FromHwnd(HeaderHandle)

Dim LblMeasureHeader As New Label()

LblMeasureHeader.Font = MyListViewValue.Font

LblMeasureHeader.AutoSize = True

If MyListViewValue.Columns(ColumnToSort).TextAlign <> _

HorizontalAlignment.Left Then

If MyListViewValue.Columns(ColumnToSort).Text.TrimEnd = _

MyListViewValue.Columns(ColumnToSort).Text Then

MyListViewValue.Columns(ColumnToSort).Text += Space(5)

End If

LblMeasureHeader.Text = MyListViewValue.Columns(ColumnToSort).Text

Dim x, y, i As Integer

Dim Triangle(2) As Point

' Evaluate the length of the Name

x = LblMeasureHeader.Width + 13

' Keep a minimum distance of the right bounce

If x + 15 > MyListViewValue.Columns(ColumnToSort).Width Then

x = MyListViewValue.Columns(ColumnToSort).Width - 13

End If

' Sum the width of all columns left to the sort column

For i = 0 To ColumnToSort - 1

x += MyListViewValue.Columns(i).Width

' Top is determined by the text height

y = LblMeasureHeader.Height / 2 + 2

' The three points of the triangle are depending on

' the sort order

If OrderOfSort = SortOrder.Ascending Then

Triangle(0).X = x - 1

Triangle(0).Y = y + 4

Triangle(1).X = x + 9

Triangle(1).Y = y + 4

Triangle(2).X = x + 4

Triangle(2).Y = y - 2

Else

Triangle(0).X = x

Triangle(0).Y = y - 1

Triangle(1).X = x + 9

Triangle(1).Y = y - 1

Triangle(2).X = x + 4

Triangle(2).Y = y + 4

End If

Grx.FillPolygon(SystemBrushes.ControlDark, Triangle)

SortColumnOld = ColumnToSort

Grx.Dispose()

End If

End Sub

Private SortColumnOld As Integer = -1

Private HeaderHandleValue As System.IntPtr

End Class

#End Region

End Class

End Namespace

Tools.Shortcut

No Comments

Imports System
Imports System.Text
Imports System.Runtime.InteropServices
Imports System.Diagnostics
Imports System.Drawing
Imports System.IO
Imports System.Windows.Forms
 
 
Namespace Tools.Shortcut
 
  Public Class ShellShortcut
    Implements IDisposable
 
    Private Const INFOTIPSIZE As Integer = 1024
    Private Const MAX_PATH As Integer = 260
 
    Private Const SW_SHOWNORMAL As Integer = 1
    Private Const SW_SHOWMINIMIZED As Integer = 2
    Private Const SW_SHOWMAXIMIZED As Integer = 3
    Private Const SW_SHOWMINNOACTIVE As Integer = 7
 
 
#If [UNICODE] Then
    Private m_Link As IShellLinkW
#Else
    Private m_Link As IShellLinkA
#End If
    Private m_sPath As String
 
    '
    ' linkPath: Path to new or existing shortcut file (.lnk).
    '
    Public Sub New(ByVal linkPath As String)
 
      Dim pf As IPersistFile
      Dim CLSID_ShellLink As Guid = New Guid("00021401-0000-0000-C000-000000000046")
      Dim tShellLink As Type
 
      ' Workaround for VB.NET compiler bug with ComImport classes
      '#If [UNICODE] Then
      '      m_Link = CType(New ShellLink(), IShellLinkW)
      '#Else
      '      m_Link = CType(New ShellLink(), IShellLinkA)
      '#End If
      tShellLink = Type.GetTypeFromCLSID(CLSID_ShellLink)
#If [UNICODE] Then
      m_Link = CType(Activator.CreateInstance(tShellLink), IShellLinkW)
#Else
      m_Link = CType(Activator.CreateInstance(tShellLink), IShellLinkA)
#End If
 
 
      m_sPath = linkPath
 
      If File.Exists(linkPath) Then
        pf = CType(m_Link, IPersistFile)
        pf.Load(linkPath, 0)
      End If
 
    End Sub
 
    Public Sub Dispose() Implements IDisposable.Dispose
      If m_Link Is Nothing Then Exit Sub
      Marshal.ReleaseComObject(m_Link)
      m_Link = Nothing
    End Sub
 
 
    '
    ' Gets or sets the argument list of the shortcut.
    '
    Public Property Arguments() As String
      Get
        Dim sb As StringBuilder = New StringBuilder(INFOTIPSIZE)
        m_Link.GetArguments(sb, sb.Capacity)
        Return sb.ToString()
      End Get
      Set(ByVal Value As String)
        m_Link.SetArguments(Value)
      End Set
    End Property
 
    '
    ' Gets or sets a description of the shortcut.
    '
    Public Property Description() As String
      Get
        Dim sb As StringBuilder = New StringBuilder(INFOTIPSIZE)
        m_Link.GetDescription(sb, sb.Capacity)
        Return sb.ToString()
      End Get
      Set(ByVal Value As String)
        m_Link.SetDescription(Value)
      End Set
    End Property
 
    '
    ' Gets or sets the working directory (aka start in directory) of the shortcut.
    '
    Public Property WorkingDirectory() As String
      Get
        Dim sb As StringBuilder = New StringBuilder(MAX_PATH)
        m_Link.GetWorkingDirectory(sb, sb.Capacity)
        Return sb.ToString()
      End Get
      Set(ByVal Value As String)
        m_Link.SetWorkingDirectory(Value)
      End Set
    End Property
 
    '
    ' If Path returns an empty string, the shortcut is associated with
    ' a PIDL instead, which can be retrieved with IShellLink.GetIDList().
    ' This is beyond the scope of this wrapper class.
    '
    ' Gets or sets the target path of the shortcut.
    '
    Public Property Path() As String
      Get
#If [UNICODE] Then
        Dim wfd As WIN32_FIND_DATAW
#Else
        Dim wfd As WIN32_FIND_DATAA
#End If
        Dim sb As StringBuilder = New StringBuilder(MAX_PATH)
        m_Link.GetPath(sb, sb.Capacity, wfd, SLGP_FLAGS.SLGP_UNCPRIORITY)
        Return sb.ToString()
      End Get
      Set(ByVal Value As String)
        m_Link.SetPath(Value)
      End Set
    End Property
 
    '
    ' Gets or sets the path of the Icon assigned to the shortcut.
    '
    Public Property IconPath() As String
      Get
        Dim sb As StringBuilder = New StringBuilder(MAX_PATH)
        Dim nIconIdx As Integer
        m_Link.GetIconLocation(sb, sb.Capacity, nIconIdx)
        Return sb.ToString()
      End Get
      Set(ByVal Value As String)
        m_Link.SetIconLocation(Value, IconIndex)
      End Set
    End Property
 
    '
    ' Gets or sets the index of the Icon assigned to the shortcut.
    ' Set to zero when the IconPath property specifies a .ICO file.
    '
    Public Property IconIndex() As Integer
      Get
        Dim sb As StringBuilder = New StringBuilder(MAX_PATH)
        Dim nIconIdx As Integer
        m_Link.GetIconLocation(sb, sb.Capacity, nIconIdx)
        Return nIconIdx
      End Get
      Set(ByVal Value As Integer)
        m_Link.SetIconLocation(IconPath, Value)
      End Set
    End Property
 
    '
    ' Retrieves the Icon of the shortcut as it will appear in Explorer.
    ' Use the IconPath and IconIndex properties to change it.
    '
    Public ReadOnly Property Icon() As Icon
      Get
        Dim sb As StringBuilder = New StringBuilder(MAX_PATH)
        Dim nIconIdx As Integer
        Dim hIcon, hInst As IntPtr
        Dim ico, clone As Icon
 
 
        m_Link.GetIconLocation(sb, sb.Capacity, nIconIdx)
 
        hInst = Marshal.GetHINSTANCE(Me.GetType().Module)
        hIcon = Native.ExtractIcon(hInst, sb.ToString(), nIconIdx)
        If hIcon.ToInt32() = 0 Then Return Nothing
 
        ' Return a cloned Icon, because we have to free the original ourself.
        ico = Icon.FromHandle(hIcon)
        clone = CType(ico.Clone(), Icon)
        ico.Dispose()
        Native.DestroyIcon(hIcon)
        Return clone
 
      End Get
    End Property
 
    '
    ' Gets or sets the System.Diagnostics.ProcessWindowStyle value
    ' that decides the initial show state of the shortcut target. Note that
    ' ProcessWindowStyle.Hidden is not a valid property value.
    '
    Public Property WindowStyle() As ProcessWindowStyle
      Get
        Dim nWS As Integer
        m_Link.GetShowCmd(nWS)
 
        Select Case nWS
          Case SW_SHOWMINIMIZED, SW_SHOWMINNOACTIVE
            Return ProcessWindowStyle.Minimized
          Case SW_SHOWMAXIMIZED
            Return ProcessWindowStyle.Maximized
          Case Else
            Return ProcessWindowStyle.Normal
        End Select
      End Get
      Set(ByVal Value As ProcessWindowStyle)
        Dim nWS As Integer
 
        Select Case Value
          Case ProcessWindowStyle.Normal
            nWS = SW_SHOWNORMAL
          Case ProcessWindowStyle.Minimized
            nWS = SW_SHOWMINNOACTIVE
          Case ProcessWindowStyle.Maximized
            nWS = SW_SHOWMAXIMIZED
          Case Else ' ProcessWindowStyle.Hidden
            Throw New ArgumentException("Unsupported ProcessWindowStyle value.")
        End Select
        m_Link.SetShowCmd(nWS)
      End Set
    End Property
 
    '
    ' Gets or sets the hotkey for the shortcut.
    '
    Public Property Hotkey() As Keys
      Get
        Dim wHotkey As Short
        Dim dwHotkey As Integer
 
        m_Link.GetHotkey(wHotkey)
 
        '
        ' Convert from IShellLink 16-bit format to Keys enumeration 32-bit value
        ' IShellLink: &HMMVK
        ' Keys:  &H00MM00VK        
        '   MM = Modifier (Alt, Control, Shift)
        '   VK = Virtual key code
        '   
        dwHotkey = (wHotkey And &HFF00I) * &H100I Or (wHotkey And &HFFI)
        Return CType(dwHotkey, Keys)
 
      End Get
      Set(ByVal Value As Keys)
        Dim wHotkey As Short
 
        If (Value And Keys.Modifiers) = 0 Then
          Throw New ArgumentException("Hotkey must include a modifier key.")
        End If
 
        '
        ' Convert from Keys enumeration 32-bit value to IShellLink 16-bit format
        ' IShellLink: &HMMVK
        ' Keys:  &H00MM00VK        
        '   MM = Modifier (Alt, Control, Shift)
        '   VK = Virtual key code
        '   
        wHotkey = CShort(CInt(Value And Keys.Modifiers) \ &H100) Or CShort(Value And Keys.KeyCode)
        m_Link.SetHotkey(wHotkey)
 
      End Set
    End Property
 
    '
    ' Saves the shortcut to disk.
    '
    Public Sub Save()
      Dim pf As IPersistFile = CType(m_Link, IPersistFile)
      pf.Save(m_sPath, True)
    End Sub
 
    '
    ' Returns a reference to the internal ShellLink object,
    ' which can be used to perform more advanced operations
    ' not supported by this wrapper class, by using the
    ' IShellLink interface directly.
    '
    Public ReadOnly Property ShellLink() As Object
      Get
        Return m_Link
      End Get
    End Property
 
 
#Region "Native Win32 API functions"
    Private Class Native
 
      <DllImport("shell32.dll", CharSet:=CharSet.Auto)> _
      Public Shared Function ExtractIcon(ByVal hInst As IntPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Integer) As IntPtr
      End Function
 
      <DllImport("user32.dll")> _
      Public Shared Function DestroyIcon(ByVal hIcon As IntPtr) As Boolean
      End Function
 
    End Class
#End Region
 
  End Class
End Namespace
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Filename:     ShellLinkNative.vb
' Author:       Mattias Sjögren (mattias@mvps.org)
'               http://www.msjogren.net/dotnet/
'
' Description:  Defines the native types used to manipulate shell shortcuts.
'
' Public types: Enum SLR_FLAGS
'               Enum SLGP_FLAGS
'               Structure WIN32_FIND_DATA[A|W]
'               Interface IPersistFile
'               Interface IShellLink[A|W]
'               (Class ShellLink)
'
'
' Copyright ©2001-2002, Mattias Sjögren
' 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

 
Namespace Tools.Shortcut
 
    ' IShellLink.Resolve fFlags
    <Flags()> _
    Public Enum SLR_FLAGS
        SLR_NO_UI = &H1
        SLR_ANY_MATCH = &H2
        SLR_UPDATE = &H4
        SLR_NOUPDATE = &H8
        SLR_NOSEARCH = &H10
        SLR_NOTRACK = &H20
        SLR_NOLINKINFO = &H40
        SLR_INVOKE_MSI = &H80
    End Enum
 
    ' IShellLink.GetPath fFlags
    <Flags()> _
    Public Enum SLGP_FLAGS
        SLGP_SHORTPATH = &H1
        SLGP_UNCPRIORITY = &H2
        SLGP_RAWPATH = &H4
    End Enum
 
    <StructLayoutAttribute(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Public Structure WIN32_FIND_DATAA
        Public dwFileAttributes As Integer
        Public ftCreationTime As FILETIME
        Public ftLastAccessTime As FILETIME
        Public ftLastWriteTime As FILETIME
        Public nFileSizeHigh As Integer
        Public nFileSizeLow As Integer
        Public dwReserved0 As Integer
        Public dwReserved1 As Integer
        <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=MAX_PATH)> Public cFileName As String
        <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=14)> Public cAlternateFileName As String
        Private Const MAX_PATH As Integer = 260
    End Structure
 
    <StructLayoutAttribute(LayoutKind.Sequential, CharSet:=CharSet.Unicode)> Public Structure WIN32_FIND_DATAW
        Public dwFileAttributes As Integer
        Public ftCreationTime As FILETIME
        Public ftLastAccessTime As FILETIME
        Public ftLastWriteTime As FILETIME
        Public nFileSizeHigh As Integer
        Public nFileSizeLow As Integer
        Public dwReserved0 As Integer
        Public dwReserved1 As Integer
        <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=MAX_PATH)> Public cFileName As String
        <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=14)> Public cAlternateFileName As String
        Private Const MAX_PATH As Integer = 260
    End Structure
 
    < _
      ComImport(), _
      InterfaceType(ComInterfaceType.InterfaceIsIUnknown), _
      Guid("0000010B-0000-0000-C000-000000000046") _
    > _
    Public Interface IPersistFile
 
#Region "Methods inherited from IPersist"
 
        Sub GetClassID( _
          <Out()> ByRef pClassID As Guid)
 
#End Region
 
        <PreserveSig()> _
        Function IsDirty() As Integer
 
        Sub Load( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszFileName As String, _
          ByVal dwMode As Integer)
 
        Sub Save( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszFileName As String, _
          <MarshalAs(UnmanagedType.Bool)> ByVal fRemember As Boolean)
 
        Sub SaveCompleted( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszFileName As String)
 
        Sub GetCurFile( _
          ByRef ppszFileName As IntPtr)
 
    End Interface
 
    < _
      ComImport(), _
      InterfaceType(ComInterfaceType.InterfaceIsIUnknown), _
      Guid("000214EE-0000-0000-C000-000000000046") _
    > _
    Public Interface IShellLinkA
 
        Sub GetPath( _
          <Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszFile As StringBuilder, _
          ByVal cchMaxPath As Integer, _
          <Out()> ByRef pfd As WIN32_FIND_DATAA, _
          ByVal fFlags As SLGP_FLAGS)
 
        Sub GetIDList( _
          ByRef ppidl As IntPtr)
 
        Sub SetIDList( _
          ByVal pidl As IntPtr)
 
        Sub GetDescription( _
          <Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszName As StringBuilder, _
          ByVal cchMaxName As Integer)
 
        Sub SetDescription( _
          <MarshalAs(UnmanagedType.LPStr)> ByVal pszName As String)
 
        Sub GetWorkingDirectory( _
          <Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszDir As StringBuilder, _
          ByVal cchMaxPath As Integer)
 
        Sub SetWorkingDirectory( _
          <MarshalAs(UnmanagedType.LPStr)> ByVal pszDir As String)
 
        Sub GetArguments( _
          <Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszArgs As StringBuilder, _
          ByVal cchMaxPath As Integer)
 
        Sub SetArguments( _
          <MarshalAs(UnmanagedType.LPStr)> ByVal pszArgs As String)
 
        Sub GetHotkey( _
          ByRef pwHotkey As Short)
 
        Sub SetHotkey( _
          ByVal wHotkey As Short)
 
        Sub GetShowCmd( _
          ByRef piShowCmd As Integer)
 
        Sub SetShowCmd( _
          ByVal iShowCmd As Integer)
 
        Sub GetIconLocation( _
          <Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszIconPath As StringBuilder, _
          ByVal cchIconPath As Integer, _
          ByRef piIcon As Integer)
 
        Sub SetIconLocation( _
          <MarshalAs(UnmanagedType.LPStr)> ByVal pszIconPath As String, _
          ByVal iIcon As Integer)
 
        Sub SetRelativePath( _
          <MarshalAs(UnmanagedType.LPStr)> ByVal pszPathRel As String, _
          ByVal dwReserved As Integer)
 
        Sub Resolve( _
          ByVal hwnd As IntPtr, _
          ByVal fFlags As SLR_FLAGS)
 
        Sub SetPath( _
          <MarshalAs(UnmanagedType.LPStr)> ByVal pszFile As String)
 
    End Interface
 
    < _
      ComImport(), _
      InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown), _
      Guid("000214F9-0000-0000-C000-000000000046") _
    > _
    Public Interface IShellLinkW
 
        Sub GetPath( _
          <Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszFile As StringBuilder, _
          ByVal cchMaxPath As Integer, _
          <Out()> ByRef pfd As WIN32_FIND_DATAW, _
          ByVal fFlags As SLGP_FLAGS)
 
        Sub GetIDList( _
          ByRef ppidl As IntPtr)
 
        Sub SetIDList( _
          ByVal pidl As IntPtr)
 
        Sub GetDescription( _
          <Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszName As StringBuilder, _
          ByVal cchMaxName As Integer)
 
        Sub SetDescription( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszName As String)
 
        Sub GetWorkingDirectory( _
          <Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszDir As StringBuilder, _
          ByVal cchMaxPath As Integer)
 
        Sub SetWorkingDirectory( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszDir As String)
 
        Sub GetArguments( _
          <Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszArgs As StringBuilder, _
          ByVal cchMaxPath As Integer)
 
        Sub SetArguments( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszArgs As String)
 
        Sub GetHotkey( _
          ByRef pwHotkey As Short)
 
        Sub SetHotkey( _
          ByVal wHotkey As Short)
 
        Sub GetShowCmd( _
          ByRef piShowCmd As Integer)
 
        Sub SetShowCmd( _
          ByVal iShowCmd As Integer)
 
        Sub GetIconLocation( _
          <Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszIconPath As StringBuilder, _
          ByVal cchIconPath As Integer, _
          ByRef piIcon As Integer)
 
        Sub SetIconLocation( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszIconPath As String, _
          ByVal iIcon As Integer)
 
        Sub SetRelativePath( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszPathRel As String, _
          ByVal dwReserved As Integer)
 
        Sub Resolve( _
          ByVal hwnd As IntPtr, _
          ByVal fFlags As SLR_FLAGS)
 
        Sub SetPath( _
          <MarshalAs(UnmanagedType.LPWStr)> ByVal pszFile As String)
 
    End Interface
 
 
    ' The following does currently not compile correctly. Use
    ' Type.GetTypeFromCLSID() and Activator.CreateInstance() instead.
    '
    '< _
    '  ComImport(), _
    '  Guid("00021401-0000-0000-C000-000000000046") _
    '> _
    'Public Class ShellLink
    '  'Implements IPersistFile
    '  'Implements IShellLinkA
    '  'Implements IShellLinkW
    'End Class

End Namespace

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

512

513

514

515

516

517

518

519

520

521

522

523

524

525

526

527

528

529

530

531

532

533

534

535

536

537

538

539

540

541

542

543

544

545

546

547

548

549

550

551

552

553

554

555

556

557

558

559

560

561

562

563

564

565

566

567

568

569

570

571

572

573

574

575

576

Imports System

Imports System.Text

Imports System.Runtime.InteropServices

Imports System.Diagnostics

Imports System.Drawing

Imports System.IO

Imports System.Windows.Forms

Namespace Tools.Shortcut

Public Class ShellShortcut

Implements IDisposable

Private Const INFOTIPSIZE As Integer = 1024

Private Const MAX_PATH As Integer = 260

Private Const SW_SHOWNORMAL As Integer = 1

Private Const SW_SHOWMINIMIZED As Integer = 2

Private Const SW_SHOWMAXIMIZED As Integer = 3

Private Const SW_SHOWMINNOACTIVE As Integer = 7

#If [UNICODE] Then

Private m_Link As IShellLinkW

#Else

Private m_Link As IShellLinkA

#End If

Private m_sPath As String

' linkPath: Path to new or existing shortcut file (.lnk).

Public Sub New(ByVal linkPath As String)

Dim pf As IPersistFile

Dim CLSID_ShellLink As Guid = New Guid("00021401-0000-0000-C000-000000000046")

Dim tShellLink As Type

' Workaround for VB.NET compiler bug with ComImport classes

'#If [UNICODE] Then

' m_Link = CType(New ShellLink(), IShellLinkW)

'#Else

' m_Link = CType(New ShellLink(), IShellLinkA)

'#End If

tShellLink = Type.GetTypeFromCLSID(CLSID_ShellLink)

#If [UNICODE] Then

m_Link = CType(Activator.CreateInstance(tShellLink), IShellLinkW)

#Else

m_Link = CType(Activator.CreateInstance(tShellLink), IShellLinkA)

#End If

m_sPath = linkPath

If File.Exists(linkPath) Then

pf = CType(m_Link, IPersistFile)

pf.Load(linkPath, 0)

End If

End Sub

Public Sub Dispose() Implements IDisposable.Dispose

If m_Link Is Nothing Then Exit Sub

Marshal.ReleaseComObject(m_Link)

m_Link = Nothing

End Sub

' Gets or sets the argument list of the shortcut.

Public Property Arguments() As String

Get

Dim sb As StringBuilder = New StringBuilder(INFOTIPSIZE)

m_Link.GetArguments(sb, sb.Capacity)

Return sb.ToString()

End Get

Set(ByVal Value As String)

m_Link.SetArguments(Value)

End Set

End Property

' Gets or sets a description of the shortcut.

Public Property Description() As String

Get

Dim sb As StringBuilder = New StringBuilder(INFOTIPSIZE)

m_Link.GetDescription(sb, sb.Capacity)

Return sb.ToString()

End Get

Set(ByVal Value As String)

m_Link.SetDescription(Value)

End Set

End Property

' Gets or sets the working directory (aka start in directory) of the shortcut.

Public Property WorkingDirectory() As String

Get

Dim sb As StringBuilder = New StringBuilder(MAX_PATH)

m_Link.GetWorkingDirectory(sb, sb.Capacity)

Return sb.ToString()

End Get

Set(ByVal Value As String)

m_Link.SetWorkingDirectory(Value)

End Set

End Property

' If Path returns an empty string, the shortcut is associated with

' a PIDL instead, which can be retrieved with IShellLink.GetIDList().

' This is beyond the scope of this wrapper class.

' Gets or sets the target path of the shortcut.

Public Property Path() As String

Get

#If [UNICODE] Then

Dim wfd As WIN32_FIND_DATAW

#Else

Dim wfd As WIN32_FIND_DATAA

#End If

Dim sb As StringBuilder = New StringBuilder(MAX_PATH)

m_Link.GetPath(sb, sb.Capacity, wfd, SLGP_FLAGS.SLGP_UNCPRIORITY)

Return sb.ToString()

End Get

Set(ByVal Value As String)

m_Link.SetPath(Value)

End Set

End Property

' Gets or sets the path of the Icon assigned to the shortcut.

Public Property IconPath() As String

Get

Dim sb As StringBuilder = New StringBuilder(MAX_PATH)

Dim nIconIdx As Integer

m_Link.GetIconLocation(sb, sb.Capacity, nIconIdx)

Return sb.ToString()

End Get

Set(ByVal Value As String)

m_Link.SetIconLocation(Value, IconIndex)

End Set

End Property

' Gets or sets the index of the Icon assigned to the shortcut.

' Set to zero when the IconPath property specifies a .ICO file.

Public Property IconIndex() As Integer

Get

Dim sb As StringBuilder = New StringBuilder(MAX_PATH)

Dim nIconIdx As Integer

m_Link.GetIconLocation(sb, sb.Capacity, nIconIdx)

Return nIconIdx

End Get

Set(ByVal Value As Integer)

m_Link.SetIconLocation(IconPath, Value)

End Set

End Property

' Retrieves the Icon of the shortcut as it will appear in Explorer.

' Use the IconPath and IconIndex properties to change it.

Public ReadOnly Property Icon() As Icon

Get

Dim sb As StringBuilder = New StringBuilder(MAX_PATH)

Dim nIconIdx As Integer

Dim hIcon, hInst As IntPtr

Dim ico, clone As Icon

m_Link.GetIconLocation(sb, sb.Capacity, nIconIdx)

hInst = Marshal.GetHINSTANCE(Me.GetType().Module)

hIcon = Native.ExtractIcon(hInst, sb.ToString(), nIconIdx)

If hIcon.ToInt32() = 0 Then Return Nothing

' Return a cloned Icon, because we have to free the original ourself.

ico = Icon.FromHandle(hIcon)

clone = CType(ico.Clone(), Icon)

ico.Dispose()

Native.DestroyIcon(hIcon)

Return clone

End Get

End Property

' Gets or sets the System.Diagnostics.ProcessWindowStyle value

' that decides the initial show state of the shortcut target. Note that

' ProcessWindowStyle.Hidden is not a valid property value.

Public Property WindowStyle() As ProcessWindowStyle

Get

Dim nWS As Integer

m_Link.GetShowCmd(nWS)

Select Case nWS

Case SW_SHOWMINIMIZED, SW_SHOWMINNOACTIVE

Return ProcessWindowStyle.Minimized

Case SW_SHOWMAXIMIZED

Return ProcessWindowStyle.Maximized

Case Else

Return ProcessWindowStyle.Normal

End Select

End Get

Set(ByVal Value As ProcessWindowStyle)

Dim nWS As Integer

Select Case Value

Case ProcessWindowStyle.Normal

nWS = SW_SHOWNORMAL

Case ProcessWindowStyle.Minimized

nWS = SW_SHOWMINNOACTIVE

Case ProcessWindowStyle.Maximized

nWS = SW_SHOWMAXIMIZED

Case Else ' ProcessWindowStyle.Hidden

Throw New ArgumentException("Unsupported ProcessWindowStyle value.")

End Select

m_Link.SetShowCmd(nWS)

End Set

End Property

' Gets or sets the hotkey for the shortcut.

Public Property Hotkey() As Keys

Get

Dim wHotkey As Short

Dim dwHotkey As Integer

m_Link.GetHotkey(wHotkey)

' Convert from IShellLink 16-bit format to Keys enumeration 32-bit value

' IShellLink: &HMMVK

' Keys: &H00MM00VK

' MM = Modifier (Alt, Control, Shift)

' VK = Virtual key code

dwHotkey = (wHotkey And &HFF00I) * &H100I Or (wHotkey And &HFFI)

Return CType(dwHotkey, Keys)

End Get

Set(ByVal Value As Keys)

Dim wHotkey As Short

If (Value And Keys.Modifiers) = 0 Then

Throw New ArgumentException("Hotkey must include a modifier key.")

End If

' Convert from Keys enumeration 32-bit value to IShellLink 16-bit format

' IShellLink: &HMMVK

' Keys: &H00MM00VK

' MM = Modifier (Alt, Control, Shift)

' VK = Virtual key code

wHotkey = CShort(CInt(Value And Keys.Modifiers) \ &H100) Or CShort(Value And Keys.KeyCode)

m_Link.SetHotkey(wHotkey)

End Set

End Property

' Saves the shortcut to disk.

Public Sub Save()

Dim pf As IPersistFile = CType(m_Link, IPersistFile)

pf.Save(m_sPath, True)

End Sub

' Returns a reference to the internal ShellLink object,

' which can be used to perform more advanced operations

' not supported by this wrapper class, by using the

' IShellLink interface directly.

Public ReadOnly Property ShellLink() As Object

Get

Return m_Link

End Get

End Property

#Region "Native Win32 API functions"

Private Class Native

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

Public Shared Function ExtractIcon(ByVal hInst As IntPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Integer) As IntPtr

End Function

<DllImport("user32.dll")> _

Public Shared Function DestroyIcon(ByVal hIcon As IntPtr) As Boolean

End Function

End Class

#End Region

End Class

End Namespace

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' Filename: ShellLinkNative.vb

' Author: Mattias Sjögren (mattias@mvps.org)

' http://www.msjogren.net/dotnet/

' Description: Defines the native types used to manipulate shell shortcuts.

' Public types: Enum SLR_FLAGS

' Enum SLGP_FLAGS

' Structure WIN32_FIND_DATA[A|W]

' Interface IPersistFile

' Interface IShellLink[A|W]

' (Class ShellLink)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Namespace Tools.Shortcut

' IShellLink.Resolve fFlags

<Flags()> _

Public Enum SLR_FLAGS

SLR_NO_UI = &H1

SLR_ANY_MATCH = &H2

SLR_UPDATE = &H4

SLR_NOUPDATE = &H8

SLR_NOSEARCH = &H10

SLR_NOTRACK = &H20

SLR_NOLINKINFO = &H40

SLR_INVOKE_MSI = &H80

End Enum

' IShellLink.GetPath fFlags

<Flags()> _

Public Enum SLGP_FLAGS

SLGP_SHORTPATH = &H1

SLGP_UNCPRIORITY = &H2

SLGP_RAWPATH = &H4

End Enum

<StructLayoutAttribute(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Public Structure WIN32_FIND_DATAA

Public dwFileAttributes As Integer

Public ftCreationTime As FILETIME

Public ftLastAccessTime As FILETIME

Public ftLastWriteTime As FILETIME

Public nFileSizeHigh As Integer

Public nFileSizeLow As Integer

Public dwReserved0 As Integer

Public dwReserved1 As Integer

<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=MAX_PATH)> Public cFileName As String

<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=14)> Public cAlternateFileName As String

Private Const MAX_PATH As Integer = 260

End Structure

<StructLayoutAttribute(LayoutKind.Sequential, CharSet:=CharSet.Unicode)> Public Structure WIN32_FIND_DATAW

Public dwFileAttributes As Integer

Public ftCreationTime As FILETIME

Public ftLastAccessTime As FILETIME

Public ftLastWriteTime As FILETIME

Public nFileSizeHigh As Integer

Public nFileSizeLow As Integer

Public dwReserved0 As Integer

Public dwReserved1 As Integer

<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=MAX_PATH)> Public cFileName As String

<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=14)> Public cAlternateFileName As String

Private Const MAX_PATH As Integer = 260

End Structure

< _

ComImport(), _

InterfaceType(ComInterfaceType.InterfaceIsIUnknown), _

Guid("0000010B-0000-0000-C000-000000000046") _

> _

Public Interface IPersistFile

#Region "Methods inherited from IPersist"

Sub GetClassID( _

<Out()> ByRef pClassID As Guid)

#End Region

<PreserveSig()> _

Function IsDirty() As Integer

Sub Load( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszFileName As String, _

ByVal dwMode As Integer)

Sub Save( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszFileName As String, _

<MarshalAs(UnmanagedType.Bool)> ByVal fRemember As Boolean)

Sub SaveCompleted( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszFileName As String)

Sub GetCurFile( _

ByRef ppszFileName As IntPtr)

End Interface

< _

ComImport(), _

InterfaceType(ComInterfaceType.InterfaceIsIUnknown), _

Guid("000214EE-0000-0000-C000-000000000046") _

> _

Public Interface IShellLinkA

Sub GetPath( _

<Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszFile As StringBuilder, _

ByVal cchMaxPath As Integer, _

<Out()> ByRef pfd As WIN32_FIND_DATAA, _

ByVal fFlags As SLGP_FLAGS)

Sub GetIDList( _

ByRef ppidl As IntPtr)

Sub SetIDList( _

ByVal pidl As IntPtr)

Sub GetDescription( _

<Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszName As StringBuilder, _

ByVal cchMaxName As Integer)

Sub SetDescription( _

<MarshalAs(UnmanagedType.LPStr)> ByVal pszName As String)

Sub GetWorkingDirectory( _

<Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszDir As StringBuilder, _

ByVal cchMaxPath As Integer)

Sub SetWorkingDirectory( _

<MarshalAs(UnmanagedType.LPStr)> ByVal pszDir As String)

Sub GetArguments( _

<Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszArgs As StringBuilder, _

ByVal cchMaxPath As Integer)

Sub SetArguments( _

<MarshalAs(UnmanagedType.LPStr)> ByVal pszArgs As String)

Sub GetHotkey( _

ByRef pwHotkey As Short)

Sub SetHotkey( _

ByVal wHotkey As Short)

Sub GetShowCmd( _

ByRef piShowCmd As Integer)

Sub SetShowCmd( _

ByVal iShowCmd As Integer)

Sub GetIconLocation( _

<Out(), MarshalAs(UnmanagedType.LPStr)> ByVal pszIconPath As StringBuilder, _

ByVal cchIconPath As Integer, _

ByRef piIcon As Integer)

Sub SetIconLocation( _

<MarshalAs(UnmanagedType.LPStr)> ByVal pszIconPath As String, _

ByVal iIcon As Integer)

Sub SetRelativePath( _

<MarshalAs(UnmanagedType.LPStr)> ByVal pszPathRel As String, _

ByVal dwReserved As Integer)

Sub Resolve( _

ByVal hwnd As IntPtr, _

ByVal fFlags As SLR_FLAGS)

Sub SetPath( _

<MarshalAs(UnmanagedType.LPStr)> ByVal pszFile As String)

End Interface

< _

ComImport(), _

InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown), _

Guid("000214F9-0000-0000-C000-000000000046") _

> _

Public Interface IShellLinkW

Sub GetPath( _

<Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszFile As StringBuilder, _

ByVal cchMaxPath As Integer, _

<Out()> ByRef pfd As WIN32_FIND_DATAW, _

ByVal fFlags As SLGP_FLAGS)

Sub GetIDList( _

ByRef ppidl As IntPtr)

Sub SetIDList( _

ByVal pidl As IntPtr)

Sub GetDescription( _

<Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszName As StringBuilder, _

ByVal cchMaxName As Integer)

Sub SetDescription( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszName As String)

Sub GetWorkingDirectory( _

<Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszDir As StringBuilder, _

ByVal cchMaxPath As Integer)

Sub SetWorkingDirectory( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszDir As String)

Sub GetArguments( _

<Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszArgs As StringBuilder, _

ByVal cchMaxPath As Integer)

Sub SetArguments( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszArgs As String)

Sub GetHotkey( _

ByRef pwHotkey As Short)

Sub SetHotkey( _

ByVal wHotkey As Short)

Sub GetShowCmd( _

ByRef piShowCmd As Integer)

Sub SetShowCmd( _

ByVal iShowCmd As Integer)

Sub GetIconLocation( _

<Out(), MarshalAs(UnmanagedType.LPWStr)> ByVal pszIconPath As StringBuilder, _

ByVal cchIconPath As Integer, _

ByRef piIcon As Integer)

Sub SetIconLocation( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszIconPath As String, _

ByVal iIcon As Integer)

Sub SetRelativePath( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszPathRel As String, _

ByVal dwReserved As Integer)

Sub Resolve( _

ByVal hwnd As IntPtr, _

ByVal fFlags As SLR_FLAGS)

Sub SetPath( _

<MarshalAs(UnmanagedType.LPWStr)> ByVal pszFile As String)

End Interface

' The following does currently not compile correctly. Use

' Type.GetTypeFromCLSID() and Activator.CreateInstance() instead.

'< _

' ComImport(), _

' Guid("00021401-0000-0000-C000-000000000046") _

'> _

'Public Class ShellLink

' 'Implements IPersistFile

' 'Implements IShellLinkA

' 'Implements IShellLinkW

'End Class

End Namespace

Tools.ServiceWrapper

No Comments

Imports System.Runtime.InteropServices
 
Namespace Tools
	Public Class ServiceWrapper
		<DllImport("advapi32.dll", EntryPoint:="OpenSCManagerW", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function OpenSCManager(ByVal lpMachingName As String, _
									  ByVal lpDatabaseName As String, _
									  ByVal dwDesiredAccess As SCM_ACCESS) As IntPtr
		End Function
 
		<DllImport("advapi32.dll", EntryPoint:="OpenServiceW", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function OpenService(ByVal SC_HANDLE As IntPtr, _
									ByVal strServiceName As String, _
									ByVal dwDesiredAccess As SERVICE_ACCESS) As IntPtr
		End Function
 
		<DllImport("advapi32.dll", EntryPoint:="CloseServiceHandle", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function CloseServiceHandle(ByVal SC_HANDLE As IntPtr) As Boolean
		End Function
 
		<DllImport("advapi32.dll", EntryPoint:="QueryServiceConfigW", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function QueryServiceConfig(ByVal SC_HANDLE As IntPtr, _
										   ByVal pBuffer As IntPtr, _
										   ByVal cbBufSize As Int32, _
										   ByRef pcbBytesNeeded As Int32) As Boolean
		End Function
 
		<DllImport("advapi32.dll", EntryPoint:="QueryServiceConfig2W", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function QueryServiceConfig2(ByVal SC_HANDLE As IntPtr, _
											ByVal dwInfoLevel As Int32, _
											ByVal pBuffer As IntPtr, _
											ByVal cbBufSize As Int32, _
											ByRef pcbBytesNeeded As Int32) As Boolean
		End Function
 
		<DllImport("advapi32.dll", EntryPoint:="CreateServiceW", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function CreateService(ByVal SC_HANDLE As IntPtr, _
									  ByVal lpServiceName As String, _
									  ByVal lpDisplayName As String, _
									  ByVal dwDesiredAccess As SERVICE_ACCESS, _
									  ByVal dwServiceType As SERVICE_TYPE, _
									  ByVal dwStartType As SERVICE_START_TYPE, _
									  ByVal dwErrorControl As SERVICE_ERROR_CONTROL, _
									  ByVal lpBinaryPathName As String, _
									  ByVal lpLoadOrderGroup As String, _
									  ByVal lpdwTagId As Int32, _
									  ByVal lpDependencies As String, _
									  ByVal lpServiceUserName As String, _
									  ByVal lpPassword As String) As IntPtr
		End Function
 
		<DllImport("advapi32.dll", EntryPoint:="DeleteService", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function DeleteService(ByVal SC_HANDLE As IntPtr) As Boolean
		End Function
 
		<DllImport("advapi32.dll", entryPoint:="ChangeServiceConfigW", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function ChangeServiceConfig(ByVal SC_HANDLE As IntPtr, _
									 ByVal dwServiceType As SERVICE_TYPE, _
									 ByVal dwStartType As SERVICE_START_TYPE, _
									 ByVal dwErrorControl As SERVICE_ERROR_CONTROL, _
									 ByVal lpBinaryPathName As String, _
									 ByVal lpLoadOrderGroup As String, _
									 ByVal lpdwTagId As Int32, _
									 ByVal lpDependencies As String, _
									 ByVal lpServiceStartName As String, _
									 ByVal lpPassword As String, _
									 ByVal lpDisplayName As String) As Boolean
		End Function
 
		<DllImport("advapi32.dll", entryPoint:="ChangeServiceConfig2W", SetLastError:=True, CharSet:=CharSet.Unicode)> _
		Private Shared Function ChangeServiceConfig2(ByVal SC_HANDLE As IntPtr, _
									  ByVal dwInfoLevel As Int32, _
									  ByVal lpInfo As IntPtr) As Boolean
		End Function
 
		Private Enum PVT_WIN32_ERRORS As Int32
			ERROR_SUCCESS = &H0
			ERROR_ACCESS_DENIED = &H5
			ERROR_INVALID_HANDLE = &H6
			ERROR_INVALID_PARAMETER = &H57
			ERROR_INSUFFICIENT_BUFFER = &H7A
			ERROR_INVALID_NAME = &H7B
			ERROR_INVALID_SERVICE_ACCOUNT = &H421
			ERROR_CIRCULAR_DEPENDENCY = &H423
			ERROR_SERVICE_DOES_NOT_EXIST = &H424
			ERROR_DATABASE_DOES_NOT_EXIST = &H429
			ERROR_SERVICE_EXISTS = &H431
			ERROR_DUPLICATE_SERVICE_NAME = &H436
			ERROR_SERVICE_MARKED_FOR_DELETE = &H430
		End Enum
 
		Private Enum SCM_ACCESS As Int32
			SC_MANAGER_CONNECT = &H1
			SC_MANAGER_CREATE_SERVICE = &H2
			SC_MANAGER_ENUMERATE_SERVICE = &H4
			SC_MANAGER_LOCK = &H8
			SC_MANAGER_QUERY_LOCK_STATUS = &H10
			SC_MANAGER_MODIFY_BOOT_CONFIG = &H20
			STANDARD_RIGHTS_REQUIRED = &HF000
			GENERIC_WRITE = &H40000000
			SC_MANAGER_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED And SC_MANAGER_CONNECT And SC_MANAGER_CREATE_SERVICE And SC_MANAGER_ENUMERATE_SERVICE And SC_MANAGER_LOCK And SC_MANAGER_QUERY_LOCK_STATUS And SC_MANAGER_MODIFY_BOOT_CONFIG
		End Enum
 
		Private Enum SERVICE_ACCESS As Int32
			SERVICE_QUERY_CONFIG = &H1
			SERVICE_CHANGE_CONFIG = &H2
			SERVICE_QUERY_STATUS = &H4
			SERVICE_ENUMERATE_DEPENDENTS = &H8
			SERVICE_START = &H10
			SERVICE_STOP = &H20
			SERVICE_PAUSE_CONTINUE = &H40
			SERVICE_INTERROGATE = &H80
			SERVICE_USER_DEFINED_CONTROL = &H100
			SERVICE_DELETE = &H10000
			SERVICE_ALL_RIGHTS = &HF01FF
		End Enum
 
		Public Enum SERVICE_TYPE As Int32
			SERVICE_KERNEL_DRIVER = &H1
			SERVICE_FILE_SYSTEM_DRIVER = &H2
			SERVICE_WIN32_OWN_PROCESS = &H10
			SERVICE_WIN32_SHARE_PROCESS = &H20
			SERVICE_INTERACTIVE_PROCESS = &H100
			SERVICE_NO_CHANGE = &HFFFFFFFF
		End Enum
 
		Public Enum SERVICE_START_TYPE As Int32
			SERVICE_BOOT_START = &H0
			SERVICE_SYSTEM_START = &H1
			SERVICE_AUTO_START = &H2
			SERVICE_DEMAND_START = &H3
			SERVICE_DISABLED = &H4
			SERVICE_NO_CHANGE = &HFFFFFFFF
		End Enum
 
		Public Enum SERVICE_ERROR_CONTROL As Int32
			SERVICE_ERROR_IGNORE = &H0
			SERVICE_ERROR_NORMAL = &H1
			SERVICE_ERROR_SEVERS = &H2
			SERVICE_ERROR_CRITICAL = &H3
			SERVICE_NO_CHANGE = &HFFFFFFFF
		End Enum
 
		<StructLayout(LayoutKind.Sequential)> _
		Private Structure SERVICE_DESCRIPTION
			<MarshalAs(UnmanagedType.LPTStr)> Dim lpDescription As String
		End Structure
 
		<StructLayout(LayoutKind.Sequential)> _
		Public Structure QUERY_SERVICE_CONFIG
			Dim dwServiceType As SERVICE_TYPE
			Dim dwStartType As SERVICE_START_TYPE
			Dim dwErrorControl As SERVICE_ERROR_CONTROL
			<MarshalAs(UnmanagedType.LPTStr)> Dim lpBinaryPathName As String
			<MarshalAs(UnmanagedType.LPTStr)> Dim lpLoadOrderGroup As String
			Dim dwTagId As Int32
			<MarshalAs(UnmanagedType.LPTStr)> Dim lpDependencies As String
			<MarshalAs(UnmanagedType.LPTStr)> Dim lpServiceStartName As String
			<MarshalAs(UnmanagedType.LPTStr)> Dim lpDisplayName As String
		End Structure
 
		Private Const SERVICE_CONFIG_DESCRIPTION As Int32 = 1
 
		Public Function InstallService(ByVal ServiceName As String, ByVal DisplayName As String, ByVal CommandLine As String, Optional ByVal ServiceType As SERVICE_TYPE = SERVICE_TYPE.SERVICE_WIN32_OWN_PROCESS, Optional ByVal StartType As SERVICE_START_TYPE = SERVICE_START_TYPE.SERVICE_DEMAND_START, Optional ByVal Username As String = Nothing, Optional ByVal Password As String = Nothing) As Boolean
			Debug.Print("InstallService")
			Dim retval As Boolean = True
 
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_CREATE_SERVICE)
			If hSCManager = 0 Then
				Debug.WriteLine("  OpenSCManager returned " & Marshal.GetLastWin32Error.ToString)
				retval = False
			Else
				Dim hService As IntPtr = CreateService(hSCManager, ServiceName, DisplayName, SERVICE_ACCESS.SERVICE_ALL_RIGHTS, ServiceType, StartType, SERVICE_ERROR_CONTROL.SERVICE_ERROR_NORMAL, CommandLine, Nothing, Nothing, Nothing, Username, Password)
				If hService = 0 Then
					Debug.WriteLine("  CreateService returned " & Marshal.GetLastWin32Error.ToString)
					retval = False
				Else
					CloseServiceHandle(hService)
				End If
				CloseServiceHandle(hSCManager)
			End If
 
			Return retval
		End Function
 
		Public Function UninstallService(ByVal ServiceName As String) As Boolean
			Debug.WriteLine("UninstallService")
			Dim retval As Boolean = True
 
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			If hSCManager = 0 Then
				Debug.WriteLine("  OpenSCManager returned " & Marshal.GetLastWin32Error.ToString)
				retval = False
			Else
				Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_ALL_RIGHTS)
				If hService = 0 Then
					Debug.WriteLine("  OpenService returned " & Marshal.GetLastWin32Error.ToString)
					retval = False
				Else
					If DeleteService(hService) = False Then
						Debug.WriteLine("  DeleteService returned " & Marshal.GetLastWin32Error.ToString)
						retval = False
					End If
					CloseServiceHandle(hService)
				End If
				CloseServiceHandle(hSCManager)
			End If
 
			Return retval
		End Function
 
		Public Function GetServiceDescription(ByVal ServiceName As String) As String
			Debug.WriteLine("GetServiceDescription")
			Dim retval As String = ""
 
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_QUERY_CONFIG)
			Dim hBuffer As IntPtr
			Dim iBytesNeeded As Integer = 0
			QueryServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, hBuffer, iBytesNeeded, iBytesNeeded)
			hBuffer = Marshal.AllocHGlobal(iBytesNeeded)
			QueryServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, hBuffer, iBytesNeeded, iBytesNeeded)
			Dim sdInfo As SERVICE_DESCRIPTION = Marshal.PtrToStructure(hBuffer, GetType(SERVICE_DESCRIPTION))
			retval = sdInfo.lpDescription
			Marshal.FreeHGlobal(hBuffer)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
			Return retval
		End Function
 
		Public Function GetServiceConfig(ByVal ServiceName As String) As QUERY_SERVICE_CONFIG
			Dim retval As QUERY_SERVICE_CONFIG
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)
			Dim hBuffer As IntPtr
			Dim iBytesNeeded As Integer = 0
			QueryServiceConfig(hService, hBuffer, iBytesNeeded, iBytesNeeded)
			hBuffer = Marshal.AllocHGlobal(iBytesNeeded)
			QueryServiceConfig(hService, hBuffer, iBytesNeeded, iBytesNeeded)
			retval = Marshal.PtrToStructure(hBuffer, GetType(QUERY_SERVICE_CONFIG))
			Marshal.FreeHGlobal(hBuffer)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
			Return retval
		End Function
 
		Public Sub SetServiceDescription(ByVal ServiceName As String, ByVal SetDescription As String)
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)
			Dim sdInfo As SERVICE_DESCRIPTION
			sdInfo.lpDescription = SetDescription
			Dim hBuffer As IntPtr = Marshal.AllocHGlobal(Marshal.SizeOf(sdInfo))
			Marshal.StructureToPtr(sdInfo, hBuffer, False)
			ChangeServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, hBuffer)
			Marshal.FreeHGlobal(hBuffer)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
		End Sub
 
		Public Sub SetServiceLogon(ByVal ServiceName As String, Optional ByVal NewUsername As String = Nothing, Optional ByVal NewPassword As String = Nothing)
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)
			ChangeServiceConfig(hService, SERVICE_TYPE.SERVICE_NO_CHANGE, SERVICE_START_TYPE.SERVICE_NO_CHANGE, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, Nothing, Nothing, Nothing, Nothing, NewUsername, NewPassword, Nothing)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
		End Sub
 
		Public Sub SetServiceDisplayName(ByVal ServiceName As String, ByVal NewDisplayName As String)
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)
			ChangeServiceConfig(hService, SERVICE_TYPE.SERVICE_NO_CHANGE, SERVICE_START_TYPE.SERVICE_NO_CHANGE, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, NewDisplayName)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
		End Sub
 
		Public Sub SetServiceType(ByVal ServiceName As String, ByVal NewType As SERVICE_TYPE)
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)
			ChangeServiceConfig(hService, NewType, SERVICE_START_TYPE.SERVICE_NO_CHANGE, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
		End Sub
 
		Public Sub SetServiceStartType(ByVal ServiceName As String, ByVal NewStartType As SERVICE_START_TYPE)
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)
			ChangeServiceConfig(hService, SERVICE_TYPE.SERVICE_NO_CHANGE, NewStartType, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
		End Sub
 
		Public Sub SetServiceCommandLine(ByVal ServiceName As String, ByVal NewCommandline As String)
			Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)
			Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)
			ChangeServiceConfig(hService, SERVICE_TYPE.SERVICE_NO_CHANGE, SERVICE_START_TYPE.SERVICE_NO_CHANGE, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, NewCommandLine, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
			CloseServiceHandle(hService)
			CloseServiceHandle(hSCManager)
		End Sub
	End Class
End Namespace

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

Imports System.Runtime.InteropServices

Namespace Tools

Public Class ServiceWrapper

<DllImport("advapi32.dll", EntryPoint:="OpenSCManagerW", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function OpenSCManager(ByVal lpMachingName As String, _

ByVal lpDatabaseName As String, _

ByVal dwDesiredAccess As SCM_ACCESS) As IntPtr

End Function

<DllImport("advapi32.dll", EntryPoint:="OpenServiceW", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function OpenService(ByVal SC_HANDLE As IntPtr, _

ByVal strServiceName As String, _

ByVal dwDesiredAccess As SERVICE_ACCESS) As IntPtr

End Function

<DllImport("advapi32.dll", EntryPoint:="CloseServiceHandle", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function CloseServiceHandle(ByVal SC_HANDLE As IntPtr) As Boolean

End Function

<DllImport("advapi32.dll", EntryPoint:="QueryServiceConfigW", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function QueryServiceConfig(ByVal SC_HANDLE As IntPtr, _

ByVal pBuffer As IntPtr, _

ByVal cbBufSize As Int32, _

ByRef pcbBytesNeeded As Int32) As Boolean

End Function

<DllImport("advapi32.dll", EntryPoint:="QueryServiceConfig2W", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function QueryServiceConfig2(ByVal SC_HANDLE As IntPtr, _

ByVal dwInfoLevel As Int32, _

ByVal pBuffer As IntPtr, _

ByVal cbBufSize As Int32, _

ByRef pcbBytesNeeded As Int32) As Boolean

End Function

<DllImport("advapi32.dll", EntryPoint:="CreateServiceW", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function CreateService(ByVal SC_HANDLE As IntPtr, _

ByVal lpServiceName As String, _

ByVal lpDisplayName As String, _

ByVal dwDesiredAccess As SERVICE_ACCESS, _

ByVal dwServiceType As SERVICE_TYPE, _

ByVal dwStartType As SERVICE_START_TYPE, _

ByVal dwErrorControl As SERVICE_ERROR_CONTROL, _

ByVal lpBinaryPathName As String, _

ByVal lpLoadOrderGroup As String, _

ByVal lpdwTagId As Int32, _

ByVal lpDependencies As String, _

ByVal lpServiceUserName As String, _

ByVal lpPassword As String) As IntPtr

End Function

<DllImport("advapi32.dll", EntryPoint:="DeleteService", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function DeleteService(ByVal SC_HANDLE As IntPtr) As Boolean

End Function

<DllImport("advapi32.dll", entryPoint:="ChangeServiceConfigW", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function ChangeServiceConfig(ByVal SC_HANDLE As IntPtr, _

ByVal dwServiceType As SERVICE_TYPE, _

ByVal dwStartType As SERVICE_START_TYPE, _

ByVal dwErrorControl As SERVICE_ERROR_CONTROL, _

ByVal lpBinaryPathName As String, _

ByVal lpLoadOrderGroup As String, _

ByVal lpdwTagId As Int32, _

ByVal lpDependencies As String, _

ByVal lpServiceStartName As String, _

ByVal lpPassword As String, _

ByVal lpDisplayName As String) As Boolean

End Function

<DllImport("advapi32.dll", entryPoint:="ChangeServiceConfig2W", SetLastError:=True, CharSet:=CharSet.Unicode)> _

Private Shared Function ChangeServiceConfig2(ByVal SC_HANDLE As IntPtr, _

ByVal dwInfoLevel As Int32, _

ByVal lpInfo As IntPtr) As Boolean

End Function

Private Enum PVT_WIN32_ERRORS As Int32

ERROR_SUCCESS = &H0

ERROR_ACCESS_DENIED = &H5

ERROR_INVALID_HANDLE = &H6

ERROR_INVALID_PARAMETER = &H57

ERROR_INSUFFICIENT_BUFFER = &H7A

ERROR_INVALID_NAME = &H7B

ERROR_INVALID_SERVICE_ACCOUNT = &H421

ERROR_CIRCULAR_DEPENDENCY = &H423

ERROR_SERVICE_DOES_NOT_EXIST = &H424

ERROR_DATABASE_DOES_NOT_EXIST = &H429

ERROR_SERVICE_EXISTS = &H431

ERROR_DUPLICATE_SERVICE_NAME = &H436

ERROR_SERVICE_MARKED_FOR_DELETE = &H430

End Enum

Private Enum SCM_ACCESS As Int32

SC_MANAGER_CONNECT = &H1

SC_MANAGER_CREATE_SERVICE = &H2

SC_MANAGER_ENUMERATE_SERVICE = &H4

SC_MANAGER_LOCK = &H8

SC_MANAGER_QUERY_LOCK_STATUS = &H10

SC_MANAGER_MODIFY_BOOT_CONFIG = &H20

STANDARD_RIGHTS_REQUIRED = &HF000

GENERIC_WRITE = &H40000000

SC_MANAGER_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED And SC_MANAGER_CONNECT And SC_MANAGER_CREATE_SERVICE And SC_MANAGER_ENUMERATE_SERVICE And SC_MANAGER_LOCK And SC_MANAGER_QUERY_LOCK_STATUS And SC_MANAGER_MODIFY_BOOT_CONFIG

End Enum

Private Enum SERVICE_ACCESS As Int32

SERVICE_QUERY_CONFIG = &H1

SERVICE_CHANGE_CONFIG = &H2

SERVICE_QUERY_STATUS = &H4

SERVICE_ENUMERATE_DEPENDENTS = &H8

SERVICE_START = &H10

SERVICE_STOP = &H20

SERVICE_PAUSE_CONTINUE = &H40

SERVICE_INTERROGATE = &H80

SERVICE_USER_DEFINED_CONTROL = &H100

SERVICE_DELETE = &H10000

SERVICE_ALL_RIGHTS = &HF01FF

End Enum

Public Enum SERVICE_TYPE As Int32

SERVICE_KERNEL_DRIVER = &H1

SERVICE_FILE_SYSTEM_DRIVER = &H2

SERVICE_WIN32_OWN_PROCESS = &H10

SERVICE_WIN32_SHARE_PROCESS = &H20

SERVICE_INTERACTIVE_PROCESS = &H100

SERVICE_NO_CHANGE = &HFFFFFFFF

End Enum

Public Enum SERVICE_START_TYPE As Int32

SERVICE_BOOT_START = &H0

SERVICE_SYSTEM_START = &H1

SERVICE_AUTO_START = &H2

SERVICE_DEMAND_START = &H3

SERVICE_DISABLED = &H4

SERVICE_NO_CHANGE = &HFFFFFFFF

End Enum

Public Enum SERVICE_ERROR_CONTROL As Int32

SERVICE_ERROR_IGNORE = &H0

SERVICE_ERROR_NORMAL = &H1

SERVICE_ERROR_SEVERS = &H2

SERVICE_ERROR_CRITICAL = &H3

SERVICE_NO_CHANGE = &HFFFFFFFF

End Enum

<StructLayout(LayoutKind.Sequential)> _

Private Structure SERVICE_DESCRIPTION

<MarshalAs(UnmanagedType.LPTStr)> Dim lpDescription As String

End Structure

<StructLayout(LayoutKind.Sequential)> _

Public Structure QUERY_SERVICE_CONFIG

Dim dwServiceType As SERVICE_TYPE

Dim dwStartType As SERVICE_START_TYPE

Dim dwErrorControl As SERVICE_ERROR_CONTROL

<MarshalAs(UnmanagedType.LPTStr)> Dim lpBinaryPathName As String

<MarshalAs(UnmanagedType.LPTStr)> Dim lpLoadOrderGroup As String

Dim dwTagId As Int32

<MarshalAs(UnmanagedType.LPTStr)> Dim lpDependencies As String

<MarshalAs(UnmanagedType.LPTStr)> Dim lpServiceStartName As String

<MarshalAs(UnmanagedType.LPTStr)> Dim lpDisplayName As String

End Structure

Private Const SERVICE_CONFIG_DESCRIPTION As Int32 = 1

Public Function InstallService(ByVal ServiceName As String, ByVal DisplayName As String, ByVal CommandLine As String, Optional ByVal ServiceType As SERVICE_TYPE = SERVICE_TYPE.SERVICE_WIN32_OWN_PROCESS, Optional ByVal StartType As SERVICE_START_TYPE = SERVICE_START_TYPE.SERVICE_DEMAND_START, Optional ByVal Username As String = Nothing, Optional ByVal Password As String = Nothing) As Boolean

Debug.Print("InstallService")

Dim retval As Boolean = True

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_CREATE_SERVICE)

If hSCManager = 0 Then

Debug.WriteLine(" OpenSCManager returned " & Marshal.GetLastWin32Error.ToString)

retval = False

Else

Dim hService As IntPtr = CreateService(hSCManager, ServiceName, DisplayName, SERVICE_ACCESS.SERVICE_ALL_RIGHTS, ServiceType, StartType, SERVICE_ERROR_CONTROL.SERVICE_ERROR_NORMAL, CommandLine, Nothing, Nothing, Nothing, Username, Password)

If hService = 0 Then

Debug.WriteLine(" CreateService returned " & Marshal.GetLastWin32Error.ToString)

retval = False

Else

CloseServiceHandle(hService)

End If

CloseServiceHandle(hSCManager)

End If

Return retval

End Function

Public Function UninstallService(ByVal ServiceName As String) As Boolean

Debug.WriteLine("UninstallService")

Dim retval As Boolean = True

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

If hSCManager = 0 Then

Debug.WriteLine(" OpenSCManager returned " & Marshal.GetLastWin32Error.ToString)

retval = False

Else

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_ALL_RIGHTS)

If hService = 0 Then

Debug.WriteLine(" OpenService returned " & Marshal.GetLastWin32Error.ToString)

retval = False

Else

If DeleteService(hService) = False Then

Debug.WriteLine(" DeleteService returned " & Marshal.GetLastWin32Error.ToString)

retval = False

End If

CloseServiceHandle(hService)

End If

CloseServiceHandle(hSCManager)

End If

Return retval

End Function

Public Function GetServiceDescription(ByVal ServiceName As String) As String

Debug.WriteLine("GetServiceDescription")

Dim retval As String = ""

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_QUERY_CONFIG)

Dim hBuffer As IntPtr

Dim iBytesNeeded As Integer = 0

QueryServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, hBuffer, iBytesNeeded, iBytesNeeded)

hBuffer = Marshal.AllocHGlobal(iBytesNeeded)

QueryServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, hBuffer, iBytesNeeded, iBytesNeeded)

Dim sdInfo As SERVICE_DESCRIPTION = Marshal.PtrToStructure(hBuffer, GetType(SERVICE_DESCRIPTION))

retval = sdInfo.lpDescription

Marshal.FreeHGlobal(hBuffer)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

Return retval

End Function

Public Function GetServiceConfig(ByVal ServiceName As String) As QUERY_SERVICE_CONFIG

Dim retval As QUERY_SERVICE_CONFIG

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)

Dim hBuffer As IntPtr

Dim iBytesNeeded As Integer = 0

QueryServiceConfig(hService, hBuffer, iBytesNeeded, iBytesNeeded)

hBuffer = Marshal.AllocHGlobal(iBytesNeeded)

QueryServiceConfig(hService, hBuffer, iBytesNeeded, iBytesNeeded)

retval = Marshal.PtrToStructure(hBuffer, GetType(QUERY_SERVICE_CONFIG))

Marshal.FreeHGlobal(hBuffer)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

Return retval

End Function

Public Sub SetServiceDescription(ByVal ServiceName As String, ByVal SetDescription As String)

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)

Dim sdInfo As SERVICE_DESCRIPTION

sdInfo.lpDescription = SetDescription

Dim hBuffer As IntPtr = Marshal.AllocHGlobal(Marshal.SizeOf(sdInfo))

Marshal.StructureToPtr(sdInfo, hBuffer, False)

ChangeServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, hBuffer)

Marshal.FreeHGlobal(hBuffer)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

End Sub

Public Sub SetServiceLogon(ByVal ServiceName As String, Optional ByVal NewUsername As String = Nothing, Optional ByVal NewPassword As String = Nothing)

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)

ChangeServiceConfig(hService, SERVICE_TYPE.SERVICE_NO_CHANGE, SERVICE_START_TYPE.SERVICE_NO_CHANGE, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, Nothing, Nothing, Nothing, Nothing, NewUsername, NewPassword, Nothing)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

End Sub

Public Sub SetServiceDisplayName(ByVal ServiceName As String, ByVal NewDisplayName As String)

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

End Sub

Public Sub SetServiceType(ByVal ServiceName As String, ByVal NewType As SERVICE_TYPE)

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)

ChangeServiceConfig(hService, NewType, SERVICE_START_TYPE.SERVICE_NO_CHANGE, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

End Sub

Public Sub SetServiceStartType(ByVal ServiceName As String, ByVal NewStartType As SERVICE_START_TYPE)

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)

ChangeServiceConfig(hService, SERVICE_TYPE.SERVICE_NO_CHANGE, NewStartType, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

End Sub

Public Sub SetServiceCommandLine(ByVal ServiceName As String, ByVal NewCommandline As String)

Dim hSCManager As IntPtr = OpenSCManager(Nothing, Nothing, SCM_ACCESS.SC_MANAGER_ALL_ACCESS)

Dim hService As IntPtr = OpenService(hSCManager, ServiceName, SERVICE_ACCESS.SERVICE_CHANGE_CONFIG)

ChangeServiceConfig(hService, SERVICE_TYPE.SERVICE_NO_CHANGE, SERVICE_START_TYPE.SERVICE_NO_CHANGE, SERVICE_ERROR_CONTROL.SERVICE_NO_CHANGE, NewCommandLine, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)

CloseServiceHandle(hService)

CloseServiceHandle(hSCManager)

End Sub

End Class

End Namespace

Tools.PowerShellScript

No Comments

' Add a reference to:
' C:\Program Files\Reference Assemblies\Microsoft\WindowsPowerShell\v1.0\System.Management.Automation.dll
Imports System.Collections.ObjectModel
Imports System.Management.Automation
Imports System.Management.Automation.Runspaces
 
Imports System.Text
Imports System.IO
 
Namespace Tools
    Public Class PowerShellScript
        Public Event StatusUpdate(ByVal status As String)
 
        Public Function RunScriptText(ByVal scriptText As String) As String
            'Runs PS code and returns the response in string format

            'Create a PS runspace and open it
            RaiseEvent StatusUpdate("Creating runspace")
            Dim myRunSpace As Runspace = RunspaceFactory.CreateRunspace
            myRunSpace.Open()
 
            'Create a pipeline and load it with our script text
            RaiseEvent StatusUpdate("Creating pipeline")
            Dim myPipeline As Pipeline = myRunSpace.CreatePipeline
            myPipeline.Commands.AddScript(scriptText)
 
            'add an extra command to ensure we get a string output
            myPipeline.Commands.Add("Out-String")
 
            'Execute
            RaiseEvent StatusUpdate("Executing script")
            Dim results As Collection(Of PSObject) = myPipeline.Invoke
 
            'Close the runspace
            RaiseEvent StatusUpdate("Closing runspace")
            myRunSpace.Close()
 
            'Put the results in a single string
            RaiseEvent StatusUpdate("Returning results")
            Dim myStringBuilder As New StringBuilder
 
            For Each obj As PSObject In results
                myStringBuilder.AppendLine(obj.ToString)
            Next
 
            'return the results
            Return myStringBuilder.ToString
        End Function
 
        Public Function LoadScriptFile(ByVal scriptFile As String) As String
            Try
                RaiseEvent StatusUpdate("Opening script file")
                Dim sr As New StreamReader(scriptFile)
                RaiseEvent StatusUpdate("Reading script contents")
                Return sr.ReadToEnd()
            Catch ex As Exception
                RaiseEvent StatusUpdate("Error reading file")
                Return "Write-Host 'The file could not be read.'"
            End Try
        End Function
    End Class
End Namespace

' Add a reference to:

' C:\Program Files\Reference Assemblies\Microsoft\WindowsPowerShell\v1.0\System.Management.Automation.dll

Imports System.Collections.ObjectModel

Imports System.Management.Automation

Imports System.Management.Automation.Runspaces

Imports System.Text

Imports System.IO

Namespace Tools

Public Class PowerShellScript

Public Event StatusUpdate(ByVal status As String)

Public Function RunScriptText(ByVal scriptText As String) As String

'Runs PS code and returns the response in string format

'Create a PS runspace and open it

RaiseEvent StatusUpdate("Creating runspace")

Dim myRunSpace As Runspace = RunspaceFactory.CreateRunspace

myRunSpace.Open()

'Create a pipeline and load it with our script text

RaiseEvent StatusUpdate("Creating pipeline")

Dim myPipeline As Pipeline = myRunSpace.CreatePipeline

myPipeline.Commands.AddScript(scriptText)

'add an extra command to ensure we get a string output

myPipeline.Commands.Add("Out-String")

'Execute

RaiseEvent StatusUpdate("Executing script")

Dim results As Collection(Of PSObject) = myPipeline.Invoke

'Close the runspace

RaiseEvent StatusUpdate("Closing runspace")

myRunSpace.Close()

'Put the results in a single string

RaiseEvent StatusUpdate("Returning results")

Dim myStringBuilder As New StringBuilder

For Each obj As PSObject In results

myStringBuilder.AppendLine(obj.ToString)

'return the results

Return myStringBuilder.ToString

End Function

Public Function LoadScriptFile(ByVal scriptFile As String) As String

Try

RaiseEvent StatusUpdate("Opening script file")

Dim sr As New StreamReader(scriptFile)

RaiseEvent StatusUpdate("Reading script contents")

Return sr.ReadToEnd()

Catch ex As Exception

RaiseEvent StatusUpdate("Error reading file")

Return "Write-Host 'The file could not be read.'"

End Try

End Function

End Class

End Namespace

Tools.Mouse

No Comments

Namespace Tools
    Public Class Mouse
        Private Declare Function SetCursorPos Lib "user32" (ByVal x As Integer, ByVal y As Integer) As Integer
        Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As Point) As Integer
        Private Declare Sub mouse_event Lib "user32" Alias "mouse_event" (ByVal dwFlags As MouseFlags, ByVal dx As Integer, ByVal dy As Integer, ByVal cButtons As Integer, ByVal dwExtraInfo As Integer)
        Private WithEvents MouseMon As New Timer
 
        Private Enum MouseFlags As Integer
            LEFTDOWN = &H2
            LEFTUP = &H4
            MIDDLEDOWN = &H20
            MIDDLEUP = &H40
            RIGHTDOWN = &H8
            RIGHTUP = &H10
        End Enum
 
        Public Structure ButtonState
            Shared Left As Boolean = False
            Shared Middle As Boolean = False
            Shared Right As Boolean = False
            Shared X1 As Boolean = False
            Shared X2 As Boolean = False
        End Structure
 
        Public Sub LeftDown()
            mouse_event(MouseFlags.LEFTDOWN, 0, 0, 0, 0)
        End Sub
        Public Sub LeftUp()
            mouse_event(MouseFlags.LEFTUP, 0, 0, 0, 0)
        End Sub
        Public Sub LeftClick()
            LeftDown()
            LeftUp()
        End Sub
 
        Public Sub MiddleDown()
            mouse_event(MouseFlags.MIDDLEDOWN, 0, 0, 0, 0)
        End Sub
        Public Sub MiddleUp()
            mouse_event(MouseFlags.MIDDLEUP, 0, 0, 0, 0)
        End Sub
        Public Sub MiddleClick()
            MiddleDown()
            MiddleUp()
        End Sub
 
        Public Sub RightDown()
            mouse_event(MouseFlags.RIGHTDOWN, 0, 0, 0, 0)
        End Sub
        Public Sub RightUp()
            mouse_event(MouseFlags.RIGHTUP, 0, 0, 0, 0)
        End Sub
        Public Sub RightClick()
            RightDown()
            RightUp()
        End Sub
 
        Public Function GetPosition() As Point
            Dim tempPoint As New Point
            GetCursorPos(tempPoint)
            Return tempPoint
        End Function
 
        Public Sub SetPosition(ByVal newPos As Point)
            SetPosition(newPos.X, newPos.Y)
        End Sub
        Public Sub SetPosition(ByVal x As Integer, ByVal y As Integer)
            SetCursorPos(x, y)
        End Sub
 
        Private Sub MouseMon_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles MouseMon.Tick
            If Control.MouseButtons And MouseButtons.Left Then ButtonState.Left = True Else ButtonState.Left = False
            If Control.MouseButtons And MouseButtons.Middle Then ButtonState.Middle = True Else ButtonState.Middle = False
            If Control.MouseButtons And MouseButtons.Right Then ButtonState.Right = True Else ButtonState.Right = False
            If Control.MouseButtons And MouseButtons.XButton1 Then ButtonState.X1 = True Else ButtonState.X1 = False
            If Control.MouseButtons And MouseButtons.XButton2 Then ButtonState.X2 = True Else ButtonState.X2 = False
        End Sub
 
        Public Sub New()
            MouseMon.Interval = 1
            MouseMon.Enabled = True
        End Sub
    End Class
End Namespace

Namespace Tools

Public Class Mouse

Private Declare Function SetCursorPos Lib "user32" (ByVal x As Integer, ByVal y As Integer) As Integer

Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As Point) As Integer

Private Declare Sub mouse_event Lib "user32" Alias "mouse_event" (ByVal dwFlags As MouseFlags, ByVal dx As Integer, ByVal dy As Integer, ByVal cButtons As Integer, ByVal dwExtraInfo As Integer)

Private WithEvents MouseMon As New Timer

Private Enum MouseFlags As Integer

LEFTDOWN = &H2

LEFTUP = &H4

MIDDLEDOWN = &H20

MIDDLEUP = &H40

RIGHTDOWN = &H8

RIGHTUP = &H10

End Enum

Public Structure ButtonState

Shared Left As Boolean = False

Shared Middle As Boolean = False

Shared Right As Boolean = False

Shared X1 As Boolean = False

Shared X2 As Boolean = False

End Structure

Public Sub LeftDown()

mouse_event(MouseFlags.LEFTDOWN, 0, 0, 0, 0)

End Sub

Public Sub LeftUp()

mouse_event(MouseFlags.LEFTUP, 0, 0, 0, 0)

End Sub

Public Sub LeftClick()

LeftDown()

LeftUp()

End Sub

Public Sub MiddleDown()

mouse_event(MouseFlags.MIDDLEDOWN, 0, 0, 0, 0)

End Sub

Public Sub MiddleUp()

mouse_event(MouseFlags.MIDDLEUP, 0, 0, 0, 0)

End Sub

Public Sub MiddleClick()

MiddleDown()

MiddleUp()

End Sub

Public Sub RightDown()

mouse_event(MouseFlags.RIGHTDOWN, 0, 0, 0, 0)

End Sub

Public Sub RightUp()

mouse_event(MouseFlags.RIGHTUP, 0, 0, 0, 0)

End Sub

Public Sub RightClick()

RightDown()

RightUp()

End Sub

Public Function GetPosition() As Point

Dim tempPoint As New Point

GetCursorPos(tempPoint)

Return tempPoint

End Function

Public Sub SetPosition(ByVal newPos As Point)

SetPosition(newPos.X, newPos.Y)

End Sub

Public Sub SetPosition(ByVal x As Integer, ByVal y As Integer)

SetCursorPos(x, y)

End Sub

Private Sub MouseMon_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles MouseMon.Tick

If Control.MouseButtons And MouseButtons.Left Then ButtonState.Left = True Else ButtonState.Left = False

If Control.MouseButtons And MouseButtons.Middle Then ButtonState.Middle = True Else ButtonState.Middle = False

If Control.MouseButtons And MouseButtons.Right Then ButtonState.Right = True Else ButtonState.Right = False

If Control.MouseButtons And MouseButtons.XButton1 Then ButtonState.X1 = True Else ButtonState.X1 = False

If Control.MouseButtons And MouseButtons.XButton2 Then ButtonState.X2 = True Else ButtonState.X2 = False

End Sub

Public Sub New()

MouseMon.Interval = 1

MouseMon.Enabled = True

End Sub

End Class

End Namespace

Tools.MonitorPower

No Comments

Imports System.Runtime.InteropServices
 
Namespace Tools
  Public Class MonitorPower
      <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
      Private Shared Function SendMessage(ByVal hWnd As Integer, ByVal Msg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
      End Function
 
      Private Const HWND_BROADCAST As Integer = &HFFFF
      Dim WM_SYSCOMMAND As Integer = &H112
      Dim SC_MONITORPOWER As Integer = &HF170
      Dim MON_ON As Integer = -1
      Dim MON_OFF As Integer = 2
 
      Public Sub TurnOn(callingForm As Form)
          Debug.WriteLine("MonitorPowerClass.TurnOn called")
          SendMessage(callingForm.Handle.ToInt32, WM_SYSCOMMAND, SC_MONITORPOWER, MON_ON)
      End Sub
 
      Public Sub TurnOff(callingForm As Form)
          Debug.WriteLine("MonitorPowerClass.TurnOff called")
          SendMessage(callingForm.Handle.ToInt32, WM_SYSCOMMAND, SC_MONITORPOWER, MON_OFF)
      End Sub
  End Class
End Namespace

Imports System.Runtime.InteropServices

Namespace Tools

Public Class MonitorPower

<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _

Private Shared Function SendMessage(ByVal hWnd As Integer, ByVal Msg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer

End Function

Private Const HWND_BROADCAST As Integer = &HFFFF

Dim WM_SYSCOMMAND As Integer = &H112

Dim SC_MONITORPOWER As Integer = &HF170

Dim MON_ON As Integer = -1

Dim MON_OFF As Integer = 2

Public Sub TurnOn(callingForm As Form)

Debug.WriteLine("MonitorPowerClass.TurnOn called")

SendMessage(callingForm.Handle.ToInt32, WM_SYSCOMMAND, SC_MONITORPOWER, MON_ON)

End Sub

Public Sub TurnOff(callingForm As Form)

Debug.WriteLine("MonitorPowerClass.TurnOff called")

SendMessage(callingForm.Handle.ToInt32, WM_SYSCOMMAND, SC_MONITORPOWER, MON_OFF)

End Sub

End Class

End Namespace

Tools.Logdor

No Comments

Imports System.Reflection
 
Namespace Tools
    Public Class Logdor
        Implements IDisposable
 
        Private m_LogToConsole As Boolean = False
        Public Property LogToConsole As Boolean
            Get
                Return m_LogToConsole
            End Get
            Set(ByVal value As Boolean)
                m_LogToConsole = value
            End Set
        End Property
 
        Private m_LogToEventLog As Boolean = False
        Public Property LogToEventLog As Boolean
            Get
                Return m_LogToEventLog
            End Get
            Set(ByVal value As Boolean)
                m_LogToEventLog = value
            End Set
        End Property
 
        Private m_EventLogSource As String = ".NET Application"
        Public Property EventLogSource As String
            Get
                Return m_EventLogSource
            End Get
            Set(ByVal value As String)
                m_EventLogSource = value
            End Set
        End Property
 
        Private m_LogToFile As Boolean = False
        Public Property LogToFile As Boolean
            Get
                Return m_LogToFile
            End Get
            Set(ByVal value As Boolean)
                m_LogToFile = value
            End Set
        End Property
 
        Private m_LogFile As String = "log.txt"
        Public Property LogFile As String
            Get
                Return m_LogFile
            End Get
            Set(ByVal value As String)
                m_LogFile = value
            End Set
        End Property
 
        Private m_UseTimestamp As Boolean = True
        Public Property UseTimeStamp As Boolean
            Get
                Return m_UseTimestamp
            End Get
            Set(ByVal value As Boolean)
                m_UseTimestamp = value
            End Set
        End Property
 
        Private m_TimestampFormat As String = "MM-dd-yy @ HH.mm.ss"
        Public Property TimestampFormat As String
            Get
                Return m_TimestampFormat
            End Get
            Set(ByVal value As String)
                m_TimestampFormat = value
            End Set
        End Property
        Public ReadOnly Property Timestamp As String
            Get
                Return String.Format(m_TimestampFormat, Now)
            End Get
        End Property
 
        Private m_IndentLevel As Integer = 0
        Public Property IndentLevel As Integer
            Get
                Return m_IndentLevel
            End Get
            Set(ByVal value As Integer)
                m_IndentLevel = value
                If m_IndentLevel < 0 Then m_IndentLevel = 0
            End Set
        End Property
 
        Private m_IndentChars As String = "  "
        Public Property IntentChars As String
            Get
                Return m_IndentChars
            End Get
            Set(ByVal value As String)
                m_IndentChars = value
            End Set
        End Property
 
        Private Function IndentString() As String
            Return StrDup(m_IndentLevel, m_IndentChars)
        End Function
 
        Public Enum Indent As Integer
            Add
            Subtract
            NoChange
        End Enum
 
        Public Function IndentAdd() As Integer
            IndentLevel += 1
            Return m_IndentLevel
        End Function
 
        Public Function IndentSubtract() As Integer
            IndentLevel -= 1
            Return m_IndentLevel
        End Function
 
        Public Function ObjectPropertyList(ByRef obj As Object, ByVal objname As String) As List(Of String)
            Dim retval As New List(Of String)
            For Each prop As PropertyInfo In obj.GetType.GetProperties
                Dim propline As New Text.StringBuilder
                propline.Append("[Property]:")
                If objname <> "" Then propline.Append(objname & ".")
                propline.Append(prop.Name & " = ")
                Try
                    If prop.GetValue(obj, New Object() {}) Is Nothing Then
                        propline.AppendLine("<nothing>")
                    Else
                        propline.AppendLine(prop.GetValue(obj, New Object() {}))
                    End If
                Catch ex As Exception
                    propline.AppendLine("Error")
                End Try
                retval.Add(propline.ToString)
            Next
            Return retval
        End Function
 
        Public Function ObjectPropertyString(ByRef obj As Object, ByVal objname As String) As String
            Dim retval As New Text.StringBuilder
            For Each item As String In ObjectPropertyList(obj, objname)
                retval.AppendLine(IndentString() & item)
            Next
            Return retval.ToString
        End Function
 
        Private LogFileIsOpen As Boolean = False
        Private LogWriter As IO.StreamWriter = Nothing
        Public Sub OpenLogFile()
            If Not LogFileIsOpen Then
                Try
                    LogWriter = New IO.StreamWriter(LogFile, True)
                    LogFileIsOpen = True
                Catch ex As Exception
                    LogFileIsOpen = False
                End Try
            End If
        End Sub
        Public Sub CloseLogFile()
            If LogFileIsOpen Then
                Try
                    LogWriter.Flush()
                    LogWriter.Close()
                    LogWriter = Nothing
                    LogFileIsOpen = False
                Catch ex As Exception
                End Try
            End If
        End Sub
 
        Public Sub WriteLog(ByVal LogText As String)
            WriteLog(LogText, EventLogEntryType.Information, 0, Indent.NoChange)
        End Sub
 
        Public Sub WriteLog(ByVal LogText As String, ByVal IndentChange As Indent)
            WriteLog(LogText, EventLogEntryType.Information, 0, IndentChange)
        End Sub
 
        Public Sub WriteLog(ByVal LogText As String, ByVal EventLogType As EventLogEntryType)
            WriteLog(LogText, EventLogType, 0, Indent.NoChange)
        End Sub
 
        Public Sub WriteLog(ByVal LogText As String, ByVal EventLogType As EventLogEntryType, ByVal EventID As Integer)
            WriteLog(LogText, EventLogType, EventID, Indent.NoChange)
        End Sub
 
        Public Sub WriteLog(ByVal LogText As String, ByVal EventLogType As EventLogEntryType, ByVal EventID As Integer, ByVal IndentChange As Indent)
            Dim LogLine As New Text.StringBuilder
 
            If IndentChange = Indent.Add Then IndentLevel += 1
            If IndentChange = Indent.Subtract Then IndentLevel -= 1
 
            If UseTimeStamp Then
                LogLine.Append(Timestamp)
            End If
            LogLine.Append(IndentString)
            LogLine.Append(LogText)
 
 
            Debug.WriteLine(LogLine.ToString)
 
            If LogToConsole Then
                Try
                    Console.WriteLine(LogLine.ToString)
                Catch ex As Exception
                    LogToConsole = False
                    WriteLog("Error writing to console: " & ex.Message)
                End Try
 
            End If
 
 
            If LogToFile Then
                Try
                    If Not LogFileIsOpen Then OpenLogFile()
                    LogWriter.WriteLine(LogLine.ToString)
                Catch ex As Exception
                    LogToFile = False
                    WriteLog("Error writing to file: " & ex.Message)
                End Try
            End If
 
 
            If LogToEventLog Then
                Try
                    EventLog.WriteEntry(EventLogSource, LogText, EventLogType, EventID)
                Catch ex As Exception
                    LogToEventLog = False
                    WriteLog("Error writing to event log: " & ex.Message)
                End Try
            End If
        End Sub
 
        Private disposedValue As Boolean
        Protected Overridable Sub Dispose(ByVal disposing As Boolean)
            If Not Me.disposedValue Then
                If disposing Then
                    If LogFileIsOpen Then
                        CloseLogFile()
                    End If
                End If
            End If
            Me.disposedValue = True
        End Sub
        Public Sub Dispose() Implements IDisposable.Dispose
            Dispose(True)
            GC.SuppressFinalize(Me)
        End Sub
    End Class
End Namespace

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

Imports System.Reflection

Namespace Tools

Public Class Logdor

Implements IDisposable

Private m_LogToConsole As Boolean = False

Public Property LogToConsole As Boolean

Get

Return m_LogToConsole

End Get

Set(ByVal value As Boolean)

m_LogToConsole = value

End Set

End Property

Private m_LogToEventLog As Boolean = False

Public Property LogToEventLog As Boolean

Get

Return m_LogToEventLog

End Get

Set(ByVal value As Boolean)

m_LogToEventLog = value

End Set

End Property

Private m_EventLogSource As String = ".NET Application"

Public Property EventLogSource As String

Get

Return m_EventLogSource

End Get

Set(ByVal value As String)

m_EventLogSource = value

End Set

End Property

Private m_LogToFile As Boolean = False

Public Property LogToFile As Boolean

Get

Return m_LogToFile

End Get

Set(ByVal value As Boolean)

m_LogToFile = value

End Set

End Property

Private m_LogFile As String = "log.txt"

Public Property LogFile As String

Get

Return m_LogFile

End Get

Set(ByVal value As String)

m_LogFile = value

End Set

End Property

Private m_UseTimestamp As Boolean = True

Public Property UseTimeStamp As Boolean

Get

Return m_UseTimestamp

End Get

Set(ByVal value As Boolean)

m_UseTimestamp = value

End Set

End Property

Private m_TimestampFormat As String = "MM-dd-yy @ HH.mm.ss"

Public Property TimestampFormat As String

Get

Return m_TimestampFormat

End Get

Set(ByVal value As String)

m_TimestampFormat = value

End Set

End Property

Public ReadOnly Property Timestamp As String

Get

Return String.Format(m_TimestampFormat, Now)

End Get

End Property

Private m_IndentLevel As Integer = 0

Public Property IndentLevel As Integer

Get

Return m_IndentLevel

End Get

Set(ByVal value As Integer)

m_IndentLevel = value

If m_IndentLevel < 0 Then m_IndentLevel = 0

End Set

End Property

Private m_IndentChars As String = " "

Public Property IntentChars As String

Get

Return m_IndentChars

End Get

Set(ByVal value As String)

m_IndentChars = value

End Set

End Property

Private Function IndentString() As String

Return StrDup(m_IndentLevel, m_IndentChars)

End Function

Public Enum Indent As Integer

Add

Subtract

NoChange

End Enum

Public Function IndentAdd() As Integer

IndentLevel += 1

Return m_IndentLevel

End Function

Public Function IndentSubtract() As Integer

IndentLevel -= 1

Return m_IndentLevel

End Function

Public Function ObjectPropertyList(ByRef obj As Object, ByVal objname As String) As List(Of String)

Dim retval As New List(Of String)

For Each prop As PropertyInfo In obj.GetType.GetProperties

Dim propline As New Text.StringBuilder

propline.Append("[Property]:")

If objname <> "" Then propline.Append(objname & ".")

propline.Append(prop.Name & " = ")

Try

If prop.GetValue(obj, New Object() {}) Is Nothing Then

propline.AppendLine("<nothing>")

Else

propline.AppendLine(prop.GetValue(obj, New Object() {}))

End If

Catch ex As Exception

propline.AppendLine("Error")

End Try

retval.Add(propline.ToString)

Return retval

End Function

Public Function ObjectPropertyString(ByRef obj As Object, ByVal objname As String) As String

Dim retval As New Text.StringBuilder

For Each item As String In ObjectPropertyList(obj, objname)

retval.AppendLine(IndentString() & item)

Return retval.ToString

End Function

Private LogFileIsOpen As Boolean = False

Private LogWriter As IO.StreamWriter = Nothing

Public Sub OpenLogFile()

If Not LogFileIsOpen Then

Try

LogWriter = New IO.StreamWriter(LogFile, True)

LogFileIsOpen = True

Catch ex As Exception

LogFileIsOpen = False

End Try

End If

End Sub

Public Sub CloseLogFile()

If LogFileIsOpen Then

Try

LogWriter.Flush()

LogWriter.Close()

LogWriter = Nothing

LogFileIsOpen = False

Catch ex As Exception

End Try

End If

End Sub

Public Sub WriteLog(ByVal LogText As String)

WriteLog(LogText, EventLogEntryType.Information, 0, Indent.NoChange)

End Sub

Public Sub WriteLog(ByVal LogText As String, ByVal IndentChange As Indent)

WriteLog(LogText, EventLogEntryType.Information, 0, IndentChange)

End Sub

Public Sub WriteLog(ByVal LogText As String, ByVal EventLogType As EventLogEntryType)

WriteLog(LogText, EventLogType, 0, Indent.NoChange)

End Sub

Public Sub WriteLog(ByVal LogText As String, ByVal EventLogType As EventLogEntryType, ByVal EventID As Integer)

WriteLog(LogText, EventLogType, EventID, Indent.NoChange)

End Sub

Public Sub WriteLog(ByVal LogText As String, ByVal EventLogType As EventLogEntryType, ByVal EventID As Integer, ByVal IndentChange As Indent)

Dim LogLine As New Text.StringBuilder

If IndentChange = Indent.Add Then IndentLevel += 1

If IndentChange = Indent.Subtract Then IndentLevel -= 1

If UseTimeStamp Then

LogLine.Append(Timestamp)

End If

LogLine.Append(IndentString)

LogLine.Append(LogText)

Debug.WriteLine(LogLine.ToString)

If LogToConsole Then

Try

Console.WriteLine(LogLine.ToString)

Catch ex As Exception

LogToConsole = False

WriteLog("Error writing to console: " & ex.Message)

End Try

End If

If LogToFile Then

Try

If Not LogFileIsOpen Then OpenLogFile()

LogWriter.WriteLine(LogLine.ToString)

Catch ex As Exception

LogToFile = False

WriteLog("Error writing to file: " & ex.Message)

End Try

End If

If LogToEventLog Then

Try

EventLog.WriteEntry(EventLogSource, LogText, EventLogType, EventID)

Catch ex As Exception

LogToEventLog = False

WriteLog("Error writing to event log: " & ex.Message)

End Try

End If

End Sub

Private disposedValue As Boolean

Protected Overridable Sub Dispose(ByVal disposing As Boolean)

If Not Me.disposedValue Then

If disposing Then

If LogFileIsOpen Then

CloseLogFile()

End If

Me.disposedValue = True

End Sub

Public Sub Dispose() Implements IDisposable.Dispose

Dispose(True)

GC.SuppressFinalize(Me)

End Sub

End Class

End Namespace