VBA技術解説
VBAでWEBカメラ操作する

ExcelマクロVBAの問題点と解決策、VBAの技術的解説
最終更新日:2020-03-06

VBAでWEBカメラ操作する


VBAでWEBカメラを操作してみます。
WEBカメラの映像を映し出し、任意の時点でスナップショットをとるようにしています。


エクセルでやる実用的な意味はほとんどありませんが、技術的な興味でやってみた自身の覚え書きになります。
したがって、解説はほとんどなくVBAコードの紹介になります。

ActiveMovie Windowを起動する

参考にしたサイト

WEBカメラの画像をキャプチャする
http://tanlab.blog.fc2.com/blog-entry-25.html

上記サイトのVBAはそのまま動作するもので、以下はこれを機能拡張したものになります。
複数カメラがある場合の選択画面や、スナップショットをとる為のユーザーフォームを作成しています。

以下のVBAでは、参照設定が必要です。
ActiveMovie control type liblary

メインのユーザーフォーム

ユーザーフォームのサンプル

マクロ VBA WEBカメラ

ユーザーフォームのオブジェクト名
frmWebCamera
コントロールのオブジェクト名
「撮影」ボタン:btnCapture
「終了」ボタン:btnClose
Imageコントロール:imgCapture

フォームモジュール

Option Explicit

