Windows FormsでKinect その4

骨格情報を取得し,深度情報に重ねて棒人間を表示するサンプルです。

棒人間表示の部分はKinect SDKのサンプル「SkeletalViewer」のソースコードを参考にしました。

Option Explicit On
Option Strict On
Option Infer Off

Imports Microsoft.Research.Kinect.Nui
Imports System.Runtime.InteropServices

Public Class Form1

    Private Const MaxDepthDistance As Single = 4000
    Private Const MinDepthDistance As Single = 850
    Private Const MaxDepthDistanceOffset As Single = MaxDepthDistance - MinDepthDistance
    Private Const MarkerSize As Integer = 10
    Private DepthImage As Bitmap
    Private WithEvents Nui As New Runtime
    Private ColorFrame(320 * 240 * 4) As Byte
    Private JointPositions As New Dictionary(Of JointID, Point)
    Private BodyParts As New List(Of Point())

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.DoubleBuffered = True
        Me.ClientSize = New Size(640, 480)
        Nui.Initialize(RuntimeOptions.UseDepthAndPlayerIndex Or RuntimeOptions.UseSkeletalTracking Or RuntimeOptions.UseColor)
        Nui.DepthStream.Open(ImageStreamType.Depth, 2, ImageResolution.Resolution320x240, ImageType.DepthAndPlayerIndex)
    End Sub

    Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
        Dim g As Graphics = e.Graphics
        If DepthImage IsNot Nothing Then
            g.DrawImage(DepthImage, Me.ClientRectangle)
        End If
        If Me.BodyParts IsNot Nothing AndAlso Me.BodyParts.Count > 0 Then
            Using Pen As New Pen(Brushes.Orange, 6)
                For Each Part As Point() In Me.BodyParts
                    g.DrawLines(Pen, Part)
                Next
            End Using
        End If
        If Me.JointPositions IsNot Nothing AndAlso Me.JointPositions.Count > 0 Then
            For Each JointPosition As KeyValuePair(Of JointID, Point) In Me.JointPositions
                g.FillEllipse(Brushes.Red, JointPosition.Value.X - CInt(MarkerSize / 2), JointPosition.Value.Y - CInt(MarkerSize / 2), MarkerSize, MarkerSize)
            Next
        End If
    End Sub

    Private Sub nui_DepthFrameReady(ByVal sender As Object, ByVal e As Microsoft.Research.Kinect.Nui.ImageFrameReadyEventArgs) Handles Nui.DepthFrameReady
        Dim Image As PlanarImage = e.ImageFrame.Image
        For i As Integer = 0 To Image.Bits.Length \ 2 - 1
            Dim Distance As Integer = GetDistanceWithPlayerIndex(Image.Bits(i * 2), Image.Bits(i * 2 + 1))
            Dim Intensity As Byte = CalculateIntensityFromDepth(Distance)
            ColorFrame(i * 4) = Intensity
            ColorFrame(i * 4 + 1) = Intensity
            ColorFrame(i * 4 + 2) = Intensity
        Next
        Dim Stride As Integer = Image.Width * 4
        Dim Handle As GCHandle = GCHandle.Alloc(ColorFrame, GCHandleType.Pinned)
        Dim Scan0 As IntPtr = CType(Handle.AddrOfPinnedObject.ToInt32, IntPtr)
        DepthImage = New Bitmap(Image.Width, Image.Height, Stride, Imaging.PixelFormat.Format32bppRgb, Scan0)
        Handle.Free()
        Me.Invalidate()
    End Sub

    Private Function GetDistanceWithPlayerIndex(ByVal firstFrame As Byte, ByVal secondFrame As Byte) As Integer
        Return CInt(firstFrame) >> 3 Or CInt(secondFrame) << 5
    End Function

    Private Function CalculateIntensityFromDepth(ByVal distance As Integer) As Byte
        Return CByte(255 - (255 * Math.Max(distance - MinDepthDistance, 0) / (MaxDepthDistanceOffset)))
    End Function

    Private Sub nui_SkeletonFrameReady(ByVal sender As Object, ByVal e As Microsoft.Research.Kinect.Nui.SkeletonFrameReadyEventArgs) Handles Nui.SkeletonFrameReady
        Dim SkeletonFrame As SkeletonFrame = e.SkeletonFrame
        Dim DepthImageWidth As Integer = Nui.DepthStream.Width
        Dim DepthImageHeight As Integer = Nui.DepthStream.Height
        Me.JointPositions.Clear()
        Me.BodyParts.Clear()
        For Each Data As SkeletonData In SkeletonFrame.Skeletons
            If Data.TrackingState = SkeletonTrackingState.Tracked Then
                For Each Joint As Joint In Data.Joints
                    Dim vx, vy As Single
                    Nui.SkeletonEngine.SkeletonToDepthImage(Joint.Position, vx, vy)
                    Dim x As Integer = CInt(Math.Max(0, Math.Min(vx * DepthImageWidth, DepthImageWidth)) * (Me.ClientSize.Width / DepthImageWidth))
                    Dim y As Integer = CInt(Math.Max(0, Math.Min(vy * DepthImageHeight, DepthImageHeight)) * (Me.ClientSize.Height / DepthImageHeight))
                    Me.JointPositions.Add(Joint.ID, New Point(x, y))
                Next
                BodyParts.Add(getBodyPart(Me.JointPositions, {JointID.Head, JointID.ShoulderCenter, JointID.Spine, JointID.HipCenter}))
                BodyParts.Add(getBodyPart(Me.JointPositions, {JointID.ShoulderCenter, JointID.ShoulderLeft, JointID.ElbowLeft, JointID.WristLeft, JointID.HandLeft}))
                BodyParts.Add(getBodyPart(Me.JointPositions, {JointID.ShoulderCenter, JointID.ShoulderRight, JointID.ElbowRight, JointID.WristRight, JointID.HandRight}))
                BodyParts.Add(getBodyPart(Me.JointPositions, {JointID.HipCenter, JointID.HipLeft, JointID.KneeLeft, JointID.AnkleLeft, JointID.FootLeft}))
                BodyParts.Add(getBodyPart(Me.JointPositions, {JointID.HipCenter, JointID.HipRight, JointID.KneeRight, JointID.AnkleRight, JointID.FootRight}))
            End If
        Next
    End Sub

    Private Function getBodyPart(ByVal Joints As Dictionary(Of JointID, Point), ByVal JointID As JointID()) As Point()
        Dim Part As New List(Of Point)
        For i As Integer = 0 To JointID.Length - 1
            Part.Add(Joints.Item(JointID(i)))
        Next
        Return Part.ToArray
    End Function

