 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
Caran
Anmeldungsdatum: 11.03.2007
Beiträge: 290
Wohnort: Lörrach
|
 Verfasst am: 25.05.2007, 14:33 Titel: "Auge" für Programme |
 |
|
Hallo zusammen,
ich bin grad dabei ein Programm zu schreiben, welches Gegenstände mit einer Webcam erkennen soll. Das daraus folgende Problem ist, wie kann ich Bilder von einer Webcam in das Programm bringen?
Das Bild sollte im Screen 18 erscheinen und jede halbe Sekunde erneuert werden.
Währe nett wenn mir jemand helfen könnte. |
|
| Nach oben |
|
 |
MisterD
Anmeldungsdatum: 10.09.2004
Beiträge: 3071
Wohnort: bei Darmstadt
|
| Verfasst am: 25.05.2007, 16:53 Titel: |
|
|
ich glaube nich dass dir hier jemand groß helfen kann, hier sind fast nur hobbyprogrammierer unterwegs und die binden normal keine webcam in ihre programme ein.. am besten fragst du mal google nach diversen video capture APIs oder sowas, da findest du glaub ich am ehesten was. ne anleitung wie's in FB direkt geht wirst du aber sicher nicht finden.
_________________
"It is practically impossible to teach good programming to students that have had a prior exposure to BASIC: as potential programmers they are mentally mutilated beyond hope of regeneration."
Edsger W. Dijkstra |
|
| Nach oben |
|
|
Mao
Anmeldungsdatum: 25.09.2005
Beiträge: 4409
Wohnort: /dev/hda1
|
| Verfasst am: 25.05.2007, 17:43 Titel: |
|
|
Uhm, doch. 
Aber ob die funktioniert, ist was anderes. Volta hat mal was passendes geschrieben, ist aber glaub ich nicht mehr kompatibel mit der 0.18, der 0.17 oder der 0.16. Einfach mal danach suchen.
_________________
Eine handvoll Glück reicht nie für zwei.
--
 |
