Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compile Exe
#Dim All
%Unicode = 1
#Include "Win32API.inc"
#Include Once "dshow.inc"
#Include Once "dshow_utilities.inc"
Enum Equates Singular
IDM_GetCurrentFormat = 500
IDM_ShowCameraList
IDM_NextCamera
IDM_Set3840
IDM_Set1920
IDM_Set1600
IDM_Set1280
IDM_Set800
IDM_Set640
IDM_Sep
End Enum
%BT = 24
Function PBMain() As Long
Dialog New Pixels, 0, "Select Camera/Format",,,640,480, %WS_OverlappedWindow Or %WS_ClipChildren To hDlg
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local x,y,w,h,iResult As Long
Select Case Cb.Msg
Case %WM_InitDialog
CreateContextMenu
GetCameraList
CameraIndex = 1 'Camera to display on startup
Camera$ = Parse$(CameraList$,$CrLf,CameraIndex) 'Camera name corresponding to CameraIndex
GetMatchingMoniker
DisplayNamedCamera
SetMatchingFormat(1920,1080,%BT)
GetCurrentFormat(w,h,%BT)
SetDialogCaption(w,h,%BT)
Case %WM_Command
Select Case Cb.Ctl
Case %IDM_ShowCameraList : ? "Camera List: " + $CrLf + $CrLf + CameraList$
Case %IDM_GetCurrentFormat : GetCurrentFormat(w,h,%BT) : SetDialogCaption(w,h,%BT)
Case %IDM_NextCamera : If CameraCount > 1 Then NextCamera Else ? "Only 1 camera found!"
Case %IDM_Set3840 : iResult = SetMatchingFormat(3840,2160,%BT) : If iResult = 0 Then ? "3840x2160 " + Trim$(Str$(%BT)) + " not supported!
Case %IDM_Set1920 : iResult = SetMatchingFormat(1920,1080,%BT) : If iResult = 0 Then ? "1920x1080 " + Trim$(Str$(%BT)) + " not supported!
Case %IDM_Set1600 : iResult = SetMatchingFormat(1600,1200,%BT) : If iResult = 0 Then ? "1600x1200 " + Trim$(Str$(%BT)) + " not supported!
Case %IDM_Set1280 : iResult = SetMatchingFormat(1280,720,%BT) : If iResult = 0 Then ? "1280x720 " + Trim$(Str$(%BT)) + " not supported!
Case %IDM_Set800 : iResult = SetMatchingFormat(800,600,%BT) : If iResult = 0 Then ? "800x600 " + Trim$(Str$(%BT)) + " not supported!
Case %IDM_Set640 : iResult = SetMatchingFormat(640,480,%BT) : If iResult = 0 Then ? "640x480 " + Trim$(Str$(%BT)) + " not supported!
End Select
Case %WM_ContextMenu
x = Lo(Integer,Cb.LParam) : y = Hi(Integer, Cb.LParam)
TrackPopupMenu hContext, %TPM_LeftAlign, x, y, 0, Cb.Hndl, ByVal 0
End Select
End Function
Sub CreateContextMenu
Menu New PopUp To hContext
Menu Add String, hContext, "Camera List", %IDM_ShowCameraList, %MF_Enabled
Menu Add String, hContext, "Next Camera", %IDM_NextCamera, %MF_Enabled
Menu Add String, hContext, "-", %IDM_Sep, %MF_Enabled
Menu Add String, hContext, "Get Current Format", %IDM_GetCurrentFormat, %MF_Enabled
Menu Add String, hContext, "-", %IDM_Sep, %MF_Enabled
Menu Add String, hContext, "Set 640x480", %IDM_Set640, %MF_Enabled
Menu Add String, hContext, "Set 800x600", %IDM_Set800, %MF_Enabled
Menu Add String, hContext, "Set 1280x720", %IDM_Set1280, %MF_Enabled
Menu Add String, hContext, "Set 1600x1200", %IDM_Set1600, %MF_Enabled
Menu Add String, hContext, "Set 1920x1080", %IDM_Set1920, %MF_Enabled
Menu Add String, hContext, "Set 3840x2160", %IDM_Set3840, %MF_Enabled
End Sub
Sub NextCamera
Local w,h As Long
Incr CameraIndex
If CameraIndex > ParseCount(CameraList$,$CrLf) Then CameraIndex = 1
Camera$ = Parse$(CameraList$,$CrLf,CameraIndex) 'Camera name corresponding to CameraIndex
GetMatchingMoniker
DisplayNamedCamera
GetCurrentFormat(w,h,%BT)
SetDialogCaption(w,h,%BT)
End Sub
http://www.garybeene.com/sw/gbsnippets.htm