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

ExcelマクロVBAの問題点と解決策、VBAの技術的解説
公開日: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


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

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

マクロ VBA WEBカメラ

ユーザーフォームのオブジェクト名
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カメラを選択するユーザーフォーム

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

マクロ 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からカメラと思われるものをリスト追加
  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カメラを接続した場合は、

マクロ 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オブジェクトの論理演算(差集合と排他的論理和)

・集合について ・Rangeオブジェクトの論理演算のVBAについて ・和集合:Unionメソッド ・積集合:Intersectメソッド ・補集合 ・差集合 ・排他的論理和 ・Rangeオブジェクトの論理演算VBAの使い方とテスト
VBAで写真の撮影日時や音楽動画の長さを取得する
・VBAで写真の撮影日時を取得 ・全てのプロパティを取得するVBA ・全てのプロパティを取得するVBAの使用例 ・VBAで撮影日時や音楽動画の長さ取得の最後に
VBAでWindowsMediaPlayerを使い動画再生する
・ワークシートにWindowsMediaPlayerを事前に追加 ・ワークシートにWindowsMediaPlayerコントロールを動的に追加 ・ユーザーフォームにWindowsMediaPlayerを事前に追加 ・ユーザーフォームにWindowsMediaPlayerを動的に追加 ・簡単に動画再生するだけなら ・VBAでの動画再生の最後に
VBAでWEBカメラ操作する
VBAで電光掲示板を作成
・東雲フォントについて ・東雲フォントの追加説明 ・東雲フォントをシートに取得するVBA ・電光掲示板のシート構成 ・電光掲示板のVBA ・VBAで電光掲示板を作成の最後に
ユーザーに絶対に停止させたくない場合のVBA設定
ユーザー操作によりマクロVBAが実行中に停止させられてしまう場合があります。再実行可能であれば問題ありませんが、途中で強制停止された場合のデータ保証が出来ないと言った場合もあるでしよう。マクロ実行でも、以下のキーボード操作でVBAは停止できてしまいます。
列幅・行高をDPI取得しピクセルで指定する
・列幅・行高をピクセルで指定するVBA ・列幅・行高をピクセルで指定するVBAの使い方と解説
VBAでWMIの使い方について
・WMIを調べるときの推奨サイト ・VBAでのWMI使用方法 ・WMIにはどんなものがあるのか
アクティブシート以外のWindowを設定できるWorksheetView
・Windowオブジェクトのメソッドとプロパティ ・アクティブシート以外の表示(Window)に関する設定 ・アクティブシート以外の表示(Window)を設定するVBA ・全ウィンドウの全シートのWorksheetViewを設定するVBA
LSetとユーザー定義型のコピー(100桁の足し算)
・数値データ型の数値範囲 ・100桁数値の足し算VBA ・100桁数値の足し算VBAの使い方と結果 ・100桁数値の足し算VBAの解説
省略可能なVariant引数の参照不可をラップ関数で利用
省略可能(Optional)なVariant引数を省略した場合、その引数は「参照不可」となります。この「参照不可」の状態について説明します。そして、これをあえて利用してワークシート関数のラップ関数を作成してみます。


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

テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
累計を求める数式あれこれ|エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE|エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。|エクセル雑感(2023-12-28)
VBAでクリップボードへ文字列を送信・取得する3つの方法|VBA技術解説(2023-12-07)
難しい数式とは何か?|エクセル雑感(2023-12-07)
スピらない スピル数式 スピらせる|エクセル雑感(2023-12-06)
イータ縮小ラムダ(eta reduced lambda)|エクセル入門(2023-11-20)


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

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




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


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



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