End Class

Sample04

| | コメント (2) | トラックバック (0)

Windows FormsでKinect その3

骨格情報を取得し,深度情報に重ねて関節位置にマーカーを表示するサンプルです。

Kinect SDK XNAで骨格情報の取得 その1」を参考にさせていただきました。

Option Explicit On
Option Strict On
Option Infer Off

Imports Microsoft.Research.Kinect.Nui
Imports System.Runtime.InteropServices

Public Class Form1

    Private Const MaxDepthDistance As Single = 4000
    Private Const MinDepthDistance As Single = 850
    Private Const MaxDepthDistanceOffset As Single = MaxDepthDistance - MinDepthDistance
    Private Const MarkerSize As Integer = 20
    Private DepthImage As Bitmap
    Private WithEvents Nui As New Runtime
    Private ColorFrame(320 * 240 * 4) As Byte
    Private JointPositions As New List(Of Point)

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.DoubleBuffered = True
        Me.ClientSize = New Size(640, 480)
        Nui.Initialize(RuntimeOptions.UseDepthAndPlayerIndex Or RuntimeOptions.UseSkeletalTracking Or RuntimeOptions.UseColor)
        Nui.DepthStream.Open(ImageStreamType.Depth, 2, ImageResolution.Resolution320x240, ImageType.DepthAndPlayerIndex)
    End Sub

    Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
        Dim g As Graphics = e.Graphics
        If DepthImage IsNot Nothing Then
            g.DrawImage(DepthImage, Me.ClientRectangle)
        End If
        If Me.JointPositions IsNot Nothing AndAlso Me.JointPositions.Count > 0 Then
            For Each JointPosition As Point In Me.JointPositions
                g.FillEllipse(Brushes.Red, JointPosition.X - CInt(MarkerSize / 2), JointPosition.Y - CInt(MarkerSize / 2), MarkerSize, MarkerSize)
            Next
        End If
    End Sub

    Private Sub nui_DepthFrameReady(ByVal sender As Object, ByVal e As Microsoft.Research.Kinect.Nui.ImageFrameReadyEventArgs) Handles Nui.DepthFrameReady
        Dim Image As PlanarImage = e.ImageFrame.Image
        For i As Integer = 0 To Image.Bits.Length \ 2 - 1
            Dim Distance As Integer = GetDistanceWithPlayerIndex(Image.Bits(i * 2), Image.Bits(i * 2 + 1))
            Dim Intensity As Byte = CalculateIntensityFromDepth(Distance)
            ColorFrame(i * 4) = Intensity
            ColorFrame(i * 4 + 1) = Intensity
            ColorFrame(i * 4 + 2) = Intensity
        Next
        Dim Stride As Integer = Image.Width * 4
        Dim Handle As GCHandle = GCHandle.Alloc(ColorFrame, GCHandleType.Pinned)
        Dim Scan0 As IntPtr = CType(Handle.AddrOfPinnedObject.ToInt32, IntPtr)
        DepthImage = New Bitmap(Image.Width, Image.Height, Stride, Imaging.PixelFormat.Format32bppRgb, Scan0)
        Handle.Free()
        Me.Invalidate()
    End Sub

    Private Function GetDistanceWithPlayerIndex(ByVal firstFrame As Byte, ByVal secondFrame As Byte) As Integer
        Return CInt(firstFrame) >> 3 Or CInt(secondFrame) << 5
    End Function

    Private Function CalculateIntensityFromDepth(ByVal distance As Integer) As Byte
        Return CByte(255 - (255 * Math.Max(distance - MinDepthDistance, 0) / (MaxDepthDistanceOffset)))
    End Function

    Private Sub nui_SkeletonFrameReady(ByVal sender As Object, ByVal e As Microsoft.Research.Kinect.Nui.SkeletonFrameReadyEventArgs) Handles Nui.SkeletonFrameReady
        Dim SkeletonFrame As SkeletonFrame = e.SkeletonFrame
        Dim DepthImageWidth As Integer = Nui.DepthStream.Width
        Dim DepthImageHeight As Integer = Nui.DepthStream.Height
        Me.JointPositions.Clear()
        For Each Data As SkeletonData In SkeletonFrame.Skeletons
            If Data.TrackingState = SkeletonTrackingState.Tracked Then
                For Each Joint As Joint In Data.Joints
                    Dim vx, vy As Single
                    Nui.SkeletonEngine.SkeletonToDepthImage(Joint.Position, vx, vy)
                    Dim x As Integer = CInt(Math.Max(0, Math.Min(vx * DepthImageWidth, DepthImageWidth)) * (Me.ClientSize.Width / DepthImageWidth))
                    Dim y As Integer = CInt(Math.Max(0, Math.Min(vy * DepthImageHeight, DepthImageHeight)) * (Me.ClientSize.Height / DepthImageHeight))
                    Me.JointPositions.Add(New Point(x, y))
                Next
            End If
        Next
    End Sub

