Keskustelu: Ohjelmointikysymykset: VB.NET: [VB .NET] Webcamista kuva tiedostoon

'väännetty SharpDevelop 3.1 betalla
Imports System
Imports System.Diagnostics
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Imports System.Threading
Imports System.Windows.Forms

Public Partial Class MainForm

   <DllImport("user32.dll")> _
   Private Shared Function GetWindowRect( _
        hWnd As IntPtr, ByRef lpRect As RECT) As _
        <MarshalAs(UnmanagedType.Bool)> Boolean
   End Function

   <StructLayout(LayoutKind.Sequential)> _
   Public Structure RECT
      Public Left As Integer
      Public Top As Integer
      Public Right As Integer
      Public Bottom As Integer
   End Structure

   Dim basePath As String = _
   Environment.GetFolderPath( _
   Environment.SpecialFolder.Desktop) & "\pictures"

   Private TheAppName As String = "CamPlay"

   Public Sub New()
      Me.InitializeComponent()
   End Sub

   Sub MainFormLoad(sender As Object, e As EventArgs)
      Me.pictureBox1.Visible = False
   End Sub

   Sub Button1MouseDown(sender As Object, e As MouseEventArgs)

      ClipBoard.Clear
      pictureBox1.Image = Nothing
      pictureBox2.Image = Nothing

   End Sub

   Sub Button1MouseUp(sender As Object, e As MouseEventArgs)

      If Not GetProcessId(TheAppName) Is Nothing Then

         Dim progid As Integer = GetProcessId(TheAppName)(0)
         Dim hWnd As IntPtr = GetProcessId(TheAppName)(1)

         Dim rct As RECT
         GetWindowRect(hWnd, rct)
         Dim fWndWidth As Integer = rct.Right - rct.Left
         Dim fWndHeight As Integer = rct.Bottom - rct.Top
         MsgBox("Capturing from CamPlay")

         Dim errcnt As Integer = 0
Back:
         AppActivate(progid)
         Thread.Sleep(100)
         Sendkeys.Send("%{PRTSC}")
         Thread.Sleep(100)

         If Not Clipboard.GetDataObject() Is Nothing Then

            pictureBox1.Image = _
            Clipboard.GetDataObject.GetData( _
            DataFormats.Bitmap)

            If Dir(basePath, vbDirectory) = "" Then
               MkDir(basePath)
            End If

            Dim fileName As String = "testi.jpg"
            Dim fullPath As String = basePath & "\" & fileName

            If Dir(fullPath) <> "" Then
               Kill(fullPath)
               Do While Dir(fullPath) <> "": Loop
            End If

            If Not PictureBox1.Image Is Nothing Then

               Dim fr_bm As New Bitmap(PictureBox1.Image)

               'nämä laatikot täytyy...
               Dim fr_rect As New Rectangle( _
               PictureBox1.Left + 10, PictureBox1.Top + 70, _
               PictureBox1.Left + PictureBox1.Image.Width _
               - 50, PictureBox1.Top + _
               PictureBox1.Image.Height - 120)

               '...säädellä "käsikopelolla"
               Dim to_rect As New Rectangle(0, 0, _
               PictureBox1.Image.Width - 20, _
               PictureBox1.Image.Height - 120)

               Dim bm As New Bitmap(to_rect.Width, _
               to_rect.Height, PixelFormat.Format32bppRgb)

               bm.MakeTransparent()

               PictureBox2.Image = bm

               Dim to_bm As New Bitmap(PictureBox2.Image)
               Dim gr As Graphics = Graphics.FromImage(to_bm)
               gr.DrawImage(fr_bm, to_rect, _
               fr_rect, GraphicsUnit.Pixel)

               PictureBox2.Image = to_bm

               PictureBox2.Image.Save(fullPath, _
               System.Drawing.Imaging.ImageFormat.Jpeg)
               AppActivate(Me.Text)
            Else
               errcnt += 1
               If errcnt > 25 Then
                  MsgBox("Capturing was not successful!")
                  Exit sub
               End If
               Goto Back
            End If
         Else
            MsgBox("No data on ClipBoard")
         End If

      Else
         MsgBox( TheAppName & ".exe is not a running process")
         Exit Sub
      End If

   End Sub

   Function GetProcessId(ByVal AppName As String) As Object

       For Each proc As Process In Process.GetProcesses()
         With proc
            If .ProcessName.ToLower _
               = AppName.ToLower Then
               Dim retObj(1) As Object
               retObj(0) = .Id
               retObj(1) = .MainWindowHandle
               Return retObj: retObj = Nothing
               Exit Function
            End If
         End With
       Next

       Return Nothing

   End Function

   Sub MainFormFormClosing(sender As Object, _
   e As FormClosingEventArgs)
      Me.Dispose
   End Sub

   Sub MainFormFormClosed(sender As Object, _
   e As FormClosedEventArgs)
      End
   End Sub

End Class