Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compile Exe
#Dim All
#Debug Error On
#Debug Display On
%Unicode = 1
#Include "Win32API.inc"
#Include Once "dshow.inc"
#Include "qedit.inc"
%ID_Timer = 500
%IDC_Graphic = 501
$Camera = "TX-1/LX-1"
'$Camera = "Logitech HD Pro Webcam C920"
Type ThreadToken 'used to pass information to the threads fo which part of the image they should process
StartAddress As Long
PixelsToDo As Long
BWtriggerScaled As Long
End Type
Global hDlg, hDlgB, hDCA, hDCB As Dword
Global wRes, hRes, bwTrigger, bwTriggerScaled, TextColor, BGColor As Long
Global bgrA, bgrB, Algorithm As Long
Global pBuffer As String Ptr, pBufferSize As Long
Global r(), g(), b() As Long, bmp$
Global qFreq, qStart, qStop As Quad
Global pGraph As IGraphBuilder 'Filter Graph Manager
Global pBuild As ICaptureGraphBuilder2 'Capture Graph Builder
Global pSysDevEnum As ICreateDevEnum 'enumeration object
Global pEnumCat As IEnumMoniker
Global pMoniker As IMoniker 'contains information about other objects
Global pceltFetched As Dword
Global pCap As IBaseFilter 'Video capture filter
Global pControl As IMediaControl
Global pWindow As IVideoWindow 'Display Window
Global pbc As IBindCTX
Global pPropBag As IPropertyBag
Function PBMain() As Long
Dialog Default Font "Tahoma", 12, 1
' Dialog New Pixels, 0, "Two Dialog Image Conversion",300,300,1920,1080, %WS_OverlappedWindow Or %WS_ClipSiblings Or %WS_ClipChildren To hDlg
Dialog New Pixels, 0, "Two Dialog Image Conversion",300,300,640,480, %WS_OverlappedWindow Or %WS_ClipSiblings Or %WS_ClipChildren To hDlg
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local w,h As Long, PS As PaintStruct
Select Case Cb.Msg
Case %WM_InitDialog
bwTrigger = 128
TextColor = %Yellow
BGColor = %Blue
bgrA = Bgr(TextColor)
bgrB = Bgr(BGColor)
BWTriggerScaled = BWTrigger * 65536
pGraph = NewCom ClsId $CLSID_FilterGraph 'filter graph
pBuild = NewCom ClsId $CLSID_CaptureGraphBuilder2 'capture graph builder
pSysDevEnum = NewCom ClsId $CLSID_SystemDeviceEnum 'enumeration object
' DisplayFirstCamera
GetMatchingMoniker
DisplayNamedCamera
Dialog New Pixels, hDlg, "DirectShow SampleGrabber Test",0,0,1920,1080, %WS_Popup Or %WS_ClipSiblings Or %WS_ClipChildren To hDlgB
Dialog Show Modeless hDlgB Call DlgBProc
Case %WM_WindowPosChanged
Dialog Set Loc hDlgB, 0,0
Case %WM_Size
Dialog Get Client hDlg To w,h
pWindow.SetWindowPosition(0,0,w,h)
Dialog Set Size hDlgB, w,h
Graphic Set Size w, h 'video and memory bitmap kept the same size
Case %WM_Destroy
pGraph = Nothing
pBuild = Nothing
pSysDevEnum = Nothing
End Select
End Function
CallBack Function DlgBProc() As Long
Local w,h,wh As Long
Select Case Cb.Msg
Case %WM_InitDialog
QueryPerformanceFrequency qFreq
Control Add Graphic, hDlgB, %IDC_Graphic, "", 0,0,10,10, %SS_Notify
Graphic Attach hDlgB, %IDC_Graphic, ReDraw
Graphic Get DC To hDCB
SetTimer(hDlgB, %ID_Timer, 50, ByVal(%Null))
Case %WM_Size
Dialog Get Size hDlgB To w,h
Control Set Size hDlg, %IDC_Graphic, w,h
Case %WM_Command
Select Case Cb.Ctl
Case %IDC_Graphic : ChangeColor
End Select
Case %WM_Help
Incr Algorithm
If Algorithm > 7 Then Algorithm = 0
Case %WM_Timer
Dialog Get Client hDlg To w,h
hDCA = GetDC(hDlg)
BitBlt hDCB, 0,0,w,h, hDCA, 0,0, %SrcCopy 'copy using bitblt dialog hDC to memory Bitmap DC
Graphic Get Bits To bmp$
QueryPerformanceCounter qStart
Select Case Algorithm 'modifies content of bmp$
Case 0 'no conversation (test
Case 1 : ConvertToBinaryColorsA
Case 2 : ConvertToBinaryColorsB
Case 3 : ConvertToBinaryColorsC
Case 4 : ConvertToBinaryColorsD
Case 5 : ConvertToBinaryColorsE
Case 6
'get width/height of image
w = Cvl(bmp$,1) : h = Cvl(bmp$,5) : wh = w * h
Byte_ConversionToBW(w,h,wh)
Case 7
'get width/height of image
w = Cvl(bmp$,1) : h = Cvl(bmp$,5) : wh = w * h
Byte_ConversionToBW_Thread(w,h,wh)
End Select
QueryPerformanceCounter qStop
Graphic Set Bits bmp$
Graphic ReDraw
Dialog Set Text hDlg, Format$((qStop-qStart)/qFreq,"###.000") & " s " + Choose$(Algorithm+1, "None","1","2","3","4","5","6","7")
End Select
End Function
Sub DisplayFirstCamera
If pSysDevEnum.CreateClassEnumerator($CLSID_VideoInputDeviceCategory, pEnumCat, 0) <> %S_Ok Then Exit Sub
pEnumCat.next(1, pMoniker, pceltFetched) 'cycle through monikders
pMoniker.BindToObject(Nothing, Nothing, $IID_IBaseFilter, pCap) 'create device filter for the chosen device
pGraph.AddFilter(pCap,"First Camera") 'add chosen device filter to the filter graph
pBuild.SetFilterGraph(pGraph) 'initialize pBuild
pBuild.RenderStream $Pin_Category_Preview, $MediaType_Video, pCap, Nothing, Nothing 'render the live source
pWindow = pGraph
pWindow.Owner = hDlg
pWindow.WindowStyle = %WS_Child Or %WS_ClipChildren Or %WS_ClipSiblings 'video window settings
pControl = pGraph
pControl.Run
End Sub
Sub DisplayNamedCamera
pGraph = NewCom ClsId $CLSID_FilterGraph 'filter graph
pBuild = NewCom ClsId $CLSID_CaptureGraphBuilder2 'capture graph builder
pMoniker.BindToObject(Nothing, Nothing, $IID_IBaseFilter, pCap) 'create device filter for the chosen device
pGraph.AddFilter(pCap,$Camera) 'add chosen device filter to the filter graph
pBuild.SetFilterGraph(pGraph) 'initialize pBuild
pBuild.RenderStream $Pin_Category_Preview, $MediaType_Video, pCap, Nothing, Nothing 'render the live source
pWindow = pGraph : pWindow.Owner = hDlg : pWindow.WindowStyle = %WS_Child Or %WS_ClipSiblings Or %WS_ClipChildren 'video window settings
pControl = pGraph
pControl.Run
End Sub
Sub GetMatchingMoniker 'stops enumeration on moniker which has the friendly name
Local pceltFetched As Dword, pwszDisplayName As WStringZ Ptr, varName As Variant
pSysDevEnum = NewCom ClsId $CLSID_SystemDeviceEnum 'enumeration object
If pSysDevEnum.CreateClassEnumerator($CLSID_VideoInputDeviceCategory, pEnumCat, 0) <> %S_Ok Then Exit Sub
While pEnumCat.next(1, pMoniker, pceltFetched) <> %S_False 'cycle through monikers
pMoniker.GetDisplayName(pbc, Nothing, pwszDisplayName) 'get complex camera name
pMoniker.BindToStorage(Nothing, Nothing, $IID_IPropertyBag, pPropBag) 'get info about Moniker
pPropBag.Read("FriendlyName", varName, Nothing) 'get friendly name
If Variant$$(varName) = $Camera Then Exit Do
Loop
End Sub
Sub ChangeColor
If TextColor = %Yellow And BGColor = %Blue Then
TextColor = %White : BGColor = %Blue
ElseIf TextColor = %White And BGColor = %Blue Then
TextColor = %White : BGColor = %Black
ElseIf TextColor = %White And BGColor = %Black Then
TextColor = %Black : BGColor = %White
ElseIf TextColor = %Black And BGColor = %White Then
TextColor = RGB(150,150,150) : BGColor = %White
Else
TextColor = %Yellow : BGColor = %Blue
End If
End Sub
Sub ConvertToBinaryColorsA
Local w,h,i,iColor,R,G,B As Long, p As Long Ptr
'get width/height of image
w = Cvl(bmp$,1) : h = Cvl(bmp$,5) : p = StrPtr(bmp$)+8
'get string position of coordinates and modify the string at that position
For i = 1 To w*h
iColor = @p 'result is a BGR color value 0-R-G-B
B = iColor Mod 256 'or this: iColor AND &HFF&
G = (iColor\256) Mod 256 'or this: (iColor AND &HFF00&) \ &H100
R = (iColor\256\256) Mod 256 'or this: (iColor AND &HFF0000&) \ &H10000&
iColor = 0.299*R + 0.587*G + 0.114*B 'or this: iColor = (R+G+B)/3
If iColor <= BWTrigger Then @p = Bgr(TextColor) Else @p = Bgr(BGColor)
Incr p
Next i
End Sub
Sub ConvertToBinaryColorsB
Local w As Long, h As Long, bp As Byte Ptr, i As Long, p As Long Ptr
Local iColor As Long, R As Long, G As Long, B As Long
'get width/height of image
w = Cvl(bmp$,1) : h = Cvl(bmp$,5) : bp = StrPtr(bmp$)+8
p = bp
'get string position of coordinates and modify the string at that position
For i = 1 To w*h
B = @bp 'string BGR bytes positions are 0-R-G-B
Incr bp : G = @bp
Incr bp : R = @bp
Incr bp : Incr bp
iColor = 0.299*R + 0.587*G + 0.114*B 'create gray component
If iColor <= BWTrigger Then @p = Bgr(TextColor) Else @p = Bgr(BGColor)
Incr p
Next i
End Sub
Sub ConvertToBinaryColorsC
Local R,G,B,iColor,w,h,i As Long, bp As Byte Ptr, p As Long Ptr
'get width/height of image
w = Cvl(bmp$,1) : h = Cvl(bmp$,5) : p = StrPtr(bmp$)+8
'get string position of coordinates and modify the string at that position
For i = 1 To w*h
bp = p
B = @bp[0] 'string BGR bytes positions are 0-R-G-B
G = @bp[1] 'string BGR bytes positions are 0-R-G-B
R = @bp[2] 'string BGR bytes positions are 0-R-G-B
iColor = 0.299*R + 0.587*G + 0.114*B 'create gray component
If iColor <= BWTrigger Then @p = BgrA Else @p = BgrB
Incr p
Next i
End Sub
Sub ConvertToBinaryColorsD 'Dixon post #49
Local w,h,p,iColor,R,G,B As Long
'get width/height of image
w = Cvl(bmp$,1) : h = Cvl(bmp$,5) : p = StrPtr(bmp$)+8
'get string position of coordinates and modify the string at that position
For p = p To p + 4 * w * h Step 4
B = Peek(Byte, p) : G = Peek( Byte, p+1) : R = Peek(Byte, p+2)
iColor = 19595 * R + 38470 * G + 7471 * R 'these are the same coefficients but *65536, scaled the same as the trigger value was
If iColor < BWtriggerScaled Then Poke Long,p, bgrA Else Poke Long, p, bgrB
Next i
End Sub
Sub ConvertToBinaryColorsE
Local w,h,i,iColor As Long, bp As Byte Ptr, p As Long Ptr
'get width/height of image
w = Cvl(bmp$,1) : h = Cvl(bmp$,5) : p = StrPtr(bmp$)+8
For p = p To p + 4 * w * h Step 4
bp = p
iColor = 19595*(@bp[2]) + 38470*(@bp[1]) + 7471*(@bp[1])
If iColor < BWTriggerScaled Then @p = BgrA Else @p = BgrB
Next p
End Sub
Sub Byte_ConversionToBW(w As Long, h As Long, wh As Long)
#Register None 'I'm using the registers so done let the compiler mess them up
Local p,BWtriggerScaled As Long
BWtriggerScaled = BWTrigger * 65536
p = StrPtr(bmp$)+8
!mov ecx,wh 'get the address of wh (it's a SUB parameter so when I load it I get the address, not the value).
!mov ecx,[ecx] 'get the value of wh
!mov esi,p 'get the pointer to the data into esi
#Align 16 'align the jump target of the loop on a cache boundary as it's faster
lp1:
!movzx eax,byte ptr [4*ecx+esi] 'get the B byte
!imul eax,7471 'multiply by 0.114 * 65536
!movzx edx,byte ptr [4*ecx+esi+1] 'get the G byte
!imul edx,38470 'muliply by 0.587 * 65536
!movzx edi,byte ptr [4*ecx+esi+2] 'get the R byte
!imul edi,19595 'muliply by 0.299 * 65536
!add eax,edx 'add the B and G results
!add eax,edi 'add in the R result
!mov edx,BgrB 'set the default colour ready for later
!cmp eax,BWtriggerScaled 'is the sum greater than the threshold?
!cmovl edx,BgrA 'choose the other colour for less than the threshold
!mov [4*ecx+esi],edx 'store the new colour
!dec ecx 'count down the loop
!jns short lp1 'if not negative, go back for the next pixel
End Sub
Type ThreadToken 'used to pass information to the threads fo which part of the image they should process
StartAddress As Long
PixelsToDo As Long
BWtriggerScaled As Long
End Type
Sub Byte_ConversionToBW_Thread(w As Long, h As Long, wh As Long) 'Dixon thread #58
Local r,p,BWtriggerScaled, NoofThreads As Long
Static CalledBefore As Long
Local BlockInfo() As ThreadToken
Local hThreads() As Long
'IF NOT CalledBefore THEN
' CalledBefore = -1 'so we don't do this again
' 'only do this copy once to create the bitmap rather than re-do it each time
' bmpOUT$ = bmpIN$
'
'END IF
NoofThreads = 4 'be careful to only use numbers which divide into the number of pixels with no remainder as I don't check for odd pixels. e.g 2,4,8,16 may be ok
Dim hThreads(1 To NoofThreads)
Dim BlockInfo(1 To NoofThreads)
BWtriggerScaled = BWTrigger * 65536
p = StrPtr(bmp$)+8
For r = 1 To NoofThreads
BlockInfo(r).StartAddress = p + (r-1)*(wh\NoofThreads)*4
BlockInfo(r).PixelsToDo = wh \ NoofThreads
BlockInfo(r).BWtriggerScaled = BWtriggerScaled
Thread Create ProcessingThread(VarPtr(BlockInfo(r))) To hThreads(r)
Next
For r = 1 To NoofThreads
WaitForSingleObject(hThreads(r), ByVal %INFINITE)
Next
End Sub
Thread Function ProcessingThread(ByVal TokenPointer As Long) As Long
#Register None 'I'm using the registers so don't let the compiler mess them up
Local InputData As ThreadToken Ptr
Local StartAddress,PixelsToDo, BWtriggerScaled As Long
InputData=TokenPointer
StartAddress = @InputData.StartAddress
PixelsToDo = @InputData.PixelsToDo
BWtriggerScaled = @InputData.BWtriggerScaled
!mov ecx,PixelsToDo
!mov esi,StartAddress
#Align 16 'align the jump target of the loop on a cache boundary as it's faster
lp1:
!movzx eax,byte ptr [4*ecx+esi] 'get the B byte
!imul eax,eax,7471 'multiply by 0.114 * 65536
!movzx edx,byte ptr [4*ecx+esi+1] 'get the G byte
!imul edx,edx,38470 'muliply by 0.587 * 65536
!movzx edi,byte ptr [4*ecx+esi+2] 'get the R byte
!imul edi,edi,19595 'muliply by 0.299 * 65536
!add eax,edx 'add the B and G results
!add eax,edi 'add in the R result
!mov edx,BgrB 'set the default colour ready for later
!cmp eax,BWtriggerScaled 'is the sum greater than the threshold?
!cmovl edx,BgrA 'no, choose the other colour for less than the threshold
!mov [4*ecx+esi],edx 'store the new colour
!dec ecx 'count down the loop
!jns short lp1 'if not negative, go back for the next pixel
End Function
http://www.garybeene.com/sw/gbsnippets.htm