End Class

Sample03

| | コメント (0) | トラックバック (0)

Windows FormsでKinect その2

深度情報を表示するサンプルです。

深度情報は「Working with Depth Data」のコードを利用して処理しました。

Option Explicit On
Option Strict On
Option Infer Off

Imports Microsoft.Research.Kinect.Nui
Imports System.Runtime.InteropServices

Public Class Form1

    Private Const MaxDepthDistance As Single = 4000
    Private Const MinDepthDistance As Single = 850
    Private Const MaxDepthDistanceOffset As Single = MaxDepthDistance - MinDepthDistance
    Private DepthImage As Bitmap
    Private WithEvents Nui As New Runtime
    Private ColorFrame(320 * 240 * 4) As Byte

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.DoubleBuffered = True
        Me.ClientSize = New Size(640, 480)
        Nui.Initialize(RuntimeOptions.UseDepthAndPlayerIndex Or RuntimeOptions.UseSkeletalTracking Or RuntimeOptions.UseColor)
        Nui.DepthStream.Open(ImageStreamType.Depth, 2, ImageResolution.Resolution320x240, ImageType.DepthAndPlayerIndex)
    End Sub

    Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
        If DepthImage IsNot Nothing Then
            e.Graphics.DrawImage(DepthImage, Me.ClientRectangle)
        End If
    End Sub

    Private Sub nui_DepthFrameReady(ByVal sender As Object, ByVal e As Microsoft.Research.Kinect.Nui.ImageFrameReadyEventArgs) Handles Nui.DepthFrameReady
        Dim Image As PlanarImage = e.ImageFrame.Image
        For i As Integer = 0 To Image.Bits.Length \ 2 - 1
            Dim Distance As Integer = GetDistanceWithPlayerIndex(Image.Bits(i * 2), Image.Bits(i * 2 + 1))
            Dim Intensity As Byte = CalculateIntensityFromDepth(Distance)
            ColorFrame(i * 4) = Intensity
            ColorFrame(i * 4 + 1) = Intensity
            ColorFrame(i * 4 + 2) = Intensity
        Next
        Dim Stride As Integer = Image.Width * 4
        Dim Handle As GCHandle = GCHandle.Alloc(ColorFrame, GCHandleType.Pinned)
        Dim Scan0 As IntPtr = CType(Handle.AddrOfPinnedObject.ToInt32, IntPtr)
        DepthImage = New Bitmap(Image.Width, Image.Height, Stride, Imaging.PixelFormat.Format32bppRgb, Scan0)
        Handle.Free()
        Me.Invalidate()
    End Sub

    Private Function GetDistanceWithPlayerIndex(ByVal firstFrame As Byte, ByVal secondFrame As Byte) As Integer
        Return CInt(firstFrame) >> 3 Or CInt(secondFrame) << 5
    End Function

    Private Function CalculateIntensityFromDepth(ByVal distance As Integer) As Byte
        Return CByte(255 - (255 * Math.Max(distance - MinDepthDistance, 0) / (MaxDepthDistanceOffset)))
    End Function