|
| Nach oben |
|
|
robbifan
Anmeldungsdatum: 18.05.2007
Beiträge: 43
|
| Verfasst am: 25.05.2007, 18:02 Titel: |
|
|
http://forum.qbasic.at/viewtopic.php?t=3278&highlight=capture
hier im forum gibt es was.
läuft mit freebasic 0.16, einmal ein windowsfenster und einmal ein freebasicscreen, gut ausbaufähig.
les dir mal alles durch was da steht.
das erkennen von hindernissen ist ein anderes problem.
hier im englischen forum ist es auch gut beschrieben für den screenmodus. :
http://www.freebasic.net/forum/viewtopic.php?t=6113&highlight=capture
| Zitat: |
hier sind fast nur hobbyprogrammierer unterwegs und die binden normal keine webcam...
|
bei purebasic , bei vb usw sind auch nur hobbyprogrammierer, da geht es saftig rund mit der webcam. du kannst doch mit freebasic nicht nur punkte setzen und linien ziehen mit draw...freebasic gibt in der grafik und kommunikation viel mehr her....als man denkt. |
|
| Nach oben |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192
|
| Verfasst am: 25.05.2007, 20:18 Titel: |
|
|
Hi,
das Prog ist mit kleinen Änderungen auch auf FB017b lauffähig.
Anmerkung: bei mir (ME) läuft das Programm nur wenn ich mindestens einmal vorher die Webcam-Software starte, d.h. die Treiber initialisiere.
Sonst erkennt das Grab-Prog die Webcam nicht.
| Code: | ' Grab_Cam_pic.bas by Volta
' auf FB017b umgestellt und nur unter ME getestet
'
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
Byval As Zstring Ptr, Byval As Zstring Ptr) As Integer
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
Byval hwnd As Integer, Byval wMsg As Integer, _
Byval wParam As Integer, Byval lParam As Any Ptr) As Integer
Declare Sub CamCap_init
Declare Sub CamCap_off
#define CAP_BASE 1024
Enum CAP_MESSAGES
SET_CALLBACK_FRAME = CAP_BASE + 5
DRIVER_CONNECT = CAP_BASE + 10
DRIVER_DISCONNECT = CAP_BASE + 11
GET_VIDEOFORMAT = CAP_BASE + 44
SET_SCALE = CAP_BASE + 53
GET_STATUS = CAP_BASE + 54
GRAB_FRAME = CAP_BASE + 60
End Enum
#define Grab SendMessage(hCapture,GRAB_FRAME,0,0)
Type BITMAPINFOHEADER_t
As Integer biSize
As Integer biWidth
As Integer biHeight
As Short biPlanes
As Short biBitCount
As Integer biCompression
As Integer biSizeImage
As Integer biXPelsPerMeter
As Integer biYPelsPerMeter
As Integer biClrUsed
As Integer biClrImportant
End Type
Type RGB32 Field = 1
As Byte b,g,r,a
End Type
Type VIDEOHDR
As Byte Ptr lpData
As Uinteger BufferSize
As Uinteger BytesUsed
As Uinteger TimeCaptured
As Integer Ptr lpUserData
As Uinteger Flag
As Integer Ptr Reserved(0 To 3)
End Type
Type CreateCaptureWindow_t As Function ( _
Byval title As Zstring Ptr, Byval flag As Integer, _
Byval x As Integer, Byval y As Integer, _
Byval w As Integer, Byval h As Integer, _
Byval hParent As Integer, Byval id As Integer) As Integer
Dim Shared As CreateCaptureWindow_t CreateCaptureWindow
Dim Shared As Integer ptr hDLL
Dim Shared As Integer cam_breite, cam_hoehe, CamPosX=1, CamPosY=1, hCapture
Dim Shared As Integer Ptr cap_image
Function GRAB_FRAME2Image(Byval hWin As Integer, Byval lpHeader As VIDEOHDR Ptr) As Integer
Dim As Integer picsize, zeile, x, y, j
Dim As RGB32 Ptr lpScreen
picsize = lpHeader->BytesUsed\3
If picsize = cam_breite * cam_hoehe Then
zeile = cam_breite * (cam_hoehe-1)
lpScreen = Cptr(RGB32 Ptr,(cap_image))+8
For y = 0 To cam_hoehe-1
For x = 0 To cam_breite-1
lpScreen[zeile+x].b = lpHeader->lpData[j]
lpScreen[zeile+x].g = lpHeader->lpData[j+1]
lpScreen[zeile+x].r = lpHeader->lpData[j+2]
j+ = 3
Next
zeile -= cam_breite
Next
Screenlock
Put (CamPosX,CamPosY),cap_image,Pset
Screenunlock
End If
Return 1
End Function
Sub CamCap_init
Dim As BITMAPINFOHEADER_t biheader
hDll = Dylibload("avicap32")
If hDll<>0 Then
CreateCaptureWindow = Dylibsymbol(hDLL, "capCreateCaptureWindowA")
Else
? "error: can't load avicap32.dll !"
Sleep:End 1
End If
hCapture = CreateCaptureWindow("Voltas Grab_Cam_Picture", &H40000000, 0, 0, 0, 0, FindWindow(0, 0), 0)
If hCapture = 0 Then
? "error: cant create capture window !"
CamCap_off
Sleep:End 1
End If
If SendMessage(hCapture, DRIVER_CONNECT, 0, 0) <> 1 Then
? "error: cant connect the driver !"
CamCap_off
Sleep:End 1
End If
SendMessage(hCapture, SET_SCALE, 1, 0)
SendMessage(hCapture, GET_VIDEOFORMAT, Sizeof(BITMAPINFOHEADER_t), @biHeader)
If (biHeader.biCompression <> 0) Then
?"error: sorry this example needs RGB !"
CamCap_off
Sleep:End 1
End If
cam_breite = biHeader.biWidth
cam_hoehe = biHeader.biHeight
cap_image = imagecreate(cam_breite,cam_hoehe,32)
SendMessage(hCapture,SET_CALLBACK_FRAME,0, @GRAB_FRAME2Image)
'Grab
End Sub
Sub CamCap_off
SendMessage(hCapture,DRIVER_DISCONNECT ,0,0)
If hDLL<>0 Then Dylibfree(hDll)
If cap_image<>0 Then Imagedestroy cap_image
End Sub
' main
Dim ik As String
Screen 18,32
CamPosX=10
CamPosY=50
CamCap_init
Do
Locate 1,20 : ? Time
Grab
Sleep 10 '500
Ik = Inkey
Loop Until Ik = Chr(3) or Ik = Chr(27) or Ik = Chr(255,107)
CamCap_off
End
|
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater. |
|
| Nach oben |
|
|
Caran
Anmeldungsdatum: 11.03.2007
Beiträge: 290
Wohnort: Lörrach
|
| Verfasst am: 26.05.2007, 09:40 Titel: |
|
|
Hey,
danke an alle für die schnellen Antworten.
@MisterD:
Eigentlich bin ich ja auch nur Hobbyprogrammierer (seit 3/4 Jahr) 
@volta:
Nochmal besonderes Danke für den Code |
|
| Nach oben |
|
|
robbifan
Anmeldungsdatum: 18.05.2007
Beiträge: 43
|
| Verfasst am: 26.05.2007, 09:49 Titel: |
|
|
hallo volta, dann könntest du doch auch mal das programm ändern für die zwischenablage welches mal von dir vorgestellt wurde im zusammenhang mit videocapture, das funktioniert auch nicht mehr seit 0.17
danke.
mfg
| Code: |
'' Clipboard functions
Option Explicit
'' Clipboard functions for Win32
''
''
'' Copyright Eric Cowles, August 2006
''
''
'' You have the right to:
''
'' Use and abuse. Just let me know and give me credit where it's due if you
'' do :)
''
''
'' Credit where it's due:
''
'' FreeBASIC, FB Dev team (too many to list individually) - mostly to v1ctor
''
'' fb.net forums, for the topics involving clipboard access and people
'' wanting access to the systems clipboards.
''
'' rdc on fb.net, for starting the whole clipboard thread.
''
'' coderJeff on fb.net, for providing examples of accessing the windows
'' clipboard for text.
''
'' KPD-Team, for API-Guide.
''
''
'' Description:
''
'' Just add this module into your project and include the include file into
'' any module which wants to access the clipboard and you have a seemless
'' clipboard API under all three OSs.
''
''
'' Functions:
''
''
'' Clip_Init
''
'' Initializes any connections or memory required to the OSs clipboard
'' API.
''
'' Returns True on success and False on failure.
''
''
'' Clip_Denit
''
'' Does the opposite of Clip_Init and closes any connections and frees
'' memory required by the OSs clipboard API.
''
'' Returns True on success and False on failure.
''
''
'' Clip_Empty
''
'' Empties the clipboard.
''
'' Returns True on success and False on failure.
''
''
'' Clip_Content_Enum
''
'' Enumerates what the contents of the clipboard is, if any.
''
'' Returns a value from Clip_Content_Type.
''
''
'' Clip_Copy_###_To
''
'' Copies data to the clipboard of the specified format.
''
'' Returns True on success and False on failure.
''
''
'' Clip_Copy_###_From
''
'' Copies data from the clipboard of the specified format.
''
'' Returns the specified data type. If the return value is NULL then
'' either no data was available to copy, the data available was of the
'' wrong type (see Clip_Content_Enum) or there was an error accessing the
'' clipboard.
''
''
'' Notes:
''
'' If you don't need the graphics functionality (because you are not using
'' gfxlib) then remark line 109 including the graphics include. This will
'' tell the rest of the source not to include the code to handle graphics.
''
''
'' DO NOT USE #include TO ADD THE MODULE (.bas) TO YOUR PROJECT! ONLY
'' #include THE INCLUDE FILE (.bi). COMPILE THE MODULE BY ADDING IT TO THE
'' LIST OF MODULES FOR YOUR PROJECT IN THE APPROPRIATE MANNER. I WILL NOT
'' HELP PEOPLE WHO #include THE MODULE INTO THIER MAIN SOURCE FILE. IF YOU
'' NEED HELP COMPILING MULTIPLE MODULES AT ONCE, THE MANUAL IS RIGHT HERE:
''
'' http://www.freebasic.net/wiki/wikka.php?wakka=CompileCmdLine
#Include Once "windows.bi"
#Include Once "fbgfx.bi"
#IfNDef FALSE
#Define FALSE 0
#EndIf
#IfNDef TRUE
#Define TRUE ( NOT FALSE )
#EndIf
#IfNDef NULL
#Define NULL 0
#EndIf
Enum Clip_Content_Type
ccNone
ccText
ccDIB
End Enum
#IfDef __fbgfx_bi__
Type gfxBuffer
As Short BytesPerPixel:3, Width:13, Height
Union
As Ubyte Pixel8
As Ushort Pixel16
As Uinteger Pixel32
End Union
End Type
#EndIf
Declare Function Clip_Init () As Uinteger
Declare Function Clip_Denit () As Uinteger
Declare Function Clip_Empty () As Uinteger
Declare Function Clip_Content_Enum () As Uinteger
Declare Function Clip_Copy_Str_To ( Text As String ) As Uinteger
Declare Function Clip_Copy_Str_From () As String
#IfDef __fbgfx_bi__
Declare Function Clip_Copy_Gfx_To ( Byval Buffer As gfxBuffer Ptr ) As Uinteger
Declare Function Clip_Copy_Gfx_From () As gfxBuffer Ptr
Type Clip_DIB_Header Field = 1
As Uinteger Size
As Integer Width
As Integer Height
As Ushort Planes
As Ushort Bits
As Uinteger Compression
As Uinteger ImageSize
As Integer xResolution
As Integer yResolution
As Uinteger nColours
As Uinteger ImportantColours
End Type
#Define pDIB Clip_DIB_Header Ptr
#Define pRGBQ Uinteger Ptr
#Define pGFX gfxBuffer Ptr
Private Sub Pal_To_8 ( Byval Pal As pRGBQ, Byval Bits As Integer )
Dim As Integer Index
For Index = 0 To ( 1 Shl Bits ) - 1
Pal[ Index ] = _
( ( Pal[ Index ] And &H00F80000 ) Shr 18 ) Or _
( ( Pal[ Index ] And &H0000F800 ) Shr 2 ) Or _
( ( Pal[ Index ] And &H000000F8 ) Shl 14 )
Next
Palette Using Pal
End Sub
Private Sub Pal_To_16 ( Byval Pal As pRGBQ, Byval Bits As Integer )
Dim As Integer Index
For Index = 0 To ( 1 Shl Bits ) - 1
Pal[ Index ] = _
( ( Pal[ Index ] And &H00F80000 ) Shr 8 ) Or _
( ( Pal[ Index ] And &H0000FC00 ) Shr 5 ) Or _
( ( Pal[ Index ] And &H000000F8 ) Shr 2 )
Next
End Sub
Private Sub Pal_To_32 ( Byval Pal As pRGBQ, Byval Bits As Integer )
End Sub
Private Sub Bits_1_To_8 ( Byval Dst As Ubyte Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 ) Step 8
Dst[ dI ] = ( Src[ sI ] And &B10000000 ) Shr 7
Dst[ dI + 1 ] = ( Src[ sI ] And &B01000000 ) Shr 6
Dst[ dI + 2 ] = ( Src[ sI ] And &B00100000 ) Shr 5
Dst[ dI + 3 ] = ( Src[ sI ] And &B00010000 ) Shr 4
Dst[ dI + 4 ] = ( Src[ sI ] And &B00001000 ) Shr 3
Dst[ dI + 5 ] = ( Src[ sI ] And &B00000100 ) Shr 2
Dst[ dI + 6 ] = ( Src[ sI ] And &B00000010 ) Shr 1
Dst[ dI + 7 ] = ( Src[ sI ] And &B00000001 )
dI += 8
sI += 1
Next
End Sub
Private Sub Bits_1_To_16 ( Byval Dst As Ushort Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 ) Step 8
Dst[ dI ] = Pal[ ( Src[ sI ] And &B10000000 ) Shr 7 ]
Dst[ dI + 1 ] = Pal[ ( Src[ sI ] And &B01000000 ) Shr 6 ]
Dst[ dI + 2 ] = Pal[ ( Src[ sI ] And &B00100000 ) Shr 5 ]
Dst[ dI + 3 ] = Pal[ ( Src[ sI ] And &B00010000 ) Shr 4 ]
Dst[ dI + 4 ] = Pal[ ( Src[ sI ] And &B00001000 ) Shr 3 ]
Dst[ dI + 5 ] = Pal[ ( Src[ sI ] And &B00000100 ) Shr 2 ]
Dst[ dI + 6 ] = Pal[ ( Src[ sI ] And &B00000010 ) Shr 1 ]
Dst[ dI + 7 ] = Pal[ ( Src[ sI ] And &B00000001 ) ]
dI += 8
sI += 1
Next
End Sub
Private Sub Bits_1_To_32 ( Byval Dst As Uinteger Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 ) Step 8
Dst[ dI ] = Pal[ ( Src[ sI ] And &B10000000 ) Shr 7 ]
Dst[ dI + 1 ] = Pal[ ( Src[ sI ] And &B01000000 ) Shr 6 ]
Dst[ dI + 2 ] = Pal[ ( Src[ sI ] And &B00100000 ) Shr 5 ]
Dst[ dI + 3 ] = Pal[ ( Src[ sI ] And &B00010000 ) Shr 4 ]
Dst[ dI + 4 ] = Pal[ ( Src[ sI ] And &B00001000 ) Shr 3 ]
Dst[ dI + 5 ] = Pal[ ( Src[ sI ] And &B00000100 ) Shr 2 ]
Dst[ dI + 6 ] = Pal[ ( Src[ sI ] And &B00000010 ) Shr 1 ]
Dst[ dI + 7 ] = Pal[ ( Src[ sI ] And &B00000001 ) ]
dI += 8
sI += 1
Next
End Sub
Private Sub Bits_4_To_8 ( Byval Dst As Ubyte Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 ) Step 2
Dst[ dI ] = ( Src[ sI ] And &B11110000 ) Shr 4
Dst[ dI + 1 ] = ( Src[ sI ] And &B00001111 )
dI += 2
sI += 1
Next
End Sub
Private Sub Bits_4_To_16 ( Byval Dst As Ushort Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 ) Step 2
Dst[ dI ] = Pal[ ( Src[ sI ] And &B11110000 ) Shr 4 ]
Dst[ dI + 1 ] = Pal[ ( Src[ sI ] And &B00001111 ) ]
dI += 2
sI += 1
Next
End Sub
Private Sub Bits_4_To_32 ( Byval Dst As Uinteger Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 ) Step 2
Dst[ dI ] = Pal[ ( Src[ sI ] And &B11110000 ) Shr 4 ]
Dst[ dI + 1 ] = Pal[ ( Src[ sI ] And &B00001111 ) ]
dI += 2
sI += 1
Next
End Sub
Private Sub Bits_8_To_8 ( Byval Dst As Ubyte Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
CopyMemory( Dst, Src, Pixels )
End Sub
Private Sub Bits_8_To_16 ( Byval Dst As Ushort Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 )
Dst[ dI ] = Pal[ Src[ sI ] ]
dI += 1
sI += 1
Next
End Sub
Private Sub Bits_8_To_32 ( Byval Dst As Uinteger Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, sI, dI
sI = 0
dI = 0
For Index = 0 To ( Pixels - 1 )
Dst[ dI ] = Pal[ Src[ sI ] ]
dI += 1
sI += 1
Next
End Sub
Private Sub Bits_24_To_8 ( Byval Dst As Ubyte Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
End Sub
Private Sub Bits_24_To_16 ( Byval Dst As Ushort Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, dI
dI = 0
For Index = 0 To ( Pixels - 1 )
Dst[ dI ] = _
( ( *Cptr( Uinteger Ptr, Src ) And &H00F80000 ) Shr 8 ) Or _
( ( *Cptr( Uinteger Ptr, Src ) And &H0000FC00 ) Shr 5 ) Or _
( ( *Cptr( Uinteger Ptr, Src ) And &H000000F8 ) Shr 2 )
dI += 1
Src += 3
Next
End Sub
Private Sub Bits_24_To_32 ( Byval Dst As Uinteger Ptr, Byval Src As Ubyte Ptr, Byval Pal As pRGBQ, Byval Pixels As Integer )
Dim As Integer Index, dI
dI = 0
For Index = 0 To ( Pixels - 1 )
Dst[ dI ] = ( *Cptr( Uinteger Ptr, Src ) And &H00FFFFFF )
dI += 1
Src += 3
Next
End Sub
Private Function Buffer_To_DIB ( Byref Bytes As Integer, Byval Buffer As gfxBuffer Ptr ) As Any Ptr
Dim As pDIB DIB = NULL
Dim As pRGBQ Pal = NULL
Dim As Integer Index, X, Y, S, Pitch, Offset
Dim As Any Ptr sS, dS
Select Case Buffer->BytesPerPixel
Case 1 : Pitch = Buffer->Width
Case 2 : Pitch = Buffer->Width * 3
Case 4 : Pitch = Buffer->Width * 3
End Select
If ( Pitch And 3 ) Then Pitch = ( Pitch And ( Not 3 ) ) + 4
Offset = Sizeof( Clip_DIB_Header )
If ( Buffer->BytesPerPixel = 1 ) Then Offset += 1024
Bytes = Offset + ( Pitch * Buffer->Height )
If ( Bytes And 1023 ) Then Bytes = ( Bytes And ( Not 1023 ) ) + 1024
DIB = Callocate( Bytes )
If ( DIB ) Then
DIB->Size = Sizeof( Clip_DIB_Header )
DIB->Width = Buffer->Width
DIB->Height = Buffer->Height
DIB->Planes = 1
If ( Buffer->BytesPerPixel = 1 ) Then
DIB->Bits = 8
Else
DIB->Bits = 24
End If
Select Case Buffer->BytesPerPixel
Case 1
Cptr( Ubyte Ptr, Pal ) = Cptr( Ubyte Ptr, DIB ) + Sizeof( Clip_DIB_Header )
Palette Get Using Pal
For Index = 0 To 255
Pal[ Index ] = _
( ( Pal[ Index ] And &H003F0000 ) Shr 14 ) Or _
( ( Pal[ Index ] And &H00003F00 ) Shl 2 ) Or _
( ( Pal[ Index ] And &H0000003F ) Shl 18 )
Next
S = ( Buffer->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
dS = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
sS = @Buffer->Pixel8 + ( Y * Buffer->Width )
CopyMemory( dS, sS, Buffer->Width )
S -= 1
Next
Case 2
S = ( Buffer->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
dS = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
sS = @Buffer->Pixel16 + ( Y * Buffer->Width )
For X = 0 To ( Buffer->Width - 1 )
*Cptr( Uinteger Ptr, dS ) = _
( ( *Cptr( Ushort Ptr, sS ) And &HF800 ) Shl 8 ) Or _
( ( *Cptr( Ushort Ptr, sS ) And &H07E0 ) Shl 5 ) Or _
( ( *Cptr( Ushort Ptr, sS ) And &H001F ) Shl 3 )
sS += 2
dS += 3
Next
S -= 1
Next
Case 4
S = ( Buffer->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
dS = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
sS = @Buffer->Pixel32 + ( Y * Buffer->Width )
For X = 0 To ( Buffer->Width - 1 )
*Cptr( Uinteger Ptr, dS ) = ( *Cptr( Uinteger Ptr, sS ) And &H00FFFFFF )
sS += 4
dS += 3
Next
S -= 1
Next
End Select
End If
Return DIB
End Function
Private Function DIB_To_Buffer ( Byval DIB As pDIB ) As gfxBuffer Ptr
Dim As pGFX Buffer = NULL
Dim As pRGBQ Pal = NULL
Dim As Integer Index, X, Y, S, Pitch, Offset
Dim As Any Ptr sS, dS
If ( DIB->Planes = 1 ) Then
Buffer = ImageCreate( DIB->Width, DIB->Height )
If ( Buffer ) Then
Offset = Sizeof( Clip_DIB_Header )
Select Case DIB->Bits
Case 1
Pitch = DIB->Width Shr 3
Offset += Sizeof( Uinteger ) Shl 1
Case 4
Pitch = DIB->Width Shr 1
Offset += Sizeof( Uinteger ) Shl 4
Case 8
Pitch = DIB->Width
Offset += Sizeof( Uinteger ) Shl 8
Case 24
Pitch = DIB->Width Shl 1 + DIB->Width
End Select
If ( Pitch And 3 ) Then Pitch = ( Pitch And ( Not 3 ) ) + 4
Select Case DIB->Bits
Case 1
Cptr( Ubyte Ptr, Pal ) = Cptr( Ubyte Ptr, DIB ) + Sizeof( Clip_DIB_Header )
Select Case Buffer->BytesPerPixel
Case 1 '' 1->8
Pal_To_8( Pal, 1 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Ubyte Ptr, dS ) = @Buffer->Pixel8 + ( Y * DIB->Width )
Bits_1_To_8( dS, sS, Pal, DIB->Width )
S -= 1
Next
Case 2 '' 1->16
Pal_To_16( Pal, 1 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Ushort Ptr, dS ) = @Buffer->Pixel16 + ( Y * DIB->Width )
Bits_1_To_16( dS, sS, Pal, DIB->Width )
S -= 1
Next
Case 4 '' 1->32
Pal_To_32( Pal, 1 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Uinteger Ptr, dS ) = @Buffer->Pixel32 + ( Y * DIB->Width )
Bits_1_To_32( dS, sS, Pal, DIB->Width )
S -= 1
Next
End Select
Case 4
Cptr( Ubyte Ptr, Pal ) = Cptr( Ubyte Ptr, DIB ) + Sizeof( Clip_DIB_Header )
Select Case Buffer->BytesPerPixel
Case 1 '' 4->8
Pal_To_8( Pal, 4 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Ubyte Ptr, dS ) = @Buffer->Pixel8 + ( Y * DIB->Width )
Bits_4_To_8( dS, sS, Pal, DIB->Width )
S -= 1
Next
Case 2 '' 4->16
Pal_To_16( Pal, 4 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Ushort Ptr, dS ) = @Buffer->Pixel16 + ( Y * DIB->Width )
Bits_4_To_16( dS, sS, Pal, DIB->Width )
S -= 1
Next
Case 4 '' 4->32
Pal_To_32( Pal, 4 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Uinteger Ptr, dS ) = @Buffer->Pixel32 + ( Y * DIB->Width )
Bits_4_To_32( dS, sS, Pal, DIB->Width )
S -= 1
Next
End Select
Case 8
Cptr( Ubyte Ptr, Pal ) = Cptr( Ubyte Ptr, DIB ) + Sizeof( Clip_DIB_Header )
Select Case Buffer->BytesPerPixel
Case 1 '' 8->8
Pal_To_8( Pal, 8 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Ubyte Ptr, dS ) = @Buffer->Pixel8 + ( Y * DIB->Width )
Bits_8_To_8( dS, sS, Pal, DIB->Width )
S -= 1
Next
Case 2 '' 8->16
Pal_To_16( Pal, 8 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Ushort Ptr, dS ) = @Buffer->Pixel16 + ( Y * DIB->Width )
Bits_8_To_16( dS, sS, Pal, DIB->Width )
S -= 1
Next
Case 4 '' 8->32
Pal_To_32( Pal, 8 )
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Uinteger Ptr, dS ) = @Buffer->Pixel32 + ( Y * DIB->Width )
Bits_8_To_32( dS, sS, Pal, DIB->Width )
S -= 1
Next
End Select
Case 24
Select Case Buffer->BytesPerPixel
Case 1 '' 24->8
Deallocate( Buffer )
Buffer = NULL
Case 2 '' 24->16
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Ushort Ptr, dS ) = @Buffer->Pixel16 + ( Y * DIB->Width )
Bits_24_To_16( dS, sS, Pal, DIB->Width )
S -= 1
Next
Case 4 '' 24->32
S = ( DIB->Height - 1 )
For Y = 0 To ( Buffer->Height - 1 )
Cptr( Ubyte Ptr, sS ) = Cptr( Ubyte Ptr, DIB ) + Offset + ( S * Pitch )
Cptr( Uinteger Ptr, dS ) = @Buffer->Pixel32 + ( Y * DIB->Width )
Bits_24_To_32( dS, sS, Pal, DIB->Width )
S -= 1
Next
End Select
End Select
End If
End If
Return Buffer
End Function
#EndIf
Public Function Clip_Init () As Uinteger
Return TRUE
End Function
Public Function Clip_Denit () As Uinteger
Function = TRUE
End Function
Public Function Clip_Empty () As Uinteger
Function = FALSE
#IfDef __FB_WIN32__
If ( OpenClipboard( NULL ) ) Then
If ( EmptyClipboard() ) Then Function = TRUE
CloseClipboard
End If
#Endif
End Function
Public Function Clip_Content_Enum () As Uinteger
' Function = Clip_Content_Type.ccNone
Function = ccNone
#IfDef __FB_WIN32__
If ( OpenClipboard( NULL ) ) Then
If ( IsClipboardFormatAvailable( CF_TEXT ) ) Then
' Function = Clip_Content_Type.ccText
Function = ccText
#IfDef __fbgfx_bi__
Elseif ( IsClipboardFormatAvailable( CF_DIB ) ) Then
' Function = Clip_Content_Type.ccDIB
Function = ccDIB
#Endif
End If
CloseClipboard()
End If
#Endif
End Function
Public Function Clip_Copy_Str_To ( Text As String ) As Uinteger
Dim As Integer iClip = Len( Text )
Function = FALSE
#IfDef __FB_WIN32__
Dim As HANDLE hClip = NULL
Dim As Ubyte Ptr pClip = NULL
If ( iClip > 0 ) Then
hClip = GlobalAlloc( GMEM_MOVEABLE Or GMEM_DDESHARE, iClip + 1 )
If ( hClip ) Then
pClip = GlobalLock( hClip )
If ( pClip ) Then
CopyMemory( pClip, Strptr( Text ), iClip )
If ( OpenClipboard( NULL ) ) Then
If ( EmptyClipboard() ) Then
If ( SetClipboardData( CF_TEXT, hClip ) ) Then
Function = TRUE
End If
End If
CloseClipboard()
End If
GlobalUnlock( hClip )
End If
End If
End If
If ( hClip ) Then GlobalFree( hClip )
#Endif
End Function
Public Function Clip_Copy_Str_From () As String
Function = ""
#IfDef __FB_WIN32__
Dim As HANDLE hClip
Dim As Zstring Ptr pClip
If ( IsClipboardFormatAvailable( CF_TEXT ) ) Then
If ( OpenClipboard( NULL ) ) Then
hClip = GetClipboardData( CF_TEXT )
If ( hClip ) Then
pClip = GlobalLock( hClip )
If ( pClip ) Then
Function = *pClip
GlobalUnlock( hClip )
End If
End If
CloseClipboard()
End If
End If
#Endif
End Function
#IfDef __fbgfx_bi__
Public Function Clip_Copy_Gfx_To ( Byval Buffer As gfxBuffer Ptr ) As Uinteger
Dim As Any Ptr DIB
Dim As Integer iClip
Function = FALSE
DIB = Buffer_To_DIB( iClip, Buffer )
#IfDef __FB_WIN32__
Dim As HANDLE hClip = NULL
Dim As Ubyte Ptr pClip = NULL
If ( iClip > 0 ) Then
hClip = GlobalAlloc( GMEM_MOVEABLE Or GMEM_DDESHARE, iClip + 1 )
If ( hClip ) Then
pClip = GlobalLock( hClip )
If ( pClip ) Then
CopyMemory( pClip, DIB, iClip )
If ( OpenClipboard( NULL ) ) Then
If ( EmptyClipboard() ) Then
If ( SetClipboardData( CF_DIB, hClip ) ) Then
Function = TRUE
End If
End If
CloseClipboard()
End If
GlobalUnlock( hClip )
End If
End If
End If
If ( hClip ) Then GlobalFree( hClip )
#Endif
Deallocate( DIB )
End Function
#EndIf
#IfDef __fbgfx_bi__
Public Function Clip_Copy_Gfx_From () As gfxBuffer Ptr
Function = NULL
#IfDef __FB_WIN32__
Dim As HANDLE hClip
Dim As Any Ptr pClip
If ( IsClipboardFormatAvailable( CF_DIB ) ) Then
If ( OpenClipboard( NULL ) ) Then
hClip = GetClipboardData( CF_DIB )
If ( hClip ) Then
pClip = GlobalLock( hClip )
If ( pClip ) Then
Function = DIB_To_Buffer( pClip )
GlobalUnlock( hClip )
End If
End If
CloseClipboard()
End If
End If
#Endif
End Function
#EndIf
|
|
|
| Nach oben |
|
|
robbifan
Anmeldungsdatum: 18.05.2007
Beiträge: 43
|
| Verfasst am: 26.05.2007, 10:18 Titel: |
|
|
| läuft 100%tig auf xp bei mir das geänderte videocapture mit 0.17 ohne die camsoftware vorher einmal zu starten. |
|
| Nach oben |
|
|
Caran
Anmeldungsdatum: 11.03.2007
Beiträge: 290
Wohnort: Lörrach
|
| Verfasst am: 26.05.2007, 15:37 Titel: |
|
|
Hi,
da ich erst jetzt dazu gekommen bin, dass mal auszuprobieren melde ich ich relativ spät:
Wenn ich das von Volta geschriebene Programm starte, steht "error: sorry this example needs RGB !" auf dem screen. Liegt das jetzt an meiner Webcam oder wie?
Grüße |
|
| Nach oben |
|
|
csde_rats
Anmeldungsdatum: 07.01.2007
Beiträge: 2292
Wohnort: Zwischen Sessel und Tastatur
|
| Verfasst am: 26.05.2007, 18:33 Titel: |
|
|
| robbifan hat Folgendes geschrieben: | | läuft 100%tig auf xp bei mir das geänderte videocapture mit 0.17 ohne die camsoftware vorher einmal zu starten. |
Möchte auch erwähnen, dass es bei mir mit 0.18 (zwei-stunden-aktuell) auch einwandfrei läuft 
_________________
If hilfreicher_Beitrag then klick(location.here)
Klick |
|
| Nach oben |
|
|
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192
|
| Verfasst am: 26.05.2007, 19:23 Titel: |
|
|
Hi Caran,
ja, das liegt am Bildformat welches die Webcam liefert.
Schau mal in den Einstellungen der Webcam ob du sie auch auf 'RGB' umstellen kannst (sollte möglich sein).
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater. |
|
| Nach oben |
|
|
dreael
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 2529
Wohnort: Hofen SH (Schweiz)
|
| Verfasst am: 26.05.2007, 20:03 Titel: |
|
|
Das im Titel genannte Problem lässt sich in folgende zwei Teilprobleme zerlegen:
1.) Auslesen der Kamerabilddaten (Diskussion gemäss den geposteten Codebeispielen bereits in Gang) - reine Frage des richtigen Windows-API
2.) Bildverarbeitung im Sinn einer grafischen Datenverarbeitung (hatte ich während meines Studiums als Fach seinerzeit übrigens): Hier geht es zentral um jenes Knowhow, welches in den Effektfiltern von Bildprogrammen wie Adobe Photoshop drinsteckt. Schliesslich müssen noch bestimmte Muster ausgewertet werden, damit beispielsweise die Fliessbandweiche in der Industrie-Fertigungsstrasse jene Säckchen mit unvollständigem Inhalt aussortieren kann.
_________________
Teste die PC-Sicherheit mit www.sec-check.net |
|
| Nach oben |
|
|
Caran
Anmeldungsdatum: 11.03.2007
Beiträge: 290
Wohnort: Lörrach
|
| Verfasst am: 27.05.2007, 09:41 Titel: |
|
|
Hey Leute,
@dreael:
Eigentlich ist das zweite ja kein großes Problem, das hab ich schon mit Bitmaps ausprobiert.
@Volta:
Ja jetzt geht das mit der Webcam auch, danke für die Auskunft.
MfG Caran |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