'ウインドウサイズ取得用
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" _
            (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1

Private pActiveMovie As FilgraphManager
Private pImgFolder As String

'画像の保存先フォルター
Property Get ImgFolder() As String
  If pImgFolder = "" Then
    ImgFolder = ThisWorkbook.Path & "\Camera_Temp"
  Else
    ImgFolder = pImgFolder
  End If
  If Right(ImgFolder, 1) = "\" Then
    ImgFolder = Left(ImgFolder, Len(ImgFolder) - 1)
  End If
  
  Call CreateFolder(ImgFolder)
End Property
Property Let ImgFolder(ByVal arg As String)
  pImgFolder = arg
End Property

'エントリーポイント
Public Sub ShowModeless()
  'タイトル
  Me.Caption = "Webカメラ - Excel"
  
  '画像全体が見えるように
  Me.imgCapture.PictureSizeMode = fmPictureSizeModeZoom
  
  'Webカメラ起動
  If Not StartCamera Then Exit Sub
  
  'ActiveMovieの横にフォームを表示
  Call MyselfPosition
  
  'モードス表示
  Me.Show vbModeless
End Sub

'シートを出してしまったとき用:フォームの何もない部分のクリック
Private Sub UserForm_Click()
  Application.WindowState = xlMinimized
  Me.Show vbModeless
End Sub

'フォーム初期処理
Private Sub UserForm_Terminate()
  Set pActiveMovie = Nothing
  Application.WindowState = xlMaximized
End Sub

'「撮影」ボタン
Private Sub btnCapture_Click()
  Call CaptureCamera
  AppActivate Application.Caption
End Sub

'「終了」ボタン
Private Sub btnClose_Click()
  Unload Me
End Sub

'WEBカメラを起動
Function StartCamera() As Boolean
  Dim iRegFilter As IRegFilterInfo
  Dim iFilter As IFilterInfo
  Dim iPin As IPinInfo
  
  Set pActiveMovie = New FilgraphManager
  
  'カメラのFilterを選択
  Set iRegFilter = frmSelectCamera.GetFilter(pActiveMovie)
  If iRegFilter Is Nothing Then
    Set pActiveMovie = Nothing
    MsgBox "カメラが選択されませんでした。"
    StartCamera = False
    Exit Function
  End If
  
  'カメラ起動
  iRegFilter.Filter iFilter
  iFilter.Pins.Item 0, iPin
  iPin.Render
  pActiveMovie.Run
  
  'カメラが使用可能か判定
  If Not EnabledCamera(pActiveMovie) Then
    Set pActiveMovie = Nothing
    MsgBox "選択したカメラは使用てせきません。"
    StartCamera = False
    Exit Function
  End If
  
  '一応開放しておく
  Set iPin = Nothing
  Set iFilter = Nothing
  Set iRegFilter = Nothing
  
  StartCamera = True
End Function

'選択したカメラが使用可能か判定
Private Function EnabledCamera(ByRef pActiveMovie As FilgraphManager) As Boolean
  On Error Resume Next
  Dim iVideo As IBasicVideo
  Set iVideo = pActiveMovie
  iVideo.GetVideoSize 0, 0
  Set iVideo = Nothing
  If Err Then
    EnabledCamera = False
    Exit Function
  End If
  EnabledCamera = True
End Function

'カメラ映像をビットマップで保存
Private Sub CaptureCamera()
  pActiveMovie.Pause '無くても良い
  
  'カメラのサイズ取得
  Dim iVideo As IBasicVideo
  Dim iWidth As Long, iHeight As Long
  Set iVideo = pActiveMovie
  iVideo.GetVideoSize iWidth, iHeight
  
  'カメラ映像取得:DIB形式(BMPのデータ形式)
  Const DibHeaderSize = 10
  Dim Dib()  As Long, DibSize As Long
  DibSize = iWidth * iHeight
  ReDim Dib(DibSize + DibHeaderSize - 1)
  iVideo.GetCurrentImage (DibSize + DibHeaderSize) * 4, Dib(0)
  Set iVideo = Nothing
  
  pActiveMovie.Run '無くても良い
  
  'DIBをBMPで保存
  Dim fileNum As Integer
  fileNum = FreeFile()
  Dim imgFile As String
  imgFile = ImgFolder() & "\tmp_" & Format(Now(), "yyyymmdd" & Timer() * 100) & ".bmp"
  Open imgFile For Binary As fileNum
  Put fileNum, , "BM"
  Put fileNum, , CLng(DibSize * 4 + &H36)
  Put fileNum, , CLng(0)
  Put fileNum, , CLng(&H36)
  Put fileNum, , Dib
  Close fileNum
  
  'BMPをフォームのイメージコントロールに表示
  Me.imgCapture.Picture = LoadPicture(imgFile)
End Sub

'指定フォルダが無ければ作成
Private Sub CreateFolder(ByVal strFolder As String)
  Dim fso As New Scripting.FileSystemObject
  Set fso = CreateObject("Scripting.FileSystemObject")
  If Not fso.FolderExists(strFolder) Then
    Call fso.CreateFolder(strFolder)
  End If
  Set fso = Nothing
End Sub

'フォームの表示位置を制御
Private Sub MyselfPosition()
  Dim x As Long, y As Long
  x = GetSystemMetrics(SM_CXSCREEN) * 0.75 / 1.25
  y = GetSystemMetrics(SM_CYSCREEN) * 0.75 / 1.25
  Me.Top = 0
  Me.Left = x - Me.Width
  Application.WindowState = xlMinimized
End Sub

MyselfPosition内の0.75は、ポイントをピクセルに変換しています。
そして、ディスプレイを125%にしている場合として、/ 1.25しています。

このVBAではフォームに表示するところまでですが、シートに追加する場合は、
写真の取込方法について(Pictures.Insert,Shapes.AddPicture)
写真を取り込んで、アルバムのようにしたり、各種の資料を作ったりと、写真をエクセルに取り込む機会は多いようです。しかし、最近は写真のサイズも大きくなり、手動で取り込んだままではスクロールもままならない状態となってしまいます。そこで写真ファイルを指定し、A列に上から順番に貼り付け、さらにセル内に収まるように縮小するVBAになります。
こちらを参考に追加してください。

VBAコードはそれほど難しい部分はありませんので読み解いてください。
上記VBAでは、メインのユーザーフォームをディスプレイの右上に表示していますが、
ActiveMovie Windowのとなりに表示する場合は、以下のようにしてください。
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
              (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" _
              (ByVal hwnd As Long, lpRect As RECT) As Long

Private Sub MyselfPosition()
  Dim myRect As RECT
  myRect = GetCameraRect("ActiveMovie Window")
  Me.Top = myRect.Top * 0.75 / 1.25
  Me.Left = myRect.Right * 0.75 / 1.25
  Application.WindowState = xlMinimized
End Sub

'ActiveMovieの位置、サイズを取得
Private Function GetCameraRect(ByVal strCaption) As RECT
  Dim hwnd As Long
  Dim myRect As RECT
  'ActiveMovieのウインドウハンドルを取得
  hwnd = FindWindow(vbNullString, strCaption)
  'ActiveMovieが起動していない場合は0,0,0,0を返す
  If hwnd = 0 Then
    Exit Function
  End If
  '位置、サイズ情報の取得
  GetWindowRect hwnd, myRect
  GetCameraRect = myRect
End Function

先のVBAのMyselfPositionを上記に入れ替えると、ActiveMovie Windowのとなりに表示されます。

WEBカメラを選択するユーザーフォーム

ユーザーフォームのサンプル

マクロ VBA WEBカメラ

ユーザーフォームのオブジェクト名
frmSelectCamera
コントロールオブジェクト名
「OK」ボタン:btnOk
「Cancel」ボタン:btnCancel
Listコントロール:lstFilter

フォームモジュール

Option Explicit

Private pFilter As String

'エントリーポイント
Public Function GetFilter(ByRef pActiveMovie As FilgraphManager) As IRegFilterInfo
  Dim iRegFilter As IRegFilterInfo
  Dim strFilter As String
  
  'Filterからカメラと思われるものをリスト追加
  Me.lstFilter.Clear
  For Each iRegFilter In pActiveMovie.RegFilterCollection
    strFilter = iRegFilter.Name
    If LCase(strFilter) Like "*webcam*" Or _
      LCase(strFilter) Like "*camera*" Then
      'リスト登録済かの確認:同じ名称が複数ある
      If Not ListExists(strFilter) Then
        Me.lstFilter.AddItem strFilter
      End If
    End If
  Next
  
  'WEBカメラ選択
  If Me.lstFilter.ListCount = 1 Then
    'カメラが1つなら決定
    pFilter = Me.lstFilter.List(0)
  Else
    'カメラが複数あれば選択画面
    pFilter = ""
    Me.Show
  End If
  
  'リスト選択に対応するIRegFilterInfoを戻す
  If pFilter <> "" Then
    Set GetFilter = GetRegFilter(pActiveMovie, pFilter)
  End If
  
  '閉じる
  Unload Me
End Function

'「OK」ボタン
Private Sub btnOk_Click()
  If Me.lstFilter.ListIndex < 0 Then Exit Sub
  pFilter = Me.lstFilter.List(Me.lstFilter.ListIndex)
  Me.Hide
End Sub

'「Cancel」ボタン
Private Sub btnCancel_Click()
  Me.Hide
End Sub

'リスト登録済かの確認:同じ名称が複数あるので
Private Function ListExists(ByVal strFilter As String) As Boolean
  Dim i As Long
  With Me.lstFilter
    For i = 0 To .ListCount - 1
      If .List(i) = strFilter Then
        ListExists = True
        Exit Function
      End If
    Next
  End With
  ListExists = False
End Function

'Filter文字列からIRegFilterInfoを戻す
Public Function GetRegFilter(ByRef pActiveMovie As FilgraphManager, _
               ByVal strFilter As String) As IRegFilterInfo
  Dim iRegFilter As IRegFilterInfo
  For Each iRegFilter In pActiveMovie.RegFilterCollection
    If iRegFilter.Name = strFilter Then
      Set GetRegFilter = iRegFilter
      Exit For
    End If
  Next
End Function

RegFilterCollectionには、WEBカメラ以外が沢山あるので、カメラと思われるもののみリスト追加しています。

ちなみにテスト機にはインカメがあり、さらにUSBカメラを接続した場合は、

マクロ VBA WEBカメラ

このように出力されました。
USBカメラのマイク等も同様の名称になっているためリストに出てきています。
ただし上記VBAでは、これらカメラとして機能しないものを選択した場合は、
メインのユーザーフォームに戻った後に、"選択したカメラは使用てせきません。"のメッセージで終了します。

上記ユーザーフォームの使い方

全てユーザーフォーム内で行っているので、起動はエントリーポイントを呼び出すだけになります。

Sub Sample()
  frmWebCamera.ShowModeless
End Sub

マクロ VBA WEBカメラ

APIを使いキャプチャをとる

参考にしたサイト

VBAでカメラを動かす(AccessでもExcelでもWordでも)
http://www5a.biglobe.ne.jp/~kkw_pl2/kkwvbs/vbacamera.htm

上記サイトのVBAはAccessメインになっていて、Excelも併記しているVBAとなっています。
Excelで不要な部分を消せば、そのままで動作します。
ボタン押下時の画像を保存しているだけなので、ここではあくまで参考として紹介だけしておきます。

VBAでWEBカメラ操作の最後に

今回は、VBAでWEBカメラに接続する方法について調べたものを、実際に動かしてみた記録です。

実際の使い道はほとんどないと思います。
上記では、BMPを作成するまでになっていますが、
JPEGで保存してシートに貼り付けるくらいまでやれば何かに使えるかもしれませんが、VBAでわざわざやる必要性は感じられませんでした。

また、インカメの場合は左右が反転したイメージになってしまいます。
ちゃんとしたアプリなら、インカメは左右を反転することになりますが、さすがにVBAでそこまでは難しいでしょう。
そして、いろいろやってほぼ完成した後に、とつぜんインカメが映らなくなってしまいました。
スナップショットは機能していているのに、動画が表示されない状態になってしまいました、
Windowsのカメラ等は機能しているので、このソフトのどこかに問題いがあるのかもしれません。
さらに激しく使うと、たまにフリーズしてしまう事もありました。
なかなか安定した使い方はできず難しいと思いました。

結論としては、他の便利なツールがあるので、それらを使ったほうが良いと思います。
あくまで、試しにやってみたことを覚え書きとして記録に残したものになります。



同じテーマ「マクロVBA技術解説」の記事

Rangeオブジェクトの論理演算(差集合と排他的論理和)
VBAで写真の撮影日時や音楽動画の長さを取得する
VBAでWindowsMediaPlayerを使い動画再生する
VBAでWEBカメラ操作する
VBAで電光掲示板を作成
ユーザーに絶対に停止させたくない場合のVBA設定
列幅・行高をDPI取得しピクセルで指定する
VBAでWMIの使い方について
アクティブシート以外のWindowを設定できるWorksheetView
LSetとユーザー定義型のコピー(100桁の足し算)
省略可能なVariant引数の参照不可をラップ関数で利用


新着記事NEW ・・・新着記事一覧を見る

import文(パッケージ・モジュールのインポート)|Python入門(9月24日)
例外処理(try文)とexception一覧|Python入門(9月23日)
リスト内包表記|Python入門(9月22日)
Pythonの引数は参照渡しだが・・・|Python入門(9月21日)
lambda(ラムダ式、無名関数)と三項演算子|Python入門(9月20日)
関数内関数(関数のネスト)とスコープ|Python入門(9月18日)
関数の定義(def文)と引数|Python入門(9月18日)
組み込み関数一覧|Python入門(9月17日)
辞書(dict型)|Python入門(9月16日)
入力規則への貼り付けを禁止する|VBA技術解説(9月16日)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
7.繰り返し処理(For Next)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