End Class

Sample02

| | コメント (0) | トラックバック (0)

Windows FormsでKinect その1

Kinect for Windows SDK beta が公開されました。

WPFやXNAのサンプルはあちこちで見られますが,Windows Formsのサンプルが少ないようなので,挑戦してみました。

まずは,ビデオ画像を表示するサンプルです。

Option Explicit On
Option Strict On
Option Infer Off

Imports Microsoft.Research.Kinect.Nui
Imports System.Runtime.InteropServices

Public Class Form1

    Private VideoImage As Bitmap
    Private WithEvents Nui As New Runtime

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.DoubleBuffered = True
        Me.ClientSize = New Size(640, 480)
        Nui.Initialize(RuntimeOptions.UseDepthAndPlayerIndex Or RuntimeOptions.UseSkeletalTracking Or RuntimeOptions.UseColor)
        Nui.VideoStream.Open(ImageStreamType.Video, 2, ImageResolution.Resolution640x480, ImageType.Color)
    End Sub

    Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
        Dim g As Graphics = e.Graphics
        If VideoImage IsNot Nothing Then
            g.DrawImage(VideoImage, Me.ClientRectangle)
        End If
    End Sub

    Private Sub nui_VideoFrameReady(ByVal sender As Object, ByVal e As Microsoft.Research.Kinect.Nui.ImageFrameReadyEventArgs) Handles Nui.VideoFrameReady
        Dim Image As PlanarImage = e.ImageFrame.Image
        Dim Stride As Integer = Image.Width * Image.BytesPerPixel
        Dim Handle As GCHandle = GCHandle.Alloc(Image.Bits, GCHandleType.Pinned)
        Dim Scan0 As IntPtr = CType(Handle.AddrOfPinnedObject.ToInt32, IntPtr)
        VideoImage = New Bitmap(Image.Width, Image.Height, Stride, Imaging.PixelFormat.Format32bppRgb, Scan0)
        Handle.Free()
        Me.Invalidate()
    End Sub

End Class

DirectShowなどとは異なり,取り込んだ静止画を連続して表示するようなやり方ですね。

| | コメント (0) | トラックバック (0)

UDPで送受信

シンプルなWebブラウザ。送信と受信があり,送信側で見ているWebページのURLをUDPのマルチキャストを使って受信側に送り,常に送信と受信のブラウザが同じページを見るようにする。

VB2005のUDPのヘルプのサンプルには間違いがあるので注意。

「送信ブラウザ」

'UDPプロトコルマルチキャストアドレス送信サンプル
Imports System.Net.Sockets
Imports System.net
Imports System.Text

