Calvin Hsia's WebLog : Windows API

What is your computer doing with all that memory? Write your own memory browser

Calvin_Hsia — Mon, 19 Oct 2009 18:53:00 GMT

What is your computer doing with all that memory? There are various kinds of memory allocated and used in each process. These include:

· Managed memory (VB.Net, C#, managed C++)

· Heap memory

· Stacks

· Images (files loaded into a process)

VirtualAlloc is the basis of these allocations. If a process needs more of these types of memory, VirtualAlloc is called.

You can inspect the various kinds of memory by running the sample code below. It offers a list of current processes, from which you dbl-click one to inspect.

Once you choose a process, a snapshot of all Virtual memory allocations is shown in a ListView, along with the size, type, etc. If it’s an image, the filename is shown too. Hovering over addresses shows the memory contents in a tooltip. Double click to open another window with the entire memory contents. You can read strings in memory in these displays.

One can imagine this being the base of your own custom Task Manager. Perhaps you want to search for all strings in all processes. “Microsoft” occurs quite often!

Imagine taking a memory snapshot of a process, doing something in that process, then taking another snapshot and displaying the difference.

Caveats: you may not have rights to read some processes or some memory. Also, if you build to 32 bit (Project Options->Compile->AdvancedCompileOptions->TargetCPU->AnyCpu) and run on 64 bit, you might have problems.

It can examine both 32 and 64 bit processes. If you get Access Denied on some processes, you might have better luck running it as Administrator

Start Visual Studio 2008

File->New Project->VB WPF Application.

Open Window1.xaml.vb, replace the contents (about 650 lines) with the sample below.

How to Create dynamic XAML to display arbitrary XML

Remove double spaces from pasted code samples in blog

Imports System.Runtime.InteropServices

Class Window1

Private WithEvents _btnRefresh As Button

Private Sub Window1_Loaded(ByVal sender As System.Object, ByVal e As System.Windows.RoutedEventArgs) Handles MyBase.Loaded

Me.Width = 800

Me.Height = 800

RefreshContent()

End Sub

Sub RefreshContent()

Dim q = From proc In System.Diagnostics.Process.GetProcesses _

Select proc.Id, _

proc.ProcessName, _

proc.WorkingSet64, _

proc.PrivateMemorySize64, _

Is64 = ProcessType(proc) _

Order By ProcessName

Me.Title = "Choose a process. Count = " + q.Count.ToString

Dim XAML = _

<Grid

xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"

xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"

<Grid.RowDefinitions>

</Grid.RowDefinitions>

<Button Name="btnRefresh">Refresh</Button>

</StackPanel>

</DockPanel>

</Grid>

Dim gr = CType(System.Windows.Markup.XamlReader.Load(XAML.CreateReader), Grid)

_btnRefresh = CType(gr.FindName("btnRefresh"), Button)

Dim dp = CType(gr.FindName("dp"), DockPanel)

dp.Children.Add(New Browse(q, delDblClick:=AddressOf OnProcWindDblClick))

Me.Content = gr

End Sub

Shared Function ProcessType(ByVal proc As Process) As String

Dim is32 = False

If IntPtr.Size = 4 Then ' 64 bit=8, 32=4

is32 = True

End If

Dim retProcType = "64"

Try

Dim IsrunningUnderWow64 = False

If IsWow64Process(proc.Handle, IsrunningUnderWow64) AndAlso IsrunningUnderWow64 Then

End If

If IsrunningUnderWow64 OrElse is32 Then

retProcType = "32"

End If

Catch ex As Exception

retProcType = ex.Message

End Try

Return retProcType

End Function

<DllImport("Kernel32.dll", SetLastError:=True, CallingConvention:=CallingConvention.Winapi)> _

Public Shared Function IsWow64Process( _

ByVal hProcess As IntPtr, _

<MarshalAs(UnmanagedType.Bool)> ByRef wow64Process As Boolean) As <MarshalAs(UnmanagedType.Bool)> Boolean

End Function

Sub OnbtnRefresh_Click() Handles _btnRefresh.Click

RefreshContent()

End Sub

Sub OnProcWindDblClick(ByVal sender As Object, ByVal e As RoutedEventArgs)

Try

Dim lv = TryCast(sender, Browse)

If lv IsNot Nothing Then

Dim tb = TryCast(e.OriginalSource, TextBlock)

If tb IsNot Nothing Then

Dim dt = tb.DataContext

If dt IsNot Nothing Then

Dim procTarget = tb.Text

Dim q = From a In Process.GetProcessesByName(procTarget)

If q.Count > 0 Then

Dim oWin = New VirtMemWindow(q.First) With {.Owner = Me}

End If

Catch ex As Exception

MessageBox.Show(ex.Message)

End Try

End Sub

Class VirtMemWindow

Inherits Window

Private _proc As Process

Private WithEvents _btnAggregate As Button

Private _Is32 As Boolean

Sub New(ByVal proc As Process)

Dim mbi As New MEMORY_BASIC_INFORMATION

_proc = proc

Dim ptype = ProcessType(_proc)

If ptype = "32" Then

_Is32 = True

ElseIf ptype = "64" Then

_Is32 = False

Else

Throw New InvalidOperationException(ptype)

End If

If IntPtr.Size = 4 AndAlso Not _Is32 Then

Throw New InvalidOperationException("32 bit app can't examine 64 bit process")

End If

Dim lpMem As UInt64 = 0

Do While VirtualQueryEx(_proc.Handle, New UIntPtr(lpMem), mbi, Marshal.SizeOf(mbi)) = Marshal.SizeOf(mbi)

_virtAllocs.Add(mbi)

lpMem = mbi.BaseAddress.ToUInt64 + mbi.RegionSize.ToUInt64

Loop

Dim XAML = _

<Grid

xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"

xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"

<Grid.RowDefinitions>

</Grid.RowDefinitions>

<Button Name="btnAgg">Aggregate</Button>

</StackPanel>

</DockPanel>

</Grid>

Dim gr = CType(System.Windows.Markup.XamlReader.Load(XAML.CreateReader), Grid)

_btnAggregate = CType(gr.FindName("btnAgg"), Button)

Dim dp = CType(gr.FindName("dp"), DockPanel)

If _virtAllocs.Count = 0 Then

dp.Children.Add(New TextBlock With {.Text = "No items found. Perhaps 64/32 bit or Rights issue"})

Else

Dim q = From a In _virtAllocs _

Select AllocationBase = Format64or32(a.AllocationBase), _

BaseAddress = Format64or32(a.BaseAddress), _

RegionSize = Format64or32(a.RegionSize), _

Filename = GetFileNameFromMBI(a), _

AllocationProtect = a.AllocationProtect.ToString, _

AllocationState = a.State.ToString, _

Type = CType(a.lType, AllocationType).ToString _

Order By Filename.ToString.Length Descending

Me.Title += String.Format("{0} Virtual Memory Use #items={1} ", proc.ProcessName, q.Count)

dp.Children.Add(New Browse(q, _

delMouseMove:=AddressOf On_VirtmemMouseMove, _

deldblclick:=AddressOf On_VirtmemDblClick))

End If

Me.Content = gr

Me.Show()

End Sub

Function Format64or32(ByVal num As UIntPtr) As String

Dim retval = ""

If _Is32 Then

retval = num.ToUInt32.ToString("x8")

Else

retval = num.ToUInt64.ToString("x16")

End If

Return retval

End Function

Sub OnbtnAggClick() Handles _btnAggregate.Click

Dim qAgg = From a In _virtAllocs _

Group By AllocationType = a.lType.ToString Into Tot = Sum(a.RegionSize.ToUInt64), Cnt = Count(a.RegionSize.ToUInt64 > 0)

Dim oWin = New Window With {.Title = "Aggregate"}

oWin.Content = New Browse(qAgg)

oWin.Owner = Me

oWin.Show()

End Sub

Private _virtAllocs As New List(Of MEMORY_BASIC_INFORMATION)

Sub On_VirtmemDblClick(ByVal sender As Object, ByVal e As RoutedEventArgs)

Try

Dim lv = TryCast(sender, Browse)

If lv IsNot Nothing Then

Dim tb = TryCast(e.OriginalSource, TextBlock)

If tb IsNot Nothing Then

Select Case tb.Name

Case "AllocationBase", "BaseAddress"

ClearPriorToolTipIfAny()

Dim baseAddr = Convert.ToInt64(tb.Text, 16) ' convert from hex (base 16)

Dim allocQuery = From a In _virtAllocs _

Where If(tb.Name = "AllocationBase", a.AllocationBase, a.BaseAddress) = baseAddr

If allocQuery.Count > 0 Then

Dim virtAlloc = allocQuery.First

Dim strAddrDump = GetAddressDump( _

virtAlloc.BaseAddress, _

virtAlloc.RegionSize, _

nMax:=0 _

)

Dim tbxDump = New TextBox With { _

.Text = strAddrDump, _

.VerticalScrollBarVisibility = ScrollBarVisibility.Auto, _

.BorderThickness = New Windows.Thickness(0), _

.FontFamily = New FontFamily("Courier New"), _

.FontSize = 10 _

}

Dim oWin = New Window With { _

.Title = String.Format("Mem dump Address = {0:x8}, size = {1}", _

tb.Text, _

virtAlloc.RegionSize _

) _

}

oWin.Content = tbxDump

oWin.Owner = Me

oWin.Show()

End If

End Select

End If

Catch ex As Exception

End Try

End Sub

Sub ClearPriorToolTipIfAny()

If _LastTipObj IsNot Nothing Then

Dim lastTip = CType(_LastTipObj.ToolTip, ToolTip)

lastTip.IsOpen = False

_LastTipObj = Nothing

End If

End Sub

Private _LastTipObj As FrameworkElement

Sub On_VirtmemMouseMove(ByVal sender As Object, ByVal e As RoutedEventArgs)

Dim lv = TryCast(sender, Browse)

If lv IsNot Nothing Then

Dim tb = TryCast(e.OriginalSource, TextBlock)

If tb IsNot Nothing Then

' Dim o = lv.ItemContainerGenerator.ContainerFromItem(tb)

If _LastTipObj IsNot Nothing Then

Dim lastTip = CType(_LastTipObj.ToolTip, ToolTip)

If tb Is _LastTipObj Then ' over same obj: don't create a new tip

Return

Else

' different object: close the tip

lastTip.IsOpen = False

End If

Dim dt = tb.DataContext

If dt IsNot Nothing Then

Dim ttipObj = New ToolTip

ttipObj.PlacementTarget = tb

ttipObj.Placement = Controls.Primitives.PlacementMode.Bottom

Select Case tb.Name

Case "AllocationBase", "BaseAddress"

Dim baseAddr = Convert.ToUInt64(tb.Text, 16) ' convert from hex (base 16)

Dim q = From a In _virtAllocs _

Where If(tb.Name = "AllocationBase", a.AllocationBase, a.BaseAddress) = baseAddr

If q.Count > 0 Then

Dim mbi = q.First

Dim baddr = If(tb.Name = "AllocationBase", mbi.AllocationBase, mbi.BaseAddress)

If CType(mbi.State, AllocationState) <> AllocationState.MEM_FREE AndAlso baddr.ToUInt64 > &H1000 Then

Dim strAddrDump = GetAddressDump( _

baddr, _

mbi.RegionSize)

Dim tbxDump = New TextBox With { _

.Text = strAddrDump, _

.BorderThickness = New Windows.Thickness(0), _

.FontFamily = New FontFamily("Courier New"), _

.FontSize = 10, _

.Background = Brushes.LightYellow _

}

Dim sp = New StackPanel With {.Orientation = Orientation.Vertical}

If CType(mbi.lType, AllocationType) = AllocationType.MEM_IMAGE Then

Dim sbFilename As New Text.StringBuilder(300)

Dim rr = GetFileNameFromMBI(mbi)

GetModuleFileNameEx(_proc.Handle, New UIntPtr(mbi.AllocationBase.ToUInt64), sbFilename, sbFilename.Capacity)

sp.Children.Add(New TextBlock With {.Text = "Filename = " + sbFilename.ToString})

End If

sp.Children.Add(tbxDump)

ttipObj.Content = sp

Else

ttipObj.Content = baddr.ToString + " bad address for mem dump"

End If

Case "RegionSize"

ttipObj.Content = String.Format(" Base 10: {0}", Convert.ToInt32(tb.Text, 16))

Case "Where", "Filename"

ttipObj.Content = tb.Text

Case Else

Return

End Select

ToolTipService.SetShowDuration(tb, 100000)

ttipObj.IsOpen = True

tb.ToolTip = ttipObj

_LastTipObj = tb

End If

End Sub

Const BlockSize As Integer = 1024

<StructLayout(LayoutKind.Sequential)> _

Structure ProcMemBlock

<MarshalAs(UnmanagedType.ByValArray, sizeconst:=BlockSize)> _

Dim data() As Byte

End Structure

Public Function GetAddressDump(ByVal nAddress As UIntPtr, ByVal nTotalBytesToRead As UIntPtr, Optional ByVal nMax As Integer = 1024) As String

Dim sbAddrDump As New Text.StringBuilder

Try

If nMax > 0 Then

nTotalBytesToRead = Math.Min(nMax, nTotalBytesToRead.ToUInt64)

End If

Dim blk = New ProcMemBlock

Dim nBytesLeftToRead = nTotalBytesToRead

Do While nBytesLeftToRead.ToUInt64 > 0

Dim nBytesToReadForThisBlock = Math.Min(nBytesLeftToRead.ToUInt64, BlockSize)

Dim nBytesRead As UIntPtr = 0

If ReadProcessMemory(_proc.Handle, nAddress, blk, nBytesToReadForThisBlock, nBytesRead) Then

nBytesLeftToRead = nBytesLeftToRead.ToUInt64 - nBytesRead.ToUInt64

Dim innerCnt = 0

Dim strBytes = ""

Dim strChars = ""

For i = 0 To nBytesRead.ToUInt64 - 1 Step 4

If innerCnt Mod 8 = 0 Then

If i > 0 Then ' if we're ending a line, dump out the bytes and chars

sbAddrDump.AppendLine(" " + strBytes + " " + strChars)

strBytes = ""

strChars = ""

Else

sbAddrDump.AppendLine()

End If

If _Is32 Then

sbAddrDump.Append(String.Format("{0:x8} : ", nAddress.ToUInt32 + CUInt(i)))

Else

Dim offset = nAddress.ToUInt64 + CUInt(i)

sbAddrDump.Append(String.Format("{0:x16} : ", nAddress.ToUInt64 + CUInt(i)))

End If

innerCnt += 1

Dim dword = 0

For p = 0 To 3

dword += CInt(blk.data(i + p)) << shifts(3 - p)

' Dim dword = Marshal.ReadIntPtr(New IntPtr(nAddress + i)).ToInt32

toBytes(dword, strBytes, strChars)

sbAddrDump.Append(String.Format("{0:x8} ", dword))

' some leftovers

Dim startLeftover = innerCnt

Do While innerCnt Mod 8 > 0

sbAddrDump.Append(" ")

innerCnt += 1

Loop

sbAddrDump.AppendLine(" " + strBytes + " ")

innerCnt = startLeftover

Do While innerCnt Mod 8 > 0

sbAddrDump.Append(" ")

innerCnt += 1

Loop

sbAddrDump.AppendLine(strChars)

Do While innerCnt Mod 8 > 0

sbAddrDump.Append(" ")

innerCnt += 1

Loop

Else

Exit Do

End If

nAddress = nAddress.ToUInt64 + nBytesRead.ToUInt64

Loop

Catch ex As Exception

sbAddrDump.Append("Exception when reading " + nAddress.ToString + " " + ex.Message)

End Try

Return sbAddrDump.ToString

End Function

Const badchars = vbCr + vbLf + vbTab + Chr(&HB) + Chr(&HC)

Private Shared shifts As Integer() = {24, 16, 8, 0}

Shared Sub toBytes(ByVal num As Integer, ByRef strBytes As String, ByRef strChars As String)

For i = 3 To 0 Step -1

Dim abyte = CByte((num >> shifts(i) And &HFF))

strBytes += String.Format("{0:x2} ", abyte)

Dim thechar = " "

If abyte > 15 AndAlso abyte < 127 Then

If badchars.IndexOf(thechar) < 0 Then

thechar = Chr(abyte).ToString

End If

strChars += thechar

End Sub

<DllImport("kernel32.dll", SetLastError:=True)> _

Public Shared Function ReadProcessMemory( _

ByVal hProcess As IntPtr, _

ByVal lpBaseAddress As UIntPtr, _

ByRef lpBuffer As ProcMemBlock, _

ByVal dwSize As Integer, _

ByRef lpNumberOfBytesRead As Integer _

) As Integer

End Function

<DllImport("psapi")> _

Shared Function GetModuleFileNameEx(ByVal hProcess As IntPtr, ByVal hModule As UIntPtr, ByVal lpFileName As Text.StringBuilder, ByVal nSize As Integer) As Integer

End Function

<DllImport("kernel32")> _

Shared Function VirtualQueryEx( _

ByVal hProcess As IntPtr, _

ByVal lpAddress As UIntPtr, _

ByRef mbi As MEMORY_BASIC_INFORMATION, _

ByVal dwLength As UInteger) As UInteger

End Function

<StructLayout(LayoutKind.Sequential)> _

Structure MEMORY_BASIC_INFORMATION

Dim BaseAddress As UIntPtr

Dim AllocationBase As UIntPtr

Dim AllocationProtect As AllocationProtect

Dim RegionSize As UIntPtr

Dim State As AllocationState

Dim Protect As AllocationProtect

Dim lType As AllocationType

End Structure

<Flags()> _

Enum AllocationProtect

PAGE_EXECUTE = &H10

PAGE_EXECUTE_READ = &H20

PAGE_EXECUTE_READWRITE = &H40

PAGE_EXECUTE_WRITECOPY = &H80

PAGE_NOACCESS = &H1

PAGE_READONLY = &H2

PAGE_READWRITE = &H4

PAGE_WRITECOPY = &H8

PAGE_GUARD = &H100

PAGE_NOCACHE = &H200

PAGE_WRITECOMBINE = &H400

End Enum

<Flags()> _

Enum AllocationType

MEM_IMAGE = &H1000000

MEM_MAPPED = &H40000

MEM_PRIVATE = &H20000

End Enum

<Flags()> _

Enum AllocationState

MEM_COMMIT = &H1000

MEM_FREE = &H10000

MEM_RESERVE = &H2000

End Enum

Function GetFileNameFromMBI(ByVal mbi As MEMORY_BASIC_INFORMATION) As String

Dim retval = ""

If CType(mbi.lType, AllocationType) = AllocationType.MEM_IMAGE Or True Then

If mbi.AllocationBase.ToUInt64 > 0 Then

Dim sbFilename As New Text.StringBuilder(300)

If GetModuleFileNameEx(_proc.Handle, New UIntPtr(mbi.AllocationBase.ToUInt64), sbFilename, sbFilename.Capacity) > 0 Then

retval = sbFilename.ToString

End If

Return retval

End Function

End Class

' see http://blogs.msdn.com/calvin_hsia/archive/2007/12/06/6684376.aspx

Public Class Browse

Inherits ListView

Private _Browse As Browse = Me

Private _delDblClick As BrowEventDelegate

Private _delMouseMove As BrowEventDelegate

Public _query As IEnumerable

Delegate Sub BrowEventDelegate(ByVal sender As Object, ByVal e As RoutedEventArgs)

Sub New( _

ByVal Query As IEnumerable, _

Optional ByVal delDblClick As BrowEventDelegate = Nothing, _

Optional ByVal delMouseMove As BrowEventDelegate = Nothing, _

Optional ByVal fAllowHeaderClickSort As Boolean = True)

_query = Query

Dim gv As New GridView

_Browse.View = gv

_Browse.ItemsSource = Query

If fAllowHeaderClickSort Then

_Browse.AddHandler(GridViewColumnHeader.ClickEvent, New RoutedEventHandler(AddressOf HandleHeaderClick))

End If

If delDblClick IsNot Nothing Then

_delDblClick = delDblClick

_Browse.AddHandler(MouseDoubleClickEvent, New RoutedEventHandler(AddressOf OnRowDblClickEvent))

End If

If delMouseMove IsNot Nothing Then

_delMouseMove = delMouseMove

_Browse.AddHandler(MouseMoveEvent, New RoutedEventHandler(AddressOf OnMouseMoveEvent))

End If

If Query.GetType.GetInterface(GetType(IEnumerable(Of )).FullName).GetGenericArguments(0).Name = "XElement" Then ' It's XML

Dim Elem1 = CType(Query, IEnumerable(Of XElement))(0).Elements ' Thanks Avner!

For Each Item In Elem1

Dim gvc As New GridViewColumn

gvc.Header = Item.Name.LocalName

gv.Columns.Add(gvc)

Dim bind As New Binding("Element[" + Item.Name.LocalName + "].Value")

gvc.DisplayMemberBinding = bind

gvc.Width = 180

Else ' it's some anonymous type like "VB$AnonymousType_1`3". Let's use reflection to get the column names

For Each mem In From mbr In _

Query.GetType().GetInterface(GetType(IEnumerable(Of )).FullName) _

.GetGenericArguments()(0).GetMembers _

Where mbr.MemberType = Reflection.MemberTypes.Property

Dim datatype = CType(mem, Reflection.PropertyInfo)

Dim coltype = datatype.PropertyType.Name

Select Case coltype

Case "Int32", "String", "Int64"

Dim gvc As New GridViewColumn

gvc.Header = mem.Name

gv.Columns.Add(gvc)

Dim XAMLdt = _

<DataTemplate

xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"

xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"

Text=<%= If(coltype = "String", _

"{Binding Path=" + mem.Name + "}", _

"{Binding Path=" + mem.Name + "}") %>

</TextBlock>

</StackPanel>

</DataTemplate>

gvc.CellTemplate = CType(System.Windows.Markup.XamlReader.Load(XAMLdt.CreateReader), DataTemplate)

If coltype <> "String" Then

' gvc.Width = 80

gvc.Width = Double.NaN ' auto

Else

' gvc.DisplayMemberBinding = New Binding(mem.Name)

' gvc.Width = 180

gvc.Width = Double.NaN ' auto

End If

End Select

End If

Dim XAMLlbStyle = _

<Style

xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"

xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"

TargetType="ListBoxItem">

<Style.Triggers>

</Trigger>

</Trigger>

</Style.Triggers>

</Style>

_Browse.ItemContainerStyle = CType(Windows.Markup.XamlReader.Load(XAMLlbStyle.CreateReader), Windows.Style)

End Sub

Sub OnRowDblClickEvent(ByVal sender As Object, ByVal e As RoutedEventArgs)

If _delDblClick IsNot Nothing Then

_delDblClick.Invoke(sender, e)

End If

End Sub

Sub OnMouseMoveEvent(ByVal sender As Object, ByVal e As RoutedEventArgs)

If _delMouseMove IsNot Nothing Then

_delMouseMove.Invoke(sender, e)

End If

End Sub

Dim _Lastdir As System.ComponentModel.ListSortDirection = ComponentModel.ListSortDirection.Ascending

Dim _LastHeaderClicked As GridViewColumnHeader = Nothing

Sub HandleHeaderClick(ByVal sender As Object, ByVal e As RoutedEventArgs)

If e.OriginalSource.GetType Is GetType(GridViewColumnHeader) Then

Dim gvh = CType(e.OriginalSource, GridViewColumnHeader)

Dim dir As System.ComponentModel.ListSortDirection = ComponentModel.ListSortDirection.Ascending

If Not gvh Is Nothing AndAlso Not gvh.Column Is Nothing Then

If _LastHeaderClicked IsNot Nothing Then

_LastHeaderClicked.Column.HeaderTemplate = Nothing

End If

Dim hdr = gvh.Column.Header

If gvh Is _LastHeaderClicked Then

If _Lastdir = ComponentModel.ListSortDirection.Ascending Then

dir = ComponentModel.ListSortDirection.Descending

End If

gvh.Column.HeaderTemplate = CType(Windows.Markup.XamlReader.Load( _

<DataTemplate

xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"

xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"

<TextBlock HorizontalAlignment="Center"

Text="{Binding}"/>

<Path

Fill="DarkGray"

Data=<%= If(dir = ComponentModel.ListSortDirection.Ascending, _

"M 5,10 L 15,10 L 10,5", _

"M 5,5 L 10,10 L 15,5") %>/>

</DockPanel>

</DataTemplate>.CreateReader), DataTemplate)

Sort(CStr(hdr), dir)

_LastHeaderClicked = gvh

_Lastdir = dir

End If

End Sub

Sub Sort(ByVal sortby As String, ByVal dir As System.ComponentModel.ListSortDirection)

_Browse.Items.SortDescriptions.Clear()

Dim sd = New System.ComponentModel.SortDescription(sortby, dir)

_Browse.Items.SortDescriptions.Add(sd)

_Browse.Items.Refresh()

End Sub

End Class

</code sample>

You can use HWndHost to host a Win32 HWnd window inside a WPF element

Calvin_Hsia — Sat, 29 Nov 2008 09:21:00 GMT

Suppose you have some old code lying around that creates a Win32 window with an HWnd (perhaps ATL, MFC, or just C/ C++). For example, if you type some erroneous code into a VB application in Visual Studio:

Dim x=4: catch ex As Exception

The “Exception” will be squiggled and the end of the squiggle will have a red underline, indicating the presence of a Smart Tag.

You can move your mouse over the red underline or hit Ctrl-Period to invoke the smart tag suggestions for fixing the error. In this case, 2 suggested fixes are suggested in the smart tag menu: to insert Try/End Try in various places.

These suggested fixes show a preview right in the smart tag menu of what the effect is of each possible correction. These windows were written originally with Win32 Hwnds, using ATL.

You might want to take these old Windows and host them in a more modern application, using Windows Presentation Foundation

The sample below creates 4 identical Win32 HWnd windows hosted inside an HwndHost control. This control is then put into 3 WPF Popups and 1 WPF Window. The Win32 windows are simple and the WM_PAINT message just paints green & blue rectangles.

The 3 popups are identical, except that:

#1 has AllowTransparency = false. The Win32 hWnd window shows just fine

#2 has AllowTransparency = true. The Win32 hWnd window doesn’t show at all, but it can be discovered by using Spy++

#3 has AllowTransparency = true, but with the StackPanel inside with a Transparent Background. The Win32 hWnd doesn’t show at all, and you can even click through the popup

A Popup with AllowsTransparency = True requires Full Trust security. See http://blogs.msdn.com/dwayneneed/archive/2008/09/08/transparent-windows-in-wpf.aspx

Start Visual Studio (I was using VS 2008)

Choose File->New Project->Visual Basic->WPF Application.

(This also works with Temporary projects)

Open Window1.xaml.vb. Paste in the code below, then hit F5 to run. Try clicking on the various areas.

See also:

Option Strict On

Imports System.Runtime.InteropServices

Imports System.Windows.Interop

Class Window1

Sub Load() Handles MyBase.Loaded

Me.Width = 600

Me.Height = 600

Dim popupNoTransparency = CreatePopup(False, "NoTransP", "AliceBlue", 0)

Dim popupAllowTransparency = CreatePopup(True, "AllowTransp", "AliceBlue", 300)

Dim popupTransparencyWithTransBack = CreatePopup(True, "popupTransparencyWithTransBack", "Transparent", 600)

Me.Content = CreateUIElem("Main Window", "Bisque")

End Sub

Function CreatePopup(ByVal AllowTransparency As Boolean, ByVal Name As String, ByVal BackGround As String, ByVal Horiz As Integer) As Primitives.Popup

Dim popup = New Primitives.Popup

popup.AllowsTransparency = AllowTransparency

popup.Child = CreateUIElem(Name, BackGround)

popup.Placement = Primitives.PlacementMode.AbsolutePoint

popup.HorizontalOffset = Horiz

popup.IsOpen = True

Return popup

End Function

Function CreateUIElem(ByVal UIElemName As String, ByVal BackGround As String) As UIElement

Dim xaml = _

<StackPanel

xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"

xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"

Name="HwndTest" Width="350" Height="450" Background=<%= BackGround %> Orientation="Vertical" Opacity=".5">

<Button>Bottom Button</Button>

</StackPanel>

Dim UIElem = CType(System.Windows.Markup.XamlReader.Load(xaml.CreateReader), StackPanel)

Dim Border = CType(UIElem.FindName("MyBorder"), UserControl)

Dim oMyHwndHost = New MyHwndHost

Border.Content = oMyHwndHost

Return UIElem

End Function

End Class

Class MyHwndHost

Inherits HwndHost

Protected Overrides Function BuildWindowCore(ByVal hwndParent As System.Runtime.InteropServices.HandleRef) As System.Runtime.InteropServices.HandleRef

Dim hwndMain As IntPtr = CreateWindowEx(0, "static", "", WindowStyles.WS_CHILD Or WindowStyles.WS_HSCROLL Or WindowStyles.WS_VSCROLL, _

0, 0, 200, 300, hwndParent.Handle, IntPtr.Zero, IntPtr.Zero, IntPtr.Zero)

Return New HandleRef(Me, hwndMain)

End Function

Protected Overrides Sub DestroyWindowCore(ByVal hwnd As System.Runtime.InteropServices.HandleRef)

DestroyWindow(hwnd.Handle)

End Sub

Protected Overrides Function WndProc(ByVal hwnd As System.IntPtr, ByVal msg As Integer, ByVal wParam As System.IntPtr, ByVal lParam As System.IntPtr, ByRef handled As Boolean) As System.IntPtr

Select Case msg

Case WM_.WM_PAINT

Dim ps As New PAINTSTRUCT

BeginPaint(hwnd, ps)

Dim hDC = ps.hdc

Dim r = New RECT

GetClientRect(hwnd, r)

r.Right = CInt(r.Right / 2) ' create a rect of left half

Dim hbrGreen = CreateSolidBrush(CType(&HFF00, IntPtr))

Dim hbrBlue = CreateSolidBrush(CType(&HFF0000, IntPtr))

FillRect(hDC, r, hbrGreen)

r.Left += r.Right - r.Left

r.Right *= 2 ' create a rect of right half

FillRect(hDC, r, hbrBlue)

EndPaint(hwnd, ps)

DeleteObject(hbrGreen)

DeleteObject(hbrBlue)

handled = True

Return IntPtr.Zero

End Select

Return MyBase.WndProc(hwnd, msg, wParam, lParam, handled)

End Function

#Region "WIN32 Defs"

Public Enum COLOR

COLOR_SCROLLBAR = 0

COLOR_BACKGROUND = 1

COLOR_DESKTOP = 1

COLOR_ACTIVECAPTION = 2

COLOR_INACTIVECAPTION = 3

COLOR_MENU = 4

COLOR_WINDOW = 5

COLOR_WINDOWFRAME = 6

COLOR_MENUTEXT = 7

COLOR_WINDOWTEXT = 8

COLOR_CAPTIONTEXT = 9

COLOR_ACTIVEBORDER = 10

COLOR_INACTIVEBORDER = 11

COLOR_APPWORKSPACE = 12

COLOR_HIGHLIGHT = 13

COLOR_HIGHLIGHTTEXT = 14

COLOR_BTNFACE = 15

COLOR_3DFACE = 15

COLOR_BTNSHADOW = 16

COLOR_3DSHADOW = 16

COLOR_GRAYTEXT = 17

COLOR_BTNTEXT = 18

COLOR_INACTIVECAPTIONTEXT = 19

COLOR_BTNHIGHLIGHT = 20

COLOR_3DHIGHLIGHT = 20

COLOR_3DHILIGHT = 20

COLOR_BTNHILIGHT = 20

COLOR_3DDKSHADOW = 21

COLOR_3DLIGHT = 22

COLOR_INFOTEXT = 23

COLOR_INFOBK = 24

End Enum

<StructLayout(LayoutKind.Sequential)> _

Public Structure RECT

Public Left As Integer

Public Top As Integer

Public Right As Integer

Public Bottom As Integer

Public Function ToRect() As System.Windows.Rect

Return New System.Windows.Rect(Left, Top, Right - Left, Bottom - Top)

End Function

End Structure

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

Private Shared Function GetClientRect(ByVal hWnd As System.IntPtr, _

ByRef lpRECT As RECT) As Integer

End Function

Enum WM_

WM_PAINT = &HF

End Enum

<Flags()> _

Enum WindowStyles

WS_OVERLAPPED = &H0

WS_POPUP = &H80000000

WS_CHILD = &H40000000

WS_MINIMIZE = &H20000000

WS_VISIBLE = &H10000000

WS_DISABLED = &H8000000

WS_CLIPSIBLINGS = &H4000000

WS_CLIPCHILDREN = &H2000000

WS_MAXIMIZE = &H1000000

WS_BORDER = &H800000

WS_DLGFRAME = &H400000

WS_VSCROLL = &H200000

WS_HSCROLL = &H100000

WS_SYSMENU = &H80000

WS_THICKFRAME = &H40000

WS_GROUP = &H20000

WS_TABSTOP = &H10000

WS_MINIMIZEBOX = &H20000

WS_MAXIMIZEBOX = &H10000

WS_CAPTION = WS_BORDER Or WS_DLGFRAME

WS_TILED = WS_OVERLAPPED

WS_ICONIC = WS_MINIMIZE

WS_SIZEBOX = WS_THICKFRAME

WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW

WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX

WS_POPUPWINDOW = WS_POPUP Or WS_BORDER Or WS_SYSMENU

WS_CHILDWINDOW = WS_CHILD

End Enum

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

Private Shared Function ShowWindow(ByVal hwnd As IntPtr, ByVal nCmdShow As Int32) As Boolean

End Function

<DllImport("user32.dll")> _

Public Shared Function UpdateWindow( _

ByVal hWnd As IntPtr) As <MarshalAs(UnmanagedType.Bool)> Boolean

End Function

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

Private Shared Function CreateWindowEx( _

ByVal dwExStyle As UInteger, _

ByVal lpClassName As String, _

ByVal lpWindowName As String, _

ByVal dwStyle As WindowStyles, _

ByVal x As Integer, _

ByVal y As Integer, _

ByVal nWidth As Integer, _

ByVal nHeight As Integer, _

ByVal hWndParent As IntPtr, _

ByVal hMenut As IntPtr, _

ByVal hInstancet As IntPtr, _

ByVal lpParamt As IntPtr) As IntPtr

End Function

#If 0 Then

hwndMain = CreateWindowEx(

0, // no extended styles

"MainWClass", // class name

"Main Window", // window name

WS_OVERLAPPEDWINDOW | // overlapped window

WS_HSCROLL | // horizontal scroll bar

WS_VSCROLL, // vertical scroll bar

CW_USEDEFAULT, // default horizontal position

CW_USEDEFAULT, // default vertical position

CW_USEDEFAULT, // default width

CW_USEDEFAULT, // default height

(HWND) NULL, // no parent or owner window

(HMENU) NULL, // class menu used

hinstance, // instance handle

NULL); // no window creation data

#End If

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

Private Shared Function DestroyWindow(ByVal hwnd As IntPtr) As Boolean

End Function

Const CW_USEDEFAULT As Int32 = &H80000000

Enum Show_Window

SW_HIDE = 0

SW_SHOWNORMAL = 1

SW_NORMAL = 1

SW_SHOWMINIMIZED = 2

SW_SHOWMAXIMIZED = 3

SW_MAXIMIZE = 3

SW_SHOWNOACTIVATE = 4

SW_SHOW = 5

SW_MINIMIZE = 6

SW_SHOWMINNOACTIVE = 7

SW_SHOWNA = 8

SW_RESTORE = 9

SW_SHOWDEFAULT = 10

SW_FORCEMINIMIZE = 11

SW_MAX = 11

End Enum

<StructLayout(LayoutKind.Sequential, Pack:=4)> _

Public Structure PAINTSTRUCT

Public hdc As IntPtr

Public fErase As Integer

Public rcPaint As RECT

Public fRestore As Integer

Public fIncUpdate As Integer

<MarshalAs(UnmanagedType.ByValArray, SizeConst:=32)> _

Public rgbReserved As Byte()

End Structure

<DllImport("user32.dll")> _

Public Shared Function BeginPaint( _

ByVal hWnd As IntPtr, ByRef lpPaint As PAINTSTRUCT) As IntPtr

End Function

<DllImport("user32.dll")> _

Public Shared Function EndPaint( _

ByVal hWnd As IntPtr, ByRef lpPaint As PAINTSTRUCT) As IntPtr

End Function

<DllImport("user32.dll")> _

Public Shared Function FillRect(ByVal hDC As IntPtr, ByRef lpRect As RECT, ByVal hBR As IntPtr) As IntPtr

End Function

<DllImport("gdi32.dll")> _

Public Shared Function CreateSolidBrush(ByVal crColor As IntPtr) As IntPtr

End Function

<DllImport("gdi32.dll")> _

Public Shared Function DeleteObject(ByVal hObject As IntPtr) As IntPtr

End Function

#End Region

End Class

</Sample Code>

Dynamically load a DLL from a runtime specified path

Calvin_Hsia — Tue, 28 Oct 2008 22:02:00 GMT

When running VB.Net or C# code, often it’s useful to call native code. One way is using PInvoke. (for other ways, see How fast is interop code?)

For example, you can call GetWindowText to get the title of a window. To get it’s managed signature, you can use this code from http://www.pinvoke.net/default.aspx/user32/GetWindowText.html

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

Shared Function GetWindowText(ByVal hwnd As IntPtr, _

ByVal lpString As StringBuilder, _

ByVal cch As Integer) As Integer

End Function

This code works because "User32.dll" is a well known system Dll and can be found along the PATH. However, many times the Dll you want may not be on the path. Sometimes it's in a known location relative to where your code is executing (like a subdirectory).

The string name of the Dll specified in the DllImport can include a path name, like "c:\windows\system32\user32.dll", but it must be constant at compile time. This limitation contradicts the name for Dll: "Dynamic Link Library"

However, sometimes a DLL may not live in a known location on a disk, but you still want to call it. Perhaps the location can be specified at runtime.

A simple way to work around this problem is to explicitly call LoadLibrary (which accepts a full path) first. Then the call will work.

Run the sample code below.

Start Visual Studio. File->New->Project->VB ->Windows Application.

Double click the form and replace the code with the sample below.

The sample creates two buttons on a form and tries to invoke GetWindowText from a specified DLL.

The 1^st button invokes the one in the Windows System32 directory.

The 2^nd button copies the system one to a different folder and a different name ("User32Copy.dll"), then calls it.

See also:

How fast is interop code?

Create a .Net UserControl that calls a web service that acts as an ActiveX control to use in Excel, VB6, Foxpro

Imports System.Runtime.InteropServices

Imports System.IO

Imports System.Text

Public Class Form1

Dim WithEvents b32 As New Button

Dim WithEvents b32Copy As New Button

Dim TargDir = IO.Path.GetTempPath

Dim SysDir = Path.Combine(My.Application.GetEnvironmentVariable("windir"), "System32") ' C:\Windows\System32

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

Me.Text = "Form1 " + DateTime.Now.ToLongTimeString

b32.Text = "User32"

Me.Controls.Add(b32)

b32Copy.Text = "User32Copy"

b32Copy.Top = 30

Me.Controls.Add(b32Copy)

End Sub

Sub btn32_click() Handles b32.Click

CallGetWindowText(New Wrap32, Path.Combine(SysDir, Wrap32.cDllName))

End Sub

Sub btn32Copy_click() Handles b32Copy.Click

Dim cFullName = Path.Combine(TargDir, Wrap32Copy.cDllName) ' D:\user32Copy.dll

If Not File.Exists(cFullName) Then

File.Copy(Path.Combine(SysDir, Wrap32.cDllName), cFullName)

End If

Using ldr = New DynamicDllLoader(cFullName)

CallGetWindowText(New Wrap32Copy, cFullName)

End Using

End Sub

Sub CallGetWindowText(ByVal wrap As Object, ByVal cFullName As String)

Dim sbStr As New StringBuilder(255)

wrap.GetWindowText(Me.Handle.ToInt32, sbStr, sbStr.Capacity)

Dim ParentWind = Me.Handle.ToInt32 'sets the owner of the Msgbox. also try Me.Handle.ToInt32 and 0 to observe Alt-Tab behavior

MessageBox.Show("From " + cFullName + vbCrLf + "Form caption = " + sbStr.ToString, "From " + cFullName, 0)

End Sub

End Class

Friend Class Wrap32

Friend Const cDllName = "user32.dll"

<DllImport(cDllName, SetLastError:=True, CharSet:=CharSet.Auto)> _

Shared Function GetWindowText(ByVal hwnd As IntPtr, _

ByVal lpString As StringBuilder, _

ByVal cch As Integer) As Integer

End Function

End Class

Friend Class Wrap32Copy

Friend Const cDllName = "user32Copy.dll"

<DllImport(cDllName, SetLastError:=True, CharSet:=CharSet.Auto)> _

Shared Function GetWindowText(ByVal hwnd As IntPtr, _

ByVal lpString As StringBuilder, _

ByVal cch As Integer) As Integer

End Function

End Class

Friend Class DynamicDllLoader

Implements IDisposable

<DllImport("kernel32.dll", _

CallingConvention:=CallingConvention.Winapi, _

CharSet:=CharSet.Auto, _

EntryPoint:="LoadLibrary", _

PreserveSig:=True)> _

Friend Shared Function LoadLibrary(<[In]()> ByVal DllPath As String) As Integer

End Function

<DllImport("kernel32.dll", _

CallingConvention:=CallingConvention.Winapi, _

EntryPoint:="FreeLibrary", _

PreserveSig:=True)> _

Friend Shared Function FreeLibrary(<[In]()> ByVal Handle As Integer) As Integer

End Function

Private _HandleDll As Integer

Sub New(ByVal FullPath As String, Optional ByVal fChangeDir As Boolean = False)

'must change folder to loc of MSVBIDE so VSAssert and MSVBIDEui can be found

Dim OrigCurdir = System.IO.Directory.GetCurrentDirectory

If fChangeDir Then

System.IO.Directory.SetCurrentDirectory(Path.GetDirectoryName(FullPath))

End If

Try

If IO.File.Exists(FullPath) Then

_HandleDll = LoadLibrary(FullPath)

If _HandleDll = 0 Then

Throw New FileNotFoundException("couldn't load " + FullPath)

End If

Else

Throw New FileNotFoundException(FullPath)

End If

Catch ex As Exception

Finally

If fChangeDir Then

Directory.SetCurrentDirectory(OrigCurdir)

End If

End Try

End Sub

Sub UnLoadDll()

If _HandleDll Then

FreeLibrary(_HandleDll)

_HandleDll = 0

End If

End Sub

Private disposedValue As Boolean = False ' To detect redundant calls

' IDisposable

Protected Overridable Sub Dispose(ByVal disposing As Boolean)

If Not Me.disposedValue Then

If disposing Then

' TODO: free other state (managed objects).

End If

UnLoadDll()

' TODO: free your own state (unmanaged objects).

' TODO: set large fields to null.

End If

Me.disposedValue = True

End Sub

#Region " IDisposable Support "

' This code added by Visual Basic to correctly implement the disposable pattern.

Public Sub Dispose() Implements IDisposable.Dispose

' Do not change this code. Put cleanup code in Dispose(ByVal disposing As Boolean) above.

Dispose(True)

GC.SuppressFinalize(Me)

End Sub

#End Region

End Class

</Sample Code>

Compress and timestamp your pictures to gain disk space

Calvin_Hsia — Thu, 13 Mar 2008 23:23:00 GMT

I was running out of space again on my notebook. As years go by, digital cameras can take pictures with more megapixels, but that means they take up more space.

Thus my pictures from 10 years ago are much smaller than this year’s.

Since I have multiple copies of my picture collection (28,000!) I didn’t mind modifying the notebook’s copy. Also, since the notebook resolution is 1400 X 1050, and I only ever display the notebook pictures on the notebook screen, the camera picture’s resolution 3072 X 2074 (Canon Powershot SD800) included more info than I needed.

The code resulted in most pictures compressing about 80%! You can vary the quality parameter and try it yourself. Also, my disk contains all the movies taken by the camera too, and these aren’t touched by the code.

So I ran the code below and gained 5 Gigabytes of storage! Not bad.

The code uses the GDIPlus class library to load, compress and store the file. This changes the file timestamp, so the code also preserves the original timestamp.

Resize your pictures for your phone or pocket pc

Timestamp digital pictures

cRoot=ADDBS("d:\pictures\2006\")

recurdir(cRoot)

?"Done",DATETIME()

PROCEDURE recurdir(cBasePath)

LOCAL n,i

LOCAL aa[1]

?cbasePath

n=ADIR(aa,cBasePath+"*.*","D")

FOR i = 1 TO n

IF "D"$aa[i,5]

IF LEFT(aa[i,1],1)<>"."

recurdir(cBasePath+aa[i,1]+"\")

ENDIF

ELSE

IF LOWER(JUSTEXT(aa[i,1]))="jpg"

recompress(cBasePath+aa[i,1])

retimestamp("d:\t.jpg",CTOT(DTOC(aa[i,3])+" "+aa[i,4]))

COPY FILE d:\t.jpg TO (cBasePath+aa[i,1])

ENDIF

ENDFOR

RETURN

PROCEDURE recompress(cPict as String)

LOCAL aa[1]

cOutfile="d:\t.jpg"

LOCAL oImage as gpImage OF (HOME()+"ffc\_gdiplus")

oImage=NEWOBJECT("gpImage",HOME()+"ffc\_gdiplus","",cpict)

oImage.SaveToFile(cOutfile,"image/jpeg","Quality=20")

ADIR(aa,cOutfile)

nSizeNew=aa[1,2]

ADIR(aa,cPict)

nSizeOrig=aa[1,2]

?cPict

??" Orig Size = ",TRANSFORM(nSizeOrig,"999,999,999")

??" New Size = ",TRANSFORM(nSizeNew,"999,999,999")

* ??" # bytes smaller = ", TRANSFORM(nSizeOrig - nSizeNew,"999,999,999")

??" # times smaller", TRANSFORM(nSizeOrig / nSizeNew)

??" % savings=", TRANSFORM(100*(nSizeOrig - nSizeNew)/nSizeOrig )

*! &cOutfile

RETURN

*From WINNT.H:

#define FILE_SHARE_READ 0x00000001

#define FILE_SHARE_WRITE 0x00000002

#define FILE_SHARE_DELETE 0x00000004

#define FILE_ATTRIBUTE_READONLY 0x00000001

#define FILE_ATTRIBUTE_HIDDEN 0x00000002

#define FILE_ATTRIBUTE_SYSTEM 0x00000004

#define FILE_ATTRIBUTE_DIRECTORY 0x00000010

#define FILE_ATTRIBUTE_ARCHIVE 0x00000020

#define FILE_ATTRIBUTE_DEVICE 0x00000040

#define FILE_ATTRIBUTE_NORMAL 0x00000080

#define FILE_ATTRIBUTE_TEMPORARY 0x00000100

#define FILE_ATTRIBUTE_SPARSE_FILE 0x00000200

#define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400

#define FILE_ATTRIBUTE_COMPRESSED 0x00000800

#define FILE_ATTRIBUTE_OFFLINE 0x00001000

#define FILE_ATTRIBUTE_NOT_CONTENT_INDEXED 0x00002000

#define FILE_ATTRIBUTE_ENCRYPTED 0x00004000

#define FILE_WRITE_ATTRIBUTES 0x100

#define GENERIC_WRITE (0x40000000)

#define GENERIC_READ (0x80000000)

*From winbase.h:

#define CREATE_NEW 1

#define CREATE_ALWAYS 2

#define OPEN_EXISTING 3

#define OPEN_ALWAYS 4

#define TRUNCATE_EXISTING 5

PROCEDURE ReTimeStamp(cFilename as string, dt as Datetime)

DECLARE integer CreateFile in win32api string, integer dwDesiredAccess, integer dwShareMode, integer security, ;

integer dwCreationDisposition, integer FlagsAttrs, integer hTemplate

DECLARE INTEGER CloseHandle in win32api integer hFile

DECLARE integer SystemTimeToFileTime IN WIN32API string , string @

DECLARE INTEGER SetFileTime IN kernel32;

INTEGER hFile, STRING lpCreationTime,;

STRING lpLastAccessTime, STRING lpLastWriteTime

DECLARE INTEGER SystemTimeToFileTime IN kernel32;

STRING lpSystemTime, STRING @lpFileTime

DECLARE INTEGER LocalFileTimeToFileTime IN kernel32;

STRING lpLocalFileTime, STRING @lpFileTime

DECLARE integer GetLastError in win32api

cFileTime = SPACE(8)

cSysTime=BINTOC(YEAR(dt),"2rs") + ;

BINTOC(MONTH(dt),"2rs") + ;

BINTOC(DOW(dt,0),"2rs") + ;

BINTOC(DAY(dt),"2rs") + ;

BINTOC(HOUR(dt),"2rs") + ;

BINTOC(MINUTE(dt),"2rs") + ;

REPLICATE(CHR(0),4)

SystemTimeToFileTime(cSysTime, @cFileTime)

LocalFileTimeToFileTime(cFileTime, @cFileTime)

hFile = CreateFile(cFilename, GENERIC_WRITE+GENERIC_READ,FILE_SHARE_READ, 0, OPEN_EXISTING, 0,0)

SetFileTime(hFile , cFileTime, cFileTime,cFileTime)

CloseHandle(hFile)

RETURN

Extract TreeView or ListView ImageList icons from a DLL

Calvin_Hsia — Wed, 07 Nov 2007 04:20:00 GMT

An ImageList can be used for a ListView or TreeView control to contain many images in a single file, usually embedded as a resource. Visual Studio itself has many icons.

If you open Windows Explorer or Internet Explorer, you can see many icons in toolbars, ListViews or TreeViews.

Using Visual Studio (any version), choose File->Open->File and navigate to C:\Windows\System32\shdocvw.dll. The file will be opened by default in the Resource editor, and you can drill down into the resources embedded in the dll. Drill down into Bitmap and double-click on 328 (xp) or 3215 (Vista). A single bitmap is displayed, made up of many smaller bitmaps placed in a row.

Below is code that will extract individual icons from such resources. It loads a DLL, loads the desired resource, creates a Managed BitMap object and uses it do display the icons in a ListView.

The Bitmap.FromHbitmap(hRes) function will take a resource and convert it into a managed BitMap, which can be used as a ListView and also Saved as an individual file.

You can use GetManifestResourceNames to get resources from a managed assembly.

Start Visual Studio (any version), then choose File->New->Project->Windows Forms Application, then dbl click the form and replace the code with this sample. Then hit F5 to run it.

Imports System.Runtime.InteropServices

Public Class Form1

Const LOAD_LIBRARY_AS_IMAGE_RESOURCE = &H20

Const LOAD_LIBRARY_AS_DATAFILE = 2

<DllImport("kernel32.dll")> _

Shared Function LoadLibraryEx(ByVal lpFilename As String, ByVal hModule As IntPtr, ByVal dwFlags As UInteger) As IntPtr

End Function

<DllImport("user32.dll")> _

Shared Function LoadBitmap(ByVal hModule As IntPtr, ByVal hResInfo As UInteger) As IntPtr

End Function

<DllImport("kernel32.dll")> _

Shared Function FreeLibrary(ByVal hModule As IntPtr) As IntPtr

End Function

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

Me.Width = 600

Me.Height = 600

Dim lv As New ListView

lv.Height = Me.Width

lv.Width = Me.Height

'C:\Windows\System32\shdocvw.dll, 328

'C:\Windows\System32\browseui.dll 279

Dim hModule = LoadLibraryEx("C:\Program Files\Microsoft Visual Studio 9.0\Common7\IDE\msenv.dll", _

0, LOAD_LIBRARY_AS_IMAGE_RESOURCE + LOAD_LIBRARY_AS_DATAFILE)

Dim hRes = LoadBitmap(hModule, &H4F4)

Dim bmpIcons = Bitmap.FromHbitmap(hRes)

bmpIcons.Save("d:\t.bmp") 'optionally save it to inspect it

FreeLibrary(hModule)

Me.Controls.Add(lv)

lv.View = View.SmallIcon

Dim imlist As New ImageList

'imlist.ImageSize = New Drawing.Size(16, 16)

'imlist.ColorDepth = ColorDepth.Depth24Bit

imlist.TransparentColor = Color.FromArgb(&HFFFF00FF)

imlist.Images.AddStrip(bmpIcons)

lv.SmallImageList = imlist

For i = 0 To 235

lv.Items.Add(i.ToString, i)

Dim icon = imlist.Images.Item(i)

icon.Save("d:\OMBmp" + i.ToString + ".bmp") 'save individual icons

End Sub

End Class

Create a WPF Form to choose a text color

Calvin_Hsia — Fri, 26 Oct 2007 23:40:00 GMT

I wanted to choose some nice colors for various kinds of text, so I wrote a simple text color picker using Windows Presentation Foundation (WPF).

The code creates a TextBlock and 4 slider controls: one for Alpha channel (Opacity) and one each for Red, Green and Blue.

The code shows how to add child controls to the WPF Form. (You can also use the Grid Class to position controls)

As you move the sliders, the color of the TextBlock changes and it displays the desired color value in the desired color (foreground and background)

Note that the HandleColorChange needs no parameters: due to the Relaxed Delegates feature of VB9.

Start Visual Studio 2008

Choose File->New Project->Visual Basic->WPF Application

You can use the WPF Forms designer, or you can write your code in a program.

Double click the form designer to bring up the Window1.xaml.vb file. Replace the contents with the code below.

Class Window1

Dim txtBlock As New TextBlock

Dim sld(3) As Slider ' Alpha, Red, Green, Blue

Dim WithEvents chk As New CheckBox

Private Sub Window1_Loaded(ByVal sender As System.Object, ByVal e As System.Windows.RoutedEventArgs) Handles MyBase.Loaded

Me.Height = 400

Dim MyGrid As Grid = Me.Content

Dim cv As New Canvas

txtBlock.Text = "Some Text to color"

txtBlock.HorizontalAlignment = Windows.HorizontalAlignment.Center

cv.Children.Add(txtBlock)

With chk

.Content = "Check to change background"

End With

Canvas.SetTop(chk, 20)

cv.Children.Add(chk)

MyGrid.Children.Add(cv)

For i = 0 To 3

sld(i) = New Slider

With sld(i)

.AutoToolTipPlacement = Primitives.AutoToolTipPlacement.TopLeft

.HorizontalAlignment = Windows.HorizontalAlignment.Stretch

.Minimum = 0

.Maximum = 255

.Width = 200

.Orientation = Controls.Orientation.Horizontal

.HorizontalAlignment = Windows.HorizontalAlignment.Center

.SmallChange = 10

If i = 0 Then ' for Alpha channel

.Value = 255

Else

.Value = 0 ' for RGB: black

End If

End With

Canvas.SetTop(sld(i), i * 30 + 60)

cv.Children.Add(sld(i))

AddHandler sld(i).ValueChanged, AddressOf Me.HandleColorChange

End Sub

Friend Sub HandleColorChange()

Dim cColor As New Color

cColor.A = &HFF

For i = 0 To 3

Select Case i

Case 0

cColor.A = sld(i).Value

Case 1

cColor.R = sld(i).Value

Case 2

cColor.G = sld(i).Value

Case 3

cColor.B = sld(i).Value

End Select

If chk.IsChecked Then

Me.txtBlock.Background = New SolidColorBrush(cColor)

Else

Me.txtBlock.Foreground = New SolidColorBrush(cColor)

End If

Me.txtBlock.Text = String.Format("Some Text to color {0:x} {1:x} {2:x} {3:x}", cColor.A, cColor.R, cColor.G, cColor.B)

End Sub

End Class

End of code

Resize your pictures for your phone or pocket pc

Calvin_Hsia — Fri, 12 Oct 2007 08:55:00 GMT

I have many digital pictures, and I'd like to put some of my favorites on my SmartPhone. However the files are much higher resolution than the device's display. This means the files take a lot more memory on the phone, and they take longer to process. I wrote some code to resize the images automatically. The code below shows a form with a resized picture on it, and you can vary the Quality of the JPG saved image by moving a TrackBar control. The form's caption shows the Quality selected, and the resulting file size. It's amazing how small you can make the file without losing too much quality.

Start Visual Studio (2005 or 2008), choose File->New->Project->Windows->Windows Forms Application. Choose View->Code and paste in the VB code below. Run it and give it a digital picture to play with.

The code creates oBitmap as an Image object, representing the original image. oBmpOut is an Image object, with the desired target size. A Graphics object is created from oBmpOut and oBitmap is drawn onto that Graphics object. Then the JPG Image encoder is found, and the JPG is saved with the specified Quality.

Below is sample code in both VB.Net and Fox that shows a particular JPG resampled to 320 x 240 resolution, with a TrackBar that allows you to change the JPG quality.

Various ways to display multiple photographs

Start of Fox code

PUBLIC ox as JpgForm

ox=CREATEOBJECT("JpgForm")

ox.visible=1

DEFINE CLASS JpgForm as Form

width=640

height=480

left=200

allowoutput=.f.

ADD OBJECT oPict as image WITH top = 20,width=320,height=240,stretch=2

ADD OBJECT oTrackbar as cTrackbar WITH width=300,smallchange=2

PROCEDURE init

SET CLASSLIB TO HOME()+"ffc\_gdiplus"

SET COMPATIBLE on && so FSIZE returns FileSize

this.refresh

PROCEDURE refresh

this.drawit()

PROCEDURE drawit

cFile="d:\kids.jpg"

cOutputFile="d:\thumb.jpg"

LOCAL oGraphics as gpGraphics OF _gdiplus.vcx

LOCAL oImage as gpImage OF _gdiplus.vcx

LOCAL oBmpOut as gpBitmap OF _gdiplus.vcx

oGraphics=CREATEOBJECT("gpGraphics")

oImage=CREATEOBJECT("gpImage",cFile)

oBmpOut=CREATEOBJECT("gpBitmap",this.oPict.width,this.oPict.height)

oGraphics.CreateFromImage(oBmpOut)

oGraphics.DrawImageScaled(oImage,0,0,oBmpOut.ImageWidth,oBmpOut.ImageHeight)

oBmpOut.SaveToFile(cOutputFile,"image/jpeg","quality="+TRANSFORM(this.oTrackbar.value))

this.oPict.picture=cOutputFile

this.Caption = TRANSFORM(this.oTrackbar.value)+" Size="+TRANSFORM(FSIZE(cOutputFile))

ENDDEFINE

DEFINE CLASS cTrackbar as olecontrol

oleclass="mscomctllib.slider.2"

PROCEDURE init

this.max=100

this.smallchange=2

this.largechange=10

PROCEDURE change

thisform.drawit

ENDDEFINE

End of Fox code

Start of VB code:

Public Class Form1

Dim oPict As New PictureBox

Dim WithEvents oTrackBar As New TrackBar

Dim cFile As String = "d:\kids.jpg"

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

Me.Width = 640

Me.Height = 480

oPict.Top = 30

oPict.Width = 640

oPict.Height = 480

oPict.Visible = 1

Dim OFD As New OpenFileDialog

OFD.FileName = cFile

If OFD.ShowDialog <> Windows.Forms.DialogResult.OK Then

End

End If

cFile = OFD.FileName

Me.Controls.Add(oPict)

oTrackBar.Width = 300

oTrackBar.Height = 20

oTrackBar.Visible = 1

oTrackBar.Minimum = 0

oTrackBar.Maximum = 100

oTrackBar.SmallChange = 5

oTrackBar.Value = 50

Me.Controls.Add(oTrackBar)

End Sub

Sub TrackBar_Change(ByVal sender As Object, ByVal e As System.EventArgs) Handles oTrackBar.ValueChanged

CalcPict()

End Sub

Sub CalcPict()

Dim oBitmap As Bitmap = New Bitmap(cFile)

Dim oBmpOut As Bitmap = New Bitmap(Me.oPict.Width, Me.oPict.Height)

Dim oG As Graphics = Graphics.FromImage(oBmpOut)

oG.DrawImage(oBitmap, 0, 0, oBmpOut.Width, oBmpOut.Height)

Dim encParam As New Imaging.EncoderParameters(1)

encParam.Param(0) = New Imaging.EncoderParameter(Imaging.Encoder.Quality, oTrackBar.Value)

Dim codecs As Imaging.ImageCodecInfo() = Imaging.ImageCodecInfo.GetImageEncoders

Dim JpgCodec As Imaging.ImageCodecInfo = Nothing

For Each codec As Imaging.ImageCodecInfo In codecs

If codec.MimeType = "image/jpeg" Then

JpgCodec = codec

Exit For

End If

Dim istream As New IO.MemoryStream

oBmpOut.Save(istream, JpgCodec, encParam)

oPict.Image = New Bitmap(istream)

Me.Text = oTrackBar.Value.ToString + " Size=" + istream.Length.ToString

End Sub

End Class

End of VB code:

Generate and run PowerShell scripts dynamically

Calvin_Hsia — Mon, 08 Oct 2007 22:13:00 GMT

In my prior post Use new XML Features of VB to generate dynamic scripts and text files , we generated a simple batch file. It’s difficult to modify the registry or manipulate a COM object

PowerShell scripts allow you to manipulate files, registry and COM objects, using a uniform object manipulation metaphor. For example, you can use CD and DIR at a command prompt to navigate the file system, the registry and certificate store too.

Here's a simple sample navigating the registry of Fox: (user typed text in this color)

Windows PowerShell

PS C:\Documents and Settings\calvinh> cd hkcu:

PS HKCU:\> cd Software

PS HKCU:\Software> cd HKCU:\Software\Microsoft\VisualFoxPro

PS HKCU:\Software\Microsoft\VisualFoxPro> dir

Hive: Microsoft.PowerShell.Core\Registry::HKEY_CURRENT_USER\Software\Microsoft\VisualFoxPro

SKC VC Name Property

--- -- ---- --------

5 0 9.0 {}

PS HKCU:\Software\Microsoft\VisualFoxPro> cd 9.0

PS HKCU:\Software\Microsoft\VisualFoxPro\9.0> dir

Hive: Microsoft.PowerShell.Core\Registry::HKEY_CURRENT_USER\Software\Microsoft\VisualFoxPro\9.0

SKC VC Name Property

--- -- ---- --------

0 1 ChooseColor {(default)}

0 8 Coverage {FrmzoomHeight, FrmzoomTop, FrmzoomWidth, FrmzoomLeft...}

0 7 Desktop {Zoomed, Row, Column, Height...}

0 0 Fonts {}

4 192 Options {LastProject, TALK, StatusBar, NOTIFY...}

PS HKCU:\Software\Microsoft\VisualFoxPro\9.0>

This PowerShell script sample modifies the setting of SET SAFETY by directly manipulating the registry, then forcing VFP to reread the registry settings using SYS(3056)

ERASE d:\t.txt

*http://www.microsoft.com/windowsserver2003/technologies/management/powershell/default.mspx

*Set-ExecutionPolicy remotesigned

SET SAFETY OFF

?"Safety before",SET("Safety")

TEXT TO myvar

#This is a sample powershell script

#get-process > d:\t.txt

#get-psdrive > d:\t.txt

#CD HKCU:\Software\Microsoft\VisualFoxPro\9.0

#get-Item * >> d:\t.txt

#can specify path to registry

#get setting of all reg keys starting with "s":

#get-ItemProperty -path registry::HKCU\Software\Microsoft\VisualFoxPro\9.0\Options s* >> d:\t.txt

#get-ItemProperty -path registry::HKCU\Software\Microsoft\VisualFoxPro\9.0\Options safety >> d:\t.txt

set-ItemProperty -path registry::HKCU\Software\Microsoft\VisualFoxPro\9.0\Options safety ON >> d:\t.txt

ENDTEXT

STRTOFILE(myvar,"d:\Myscript.ps1")

! powershell d:\Myscript

?STRCONV(SUBSTR(FILETOSTR("d:\t.txt"),3),6) && convert from Unicode, remove ByteOrderMark

SYS(3056) && Force VFP to reread registry

?"Safety After: ",SET("safety")

SET SAFETY OFF && restore value

You can even create a VFP COM Object from within a PowerShell script and invoke its methods: (using my favorite VFP COM Object "t1.c1")

Here's a PowerShell script sample that creates an instance of Excel, and passes it to the VFP COM object for further manipulation: The hardest part of this code was trying to figure out how to close Excel without saving changes!

PowerShell variables start with “$”, comments start with “#”

SET SAFETY OFF

sOutputFile="d:\t.txt"

ERASE (sOutputFile)

TEXT TO myvar TEXTMERGE

#create Excel

$oExcel = New-Object -ComObject Excel.Application

#create VFP COM Object

$oVFP = New-Object -ComObject t1.c1

#Pass Excel to VFP object

$oVFP.MyDoCmd("p2.Visible=1",$oExcel,0,0,0)

#Get the name of the object

$oVFP.MyEval("p2.name",$oExcel,0,0,0) >> <<sOutputFile>>

#Add a workbook

$oVFP.MyDoCmd("p2.Workbooks.Add",$oExcel,0,0,0)

$pv="PowerShell variable"

#Change the 1st cell's value to a combination of VFP and Powershell vars

$oVFP.MyDoCmd("p2.Cells(1,1).value='Hi from VFP '+p3",$oExcel,$pv,0,0)

$oVFP.MyDoCmd("DECLARE integer MessageBoxA IN WIN32API integer,string,string,integer",0,0,0,0)

$oVFP.MyEval("MessageBoxA(0,'Hi From VFP inside PowerShell','',0)",0,0,0,0)

#Close Excel workbook without saving!

$oVFP.MyDoCmd("p2.ActiveWorkbook.Close(.f.)",$oExcel,0,0,0)

$oVFP.MyDoCmd("p2.Visible=0",$oExcel,0,0,0)

$oVFP.MyDoCmd("p2.Quit",$oExcel,0,0,0)

ENDTEXT

STRTOFILE(myvar,"d:\Myscript.ps1")

! powershell d:\Myscript

IF FILE(sOutputFile)

?STRCONV(SUBSTR(FILETOSTR(sOutputFile),3),6) && convert from Unicode, remove ByteOrderMark

ENDIF

You can do this from VB using the new XML features (Use new XML Features of VB to generate dynamic scripts and text files )

Module Module1

Sub Main()

Dim sOutputFile = "d:\t.txt"

Dim sScriptFile = "d:\t.ps1"

If My.Computer.FileSystem.FileExists(sOutputFile) Then

My.Computer.FileSystem.DeleteFile(sOutputFile)

End If

Dim PowerShellScriptXML = <myxml>

#create Excel

$oExcel = New-Object -ComObject Excel.Application

#create VFP COM Object

$oVFP = New-Object -ComObject t1.c1

#Pass Excel to VFP object

$oVFP.MyDoCmd("p2.Visible=1",$oExcel,0,0,0)

#Get the name of the object

$oVFP.MyEval("p2.name",$oExcel,0,0,0) >> <%= sOutputFile %>

#Add a workbook

$oVFP.MyDoCmd("p2.Workbooks.Add",$oExcel,0,0,0)

$pv="PowerShell variable"

#Change the 1st cell's value to a combination of VFP and Powershell vars

$oVFP.MyDoCmd("p2.Cells(1,1).value='Hi from VFP '+p3",$oExcel,$pv,0,0)

$oVFP.MyDoCmd("DECLARE integer MessageBoxA IN WIN32API integer,string,string,integer",0,0,0,0)

$oVFP.MyEval("MessageBoxA(0,'Hi From VFP inside PowerShell','',0)",0,0,0,0)

#Close Excel workbook without saving!

$oVFP.MyDoCmd("p2.ActiveWorkbook.Close(.f.)",$oExcel,0,0,0)

$oVFP.MyDoCmd("p2.Visible=0",$oExcel,0,0,0)

$oVFP.MyDoCmd("p2.Quit",$oExcel,0,0,0)

</myxml>

Console.WriteLine(PowerShellScriptXML.Value)

My.Computer.FileSystem.WriteAllText(sScriptFile, PowerShellScriptXML.Value, False, Text.Encoding.ASCII)

Dim proc = System.Diagnostics.Process.Start("PowerShell", sScriptFile)

proc.WaitForExit()

Dim ss = My.Computer.FileSystem.ReadAllText(sOutputFile)

MsgBox("Proc Done " + ss)

End Sub

End Module

End of code