VBAでWEBカメラ操作する

公開日：2020-03-06　最終更新日：2021-02-06

VBAでWEBカメラ操作する

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

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

※環境により上手く動かない場合が結構あるようです。
あくまで、筆者の特定PC環境で動かしたときのVBAコードの紹介になります。
また、ウィンドウ位置等は適当な感じで終わりにしていますので、もし使う場合は適宜対応してください。

ActiveMovie Windowを起動する

参考にしたサイト

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

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

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

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

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

ユーザーフォームのオブジェクト名

frmWebCamera

コントロールのオブジェクト名

「撮影」ボタン：btnCapture
「終了」ボタン：btnClose
Imageコントロール：imgCapture

フォームモジュール


  
    
      Option Explicit


      'ウインドウサイズ取得用

'Private Declare PtrSafe Function GetSystemMetrics Lib "user32" _

'                        (ByVal nIndex As Long) As LongPtr

'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 myRect As RECT

　　myRect = GetCameraRect("ActiveMovie Window")

　　Me.Top = myRect.Top / 1.25

　　Me.Left = myRect.Right / 1.25

　　Dim x As LongPtr, y As LongPtr

'　　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）

・Pictures.Insertメソッド・Shapes.AddPictureメソッド・Shapesに関連する記事

こちらを参考に追加してください。

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 LongPtr

      Private Declare PtrSafe Function GetWindowRect Lib "user32" _

      　　　　　　　　　　　　　　(ByVal hwnd As LongPtr, lpRect As RECT) As LongPtr


  
    
      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 LongPtr

      　　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カメラを選択するユーザーフォーム

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

ユーザーフォームのオブジェクト名

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からカメラと思われるものをリスト追加

      　　On Error Resume Next

      　　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

      　　On Error GoTo 0

      　　

      　　'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カメラを接続した場合は、

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

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

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


  
    
      Sub Sample()

      　　frmWebCamera.ShowModeless

End Sub

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引数の参照不可をラップ関数で利用

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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.マクロとは？VBAとは？VBAでできること｜VBA入門

ホーム
マクロVBA応用編
マクロVBA技術解説
VBAでWEBカメラ操作する

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

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

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