Public Class Form1

    Dim WithEvents WebBrowser As WebBrowser

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.Text = "送信サンプル"
        Me.WebBrowser = New WebBrowser
        Me.WebBrowser.Dock = DockStyle.Fill
        Me.Controls.Add(Me.WebBrowser)
        Me.WebBrowser.Navigate("http://www.yahoo.co.jp")
    End Sub

    Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
        Me.WebBrowser.Dispose()
    End Sub

    Private Sub WebBrowser_DocumentCompleted(ByVal sender As Object, ByVal e As System.Windows.Forms.WebBrowserDocumentCompletedEventArgs) Handles WebBrowser.DocumentCompleted
        Debug.Print(WebBrowser.Document.Url.ToString)
        If WebBrowser.Url.ToString = e.Url.ToString Then
            UDPSender(WebBrowser.Url.ToString)
        End If
    End Sub
    '
    'UDPでマルチキャストアドレスに送信する
    'マルチキャストアドレス224.168.1.1 ポート11000
    '
    Public Sub UDPSender(ByVal s As String)
        Dim GrpAdd As IPAddress = IPAddress.Parse("224.168.1.1")
        Dim GrpPort As Integer = 11000
        Dim GrpEP As New IPEndPoint(GrpAdd, GrpPort)
        Dim Udp As New UdpClient
        Try
            Dim Bytes As Byte() = Encoding.ASCII.GetBytes(s)
            Udp.Send(Bytes, Bytes.Length, GrpEP)
            Udp.Close()
        Catch ex As Exception
            If Not IsNothing(Udp) Then
                Udp.Close()
            End If
        End Try
    End Sub

End Class

「受信ブラウザ」

'UDPプロトコルマルチキャストアドレス受信サンプル
Imports System.Net.Sockets
Imports System.net
Imports System.Text
Imports System.Threading

Public Class Form1

    Dim WithEvents WebBrowser As WebBrowser
    Dim UdpListenerThread As Thread
    Dim Udp As UdpClient

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.Text = "受信サンプル"
        Me.WebBrowser = New WebBrowser
        Me.WebBrowser.Dock = DockStyle.Fill
        Me.Controls.Add(Me.WebBrowser)
        'UDPをマルチスレッドで受信する
        UdpListenerThread = New Thread(AddressOf UDPListener)
        UdpListenerThread.IsBackground = True
        UdpListenerThread.Start()
    End Sub

    Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
        '受信スレッド終了
        If Not IsNothing(Udp) Then
            Udp.Close() '受信スレッドは例外で終了する
        End If
        '受信スレッド終了の確認
        If Not IsNothing(UdpListenerThread) AndAlso Not UdpListenerThread.Join(1000) Then
            '終了が確認できないときは強制終了
            UdpListenerThread.Abort()
            Debug.Print("受信スレッド強制終了")
        End If

    End Sub
    'UDPでマルチスレッドアドレスから受信する
    'マルチキャストアドレス224.168.1.1 ポート11000
    '
    Private Sub UDPListener()
        Dim GrpAdd As IPAddress = IPAddress.Parse("224.168.1.1")
        Dim GrpPort As Integer = 11000
        Dim grpEP As New IPEndPoint(GrpAdd, GrpPort)
        Udp = New UdpClient(11000)
        Dim Url As String
        Try
            Udp.JoinMulticastGroup(GrpAdd) 'マルチキャストグループに参加する
            Do
                Dim Bytes As Byte() = Udp.Receive(grpEP)
                Url = Encoding.ASCII.GetString(Bytes, 0, Bytes.Length)
                Debug.Print(Url)
                Try
                    WebBrowser.Invoke(New WebBrowserNavigateDelegate(AddressOf WebBrowser.Navigate), New Object() {Url})
                Catch ex As Exception
                    Trace.WriteLine(ex.Message)
                End Try
            Loop
        Catch ex As Exception
            Debug.WriteLine(ex.Message)
            If Udp IsNot Nothing Then Udp.Close()
        Finally
                Trace.WriteLine("UDP受信スレッド終了")
        End Try
    End Sub

    Delegate Sub WebBrowserNavigateDelegate(ByVal Url As String)

End Class

| | コメント (2) | トラックバック (0)

WebBrowserコントロールの更新の完了のイベントを発生させる

WebBrowserコントロールでは例えばF5キーを押すなどした更新はNavigatingイベントやDocumentCompletedイベントが発生しない。

以下のコードは手抜きのコードだがこれを発生させる一つの例である。

Public Class Form1

    Dim WithEvents WebBrowser1 As New ExWebBrowser

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.WebBrowser1.Dock = DockStyle.Fill
        Me.Controls.Add(Me.WebBrowser1)
        Me.WebBrowser1.GoHome()
    End Sub

    Private Sub WebBrowser1_DocumentCompleted(ByVal sender As Object, ByVal e As System.Windows.Forms.WebBrowserDocumentCompletedEventArgs) Handles WebBrowser1.DocumentCompleted
        If e.Url = DirectCast(sender, WebBrowser).Url Then
            MessageBox.Show("読み込み完了" & e.Url.ToString)
        End If
    End Sub

End Class

Public Class ExWebBrowser
    Inherits WebBrowser

    Public Overrides Function PreProcessMessage(ByRef msg As System.Windows.Forms.Message) As Boolean
        Const WM_KEYDOWN As Integer = &H100
        If msg.Msg = WM_KEYDOWN Then
            Dim keyCode As Keys = CType(msg.WParam, Keys) And Keys.KeyCode
            Select Case keyCode
                Case Keys.F5
                    MessageBox.Show("F5が押されました", "ブラウザ更新", MessageBoxButtons.OK, MessageBoxIcon.Information)
                    Me.Refresh()
                    Return True
            End Select
        End If
        Return MyBase.PreProcessMessage(msg)
    End Function

    Public Overrides Sub Refresh()
        MyBase.Refresh()
        While Me.ReadyState = WebBrowserReadyState.Complete
            Application.DoEvents()
        End While
        While Me.ReadyState <> WebBrowserReadyState.Complete
            Application.DoEvents()
        End While
        Me.OnDocumentCompleted(New WebBrowserDocumentCompletedEventArgs(Me.Url))
    End Sub

End Class

| | コメント (3) | トラックバック (0)

文字列中の半角カタカナを全角カタカナに置換する

文字列の中の半角カタカナを全角のカタカナに置き換えます。

正規表現を使っています。

Imports System.Text.RegularExpressions

    Private Function ConvertKana(ByVal Src As String) As String
        Return Regex.Replace(Src, "[\uFF61-\uFF9F]+", New MatchEvaluator(AddressOf RegexMatchEvaluator))
    End Function

    Private Function RegexMatchEvaluator(ByVal M As Match) As String
        Return Strings.StrConv(M.Value, VbStrConv.Wide, 0)
    End Function

| | コメント (0) | トラックバック (0)

ShellオブジェクトからHTMLDocumentを取得し,IEの表示しているURLを取得する

Getieurl

外部で起動したIEの表示しているWebページのURLをリストボックスに列挙します。

ShellオブジェクトにはExplorerとInternetExplorerがあるので,Documentの型をチェックして区別しています。型のチェックをTypeNameで行うサンプルもありますが,いつも同じ型名を返すとは限らず,安定して動作しません。ここはmshtmlを参照設定して型のチェックをして方がよいと思います。(DLLが作成されてしまうのですが...)

Imports System.Runtime.InteropServices
Imports mshtml

Public Class Form1
    Dim WithEvents ListBox1 As New ListBox
    Dim WithEvents Timer1 As New Timer

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        'ListBox1
        ListBox1.Dock = DockStyle.Fill
        ListBox1.IntegralHeight = False
        'From1
        Me.Text = "GetIEURL"
        Me.Controls.Add(ListBox1)
        'Timer1
        Timer1.Interval = 1000
        Timer1.Enabled = True
    End Sub

    Private Sub Timer_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        Dim Shell As Object = Nothing 'Shellオブジェクト(COMオブジェクト)
        Dim Document As Object = Nothing 'IWebDocument2オブジェクト(COMオブジェクト)
        Dim State As WebBrowserReadyState
        ListBox1.Items.Clear()
        Try
            Shell = CreateObject("Shell.Application").Windows 'Shellオブジェクトを取得
            For Each Obj As Object In Shell
                Try
                    State = CType(Obj.ReadyState, Integer) 'オブジェクトがアクセス可能かどうか調べる
                    If State >= WebBrowserReadyState.Interactive Then
                        Document = Obj.document
                        If TypeOf Document Is mshtml.HTMLDocument Then 'IEだけ
                            ListBox1.Items.Add(Obj.document.url)
                        End If
                    End If
                Catch ex As Exception
                Finally
                    If Not Document Is Nothing AndAlso Marshal.IsComObject(Document) Then
                        Marshal.ReleaseComObject(Document) 'COMオブジェクトを解放
                    End If
                End Try
            Next
        Catch ex As Exception
        Finally
            If Not Shell Is Nothing AndAlso Marshal.IsComObject(Shell) Then
                Marshal.ReleaseComObject(Shell) 'COMオブジェクトを解放
            End If
        End Try
    End Sub

    Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
        Me.Timer1.Enabled = False
        Me.Timer1.Dispose()
        Me.ListBox1.Dispose()
    End Sub

End Class

| | コメント (0) | トラックバック (0)

画面を拡大表示する

Zoomscreen

デスクトップを拡大表示します。

マウスのまわりをタイマで定期的にキャプチャして拡大してフォームのバックグラウンドイメージに表示します。ホイールで拡大率を変えることができます。

Option Strict On
Public Class Form1

    Dim WithEvents Timer1 As New Timer
    Dim Mag As Single = 5.0!

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.Text = "ZoomScreen"
        Me.TopMost = True
        Me.SetStyle(ControlStyles.OptimizedDoubleBuffer, True)
        Me.SetStyle(ControlStyles.AllPaintingInWmPaint, True)
        Me.Timer1.Interval = 50
        Me.Timer1.Enabled = True
    End Sub

    Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
        Me.Timer1.Enabled = False
    End Sub

    Private Sub Timer1_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        If Me.BackgroundImage IsNot Nothing Then
            Using Image As Image = Me.BackgroundImage
                Me.BackgroundImage = Nothing
            End Using
        End If
        Me.BackgroundImage = New Bitmap(Me.ClientSize.Width, Me.ClientSize.Height)
        Using Image As Image = New Bitmap(CInt(Me.BackgroundImage.Width / Mag), CInt(Me.BackgroundImage.Height / Mag))
            Dim X As Integer = Control.MousePosition.X - Image.Width \ 2
            Dim Y As Integer = Control.MousePosition.Y - Image.Height \ 2
            If X < 0 Then
                X = 0
            ElseIf X + Image.Width > Screen.GetBounds(Control.MousePosition).Right Then
                X = Screen.GetBounds(Control.MousePosition).Right - Image.Width
            End If
            If Y < 0 Then
                Y = 0
            ElseIf Y + Image.Height > Screen.GetBounds(Control.MousePosition).Bottom Then
                Y = Screen.GetBounds(Control.MousePosition).Bottom - Image.Height
            End If
            Using Graph As Graphics = Graphics.FromImage(Image)
                Graph.CopyFromScreen(New Point(X, Y), New Point(0, 0), Image.Size)
            End Using
            Using Graph As Graphics = Graphics.FromImage(Me.BackgroundImage)
                Graph.InterpolationMode = Drawing2D.InterpolationMode.NearestNeighbor
                Graph.DrawImage(Image, New Rectangle(New Point(0, 0), Me.BackgroundImage.Size))
            End Using
        End Using
    End Sub

    Private Sub Form1_MouseWheel(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Me.MouseWheel
        Mag += CSng(IIf(e.Delta > 0, 1.0!, -1.0!))
        If Mag < 1.0! Then
            Mag = 1.0!
        ElseIf Mag > 10.0! Then
            Mag = 10.0!
        End If
    End Sub

End Class

| | コメント (0) | トラックバック (0)

IE7のお気に入りが表示されない

WindowsXpにIE7をインストールして使っていたら,ある日お気に入りが表示されなくなってしまった。

%USERPROFILE%\FavoritesにWebページへのショートカットは存在している。しかたがないのでIE7をアンインストールしたが改善しない。IE6のお気に入りもグレーの四角が表示されるだけだ。お気に入りの追加も整理もできない。Shiftキーを押しながらお気に入りの整理をクリックしてもお気に入りのフォルダが開かない。うーむ。

レジストリがおかしくなったのかと

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Favorites

を確認すると,データは

%USERPROFILE%\Favorites

で正しいようだ。ただ,種類がREG_SZになっている。これはREG_EXPAND_SZではないだろうか? 種類をREG_EXPAND_SZとして試しにキーを作り直してみると...

直った!

レジストリの値がおかしくなることは時々あるけれど,種類がおかしくなったのは初めてだ。

| | コメント (5) | トラックバック (0)

«ホイールのスクロール量を設定する