XProfan

Kompilieren Markieren Separieren

« Dieser Beitrag wurde als Lösung gekennzeichnet. »

p.specht

RESTAURIERT und für XProfan11.2a adaptiert.
Version R0.2ß - Bitte vorsichtig testen:
==============================

'##################################################
'Video-Capture mit Profan ab Profan-Version 7
'ist aber mit Bereichsvariablen leicht an vorherige
'Versionen anpassbar !
'Alle Funktionen mit Callbacks sind bisher nicht
'verwendbar (habe ich gleich weggelassen ) !
'Das sind vor allem Fehlermeldungen und auch
'die Statusanzeigen.
'##################################################
'Andreas Miethe * Februar 2002
'##################################################
'Definitionen
DEF capCreateCaptureWindow(8) ! "avicap32.dll","capCreateCaptureWindowA"
DEF capGetDriverDescription(5) ! "avicap32.dll","capGetDriverDescriptionA"
DEF GetButtonFaceColor(0) External("User32","GetSysColor",15)
DEF SetWindowLong(3) ! "USER32","SetWindowLongA"
Def GetStockObject(1) !"GDI32","GetStockObject"
Def SetDefaultGUIFont(1) SendMessage(&(1),$30,Val(GetStockObject($11)),1)
Def HiWord(1) &(1)\$10000
Def LoWord(1) &(1) & $FFFF
Def LockWindowUpdate(1) ! "User32","LockWindowUpdate"
'Konstanten
Def &WM_Capstart 1024
Def &WM_CAP_DRIVER_CONNECT 1034
Def &WM_CAP_DRIVER_DISCONNECT 1035
Def &WM_CAP_DRIVER_GET_NAME 1036
Def &WM_CAP_DRIVER_GET_VERSION 1037
Def &WM_CAP_FILE_SET_CAPTURE_FILE 1044
Def &WM_CAP_FILE_GET_CAPTURE_FILE 1045
Def &WM_CAP_FILE_SAVEAS 1047
Def &WM_CAP_FILE_SAVEDIB 1049
Def &WM_CAP_SET_AUDIOFORMAT 1059
Def &WM_CAP_GET_AUDIOFORMAT 1060
Def &WM_CAP_DLG_VIDEOFORMAT 1065
Def &WM_CAP_DLG_VIDEOSOURCE 1066
Def &WM_CAP_DLG_VIDEODISPLAY 1067
Def &WM_CAP_GET_VIDEOFORMAT 1068
Def &WM_CAP_SET_VIDEOFORMAT 1069
Def &WM_CAP_DLG_VIDEOCOMPRESSION 1070
Def &WM_CAP_SET_PREVIEW 1074
Def &WM_CAP_SET_OVERLAY 1075
Def &WM_CAP_SET_PREVIEWRATE 1076
Def &WM_CAP_SET_SCALE 1077
Def &WM_CAP_SET_SCROLL 1079
Def &WM_CAP_GRAB_FRAME 1084
Def &WM_CAP_GRAB_FRAME_NOSTOP 1085
Def &WM_CAP_SEQUENCE 1086
Def &WM_CAP_SEQUENCE_NOFILE 1087
Def &WM_CAP_SET_SEQUENCE_SETUP 1088
Def &WM_CAP_GET_SEQUENCE_SETUP 1089
Def &WM_CAP_SET_MCI_DEVICE 1090
Def &WM_CAP_GET_MCI_DEVICE 1091
Def &WM_CAP_STOP 1092
Def &WM_CAP_ABORT 1093
'Strukturen
Struct WaveFormatEx = wFormatTag%,nChannels%,nSamplesPerSec&,nAvgBytesPerSec&,\
nBlockAlign%,wBitsPerSample%,cbSize%
'globale Variablen
Declare CapDll&,MM&,CapWindow&,CapBMPFilename$,CapAVIFilename$
Declare DriverChoice&,OverlayButton&,CapBMPButton&
Declare VideoFormatText&
Declare SourceDialogButton&,FormatDialogButton&,KompressionDialogButton&
Declare SingleNameEdit&,AVINameEdit&
Declare StartCapButton&,StopCapButton&,EndeButton&
Declare Ende%,IsOverlay%
Declare AudioChoice&,Waveformat#,BM#
Declare T$
'Prozeduren

Proc CapInit

    CapDll& = UseDll("avicap32.dll")

EndProc

Proc CapExit

    FreeDll CapDll&

EndProc

Proc GetCaptureDriverList

    Declare Treiber$,Version$,Zaehler%
    ClearList

    Whilenot zaehler% = 9'reicht fuer 10 Treiber

        Treiber$ = Space$(80)'80 Zeichen werden maximal aufgenommen
        Version$ = Space$(80)'80 Zeichen werden maximal aufgenommen

        If capGetDriverDescription(Zaehler%,ADDR(Treiber$),80,ADDR(Version$),80) > 0

            AddString Trim$(Treiber$)

        Endif

        Inc Zaehler%

    EndWhile

EndProc

Proc CreateCapWindow

    Parameters x%,y%,w%,h%
    CapWindow& = 0
    CapWindow& = capCreateCaptureWindow(0,$50000000,0,0,0,0,%Hwnd,0)

    Whilenot CapWindow& > 0

    wend

    SetWindowLong(CapWindow&,-20,$200)
    SetWindowPos CapWindow& = x%,y% - w%,h%

EndProc

Proc ConnectDriver

    Parameters DriverIndex%
    Return Sendmessage(CapWindow&,1034,DriverIndex%,0)

EndProc

Proc DisconnectDriver

    Return Sendmessage(CapWindow&,&WM_CAP_DRIVER_DISCONNECT,0,0)

EndProc

Proc SetOverlay

    Parameters True%
    Return Sendmessage(CapWindow&,&WM_CAP_SET_OVERLAY,True%,0)

EndProc

Proc SetPreviev

    Parameters True%,Rate%,Scale%
    Sendmessage(CapWindow&,&WM_CAP_SET_PREVIEW,True%,0)
    Sendmessage(CapWindow&,&WM_CAP_SET_PREVIEWRATE,Rate%,0)
    Sendmessage(CapWindow&,&WM_CAP_SET_SCALE,Scale%,0)

EndProc

Proc GetVideoFormat

    Declare Ret$
    Dim BM#,44
    Clear BM#
    Sendmessage(CapWindow&,&WM_CAP_GET_VIDEOFORMAT,44,BM#)
    Ret$ = Str$(word(bm#,4))+","+Str$(word(bm#,8))
    Dispose BM#
    Return Ret$

EndProc

Proc CapSaveas

    Parameters Savename$
    Sendmessage(CapWindow&,&WM_CAP_FILE_SAVEAS,0,ADDR(Savename$))

EndProc

Proc SaveAsBMP

    Parameters Filename$
    Sendmessage(CapWindow&,&WM_CAP_FILE_SAVEDIB,0,ADDR(Filename$))

EndProc

Proc GrabFrame

    Parameters Filename$
    Sendmessage(CapWindow&,&WM_CAP_GRAB_FRAME_NOSTOP,0,0)
    SaveAsBMP Filename$

EndProc

Proc CapStart

    Parameters Filename$
    Sendmessage(CapWindow&,&WM_CAP_FILE_SET_CAPTURE_FILE,0,addr(filename$))
    Sendmessage(CapWindow&,&WM_CAP_SEQUENCE,0,0)

EndProc

Proc CapStop

    Sendmessage(CapWindow&,&WM_CAP_STOP,0,0)

EndProc

Proc CapAbort

    Sendmessage(CapWindow&,&WM_CAP_ABORT,0,0)

EndProc

Proc VideoSourceDialog

    Sendmessage(CapWindow&,1066,0,0)

EndProc

Proc VideoFormatDialog

    Sendmessage(CapWindow&,1065,0,0)

EndProc

Proc VideoDisplayDialog

    Sendmessage(CapWindow&,1067,0,0)

EndProc

Proc VideoKompressionDialog

    Sendmessage(CapWindow&,1070,0,0)

EndProc

Proc SetWaveFormat

    Parameters Stereo%,Bits%,Samples%
    Declare GetSize&
    Dim WaveFormat#,WaveFormatEx
    GetSize& = Sendmessage(CapWindow&,1060,0,0)
    Sendmessage(CapWindow&,1060,GetSize&,WaveFormat#)

    if WaveFormat#.wFormatTag% = 1

        Case Stereo% = 0 : WaveFormat#.nChannels% = 1
        Case Stereo% = 1 : WaveFormat#.nChannels% = 2
        WaveFormat#.nSamplesPerSec& = Samples%
        Case Bits% = 8 :WaveFormat#.wBitsPerSample% = 8
        Case Bits% = 16 :WaveFormat#.wBitsPerSample% = 16
        WaveFormat#.nBlockAlign% = (WaveFormat#.nChannels% * WaveFormat#.wBitsPerSample%) / 8
        WaveFormat#.nAvgBytesPerSec& = (WaveFormat#.nSamplesPerSec& * WaveFormat#.nBlockAlign%)
        Sendmessage(CapWindow&,1059,GetSize&,WaveFormat#)

    endif

    Dispose WaveFormat#

EndProc

Set("TrueColor", 1)
CLS GetButtonFaceColor(0)
'Voreinstellungen
'#################
CapInit
GetCaptureDriverList
DriverChoice& =  @Control("ComboBox","",$54000043,0,300,320,80,%hwnd,1000,%Hinstance)
SetDefaultGUIFont(DriverChoice&)
MoveListToChoice(DriverChoice&)
AudioChoice& =  @Control("ComboBox","",$54000242,0,330,320,300,%hwnd,1001,%Hinstance)
SetDefaultGUIFont(AudioChoice&)
SendMessage(DriverChoice&,$014E,0,0)'Auf 1. Eintrag setzen
OverlayButton& = @Create("Button",%Hwnd,"Preview",340,0,120,24)
SetDefaultGUIFont(OverlayButton&)
CapBMPButton& = @Create("Button",%Hwnd,"Einzelbild fangen",340,30,120,24)
SetDefaultGUIFont(CapBMPButton&)
SourceDialogButton& = @Create("Button",%Hwnd,"Video-Source",340,60,120,24)
SetDefaultGUIFont(SourceDialogButton&)
FormatDialogButton& = @Create("Button",%Hwnd,"Video-Format",340,90,120,24)
SetDefaultGUIFont(FormatDialogButton&)
KompressionDialogButton& = @Create("Button",%Hwnd,"Video-Kompression",340,120,120,24)
SetDefaultGUIFont(KompressionDialogButton&)
SingleNameEdit& = @Create("Edit",%Hwnd,"Noname.bmp",480,30,120,24)
SetDefaultGUIFont(SingleNameEdit&)
StartCapButton& = @Create("Button",%Hwnd,"Starte-Capture",340,150,120,24)
SetDefaultGUIFont(StartCapButton&)
AVINameEdit& = @Create("Edit",%Hwnd,"Noname.avi",480,150,120,24)
SetDefaultGUIFont(AVINameEdit&)
StopCapButton& = @Create("Button",%Hwnd,"Stop-Capture",340,180,120,24)
SetDefaultGUIFont(StopCapButton&)
EndeButton& = @Create("Button",%Hwnd,"Ende",340,210,120,24)
SetDefaultGUIFont(EndeButton&)
UseCursor 2
CreateCapWindow 0,40,320,240'Capture-Fenster anlegen
ConnectDriver 0'ersten Eintrag wählen
SetOverlay 1'Overlay-Modus einschalten
IsOverlay% = 1
UseCursor 0
VideoFormatText& = \
@Control("Static","",$54001001,0,0,320,20,%hwnd,1000,%Hinstance,0)
SetDefaultGUIFont(VideoFormatText&)
'GetVideoFormatVideo-Format auslesen
SetText VideoFormatText&, "Video-Format : "+\
Substr$(@$(0),1,",")+" x "+Substr$(@$(0),2,",")+"Pixel"
T$ =" Mono - 8Bit - 8.000 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Mono - 8Bit - 11.025 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Mono - 8Bit - 22,050 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Mono - 8Bit - 44.100 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Mono - 16Bit - 8.000 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Mono - 16Bit - 11.025 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Mono - 16Bit - 22,050 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Mono - 16Bit - 44.100 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 8Bit - 8.000 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 8Bit - 11.025 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 8Bit - 22,050 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 8Bit - 44.100 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 16Bit - 8.000 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 16Bit - 11.025 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 16Bit - 22,050 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
T$ =" Stereo - 16Bit - 44.100 kHz"
SendMessage(AudioChoice&,$0143,0,ADDR(T$))
SendMessage(AudioChoice&,$014E,15,0)'Auf 1. Eintrag setzen
SetWaveFormat 1,16,44100
'#################
Usermessages $03,$0111
SetPreviev 1,25,1
SetText OverlayButton&,"Overlay"
IsOverlay% = 0

Whilenot ende%

    Waitinput

    If %UMessage = $0111'WM_Command

        If &ULParam = DriverChoice&

            If HiWord(&UWParam) = $01'Eintrag in Choicebox gewechselt ??

                UseCursor 2
                LockWindowUpdate(%hwnd)
                DisconnectDriver
                ConnectDriver SendMessage(DriverChoice&,$0147,0,0)
                LockWindowUpdate(0)
                UseCursor 0

            endif

        ElseIf &ULParam = AudioChoice&

            If HiWord(&UWParam) = $01'Eintrag in Choicebox gewechselt ??

                Case Sendmessage(AudioChoice&,$0147,0,0) = 0 :SetWaveFormat 0,8,8
                Case Sendmessage(AudioChoice&,$0147,0,0) = 1 :SetWaveFormat 0,8,11025
                Case Sendmessage(AudioChoice&,$0147,0,0) = 2 :SetWaveFormat 0,8,22050
                Case Sendmessage(AudioChoice&,$0147,0,0) = 3 :SetWaveFormat 0,8,44100
                Case Sendmessage(AudioChoice&,$0147,0,0) = 4 :SetWaveFormat 0,16,8
                Case Sendmessage(AudioChoice&,$0147,0,0) = 5 :SetWaveFormat 0,16,11025
                Case Sendmessage(AudioChoice&,$0147,0,0) = 6 :SetWaveFormat 0,16,22050
                Case Sendmessage(AudioChoice&,$0147,0,0) = 7 :SetWaveFormat 0,16,44100
                Case Sendmessage(AudioChoice&,$0147,0,0) = 8 :SetWaveFormat 1,8,8
                Case Sendmessage(AudioChoice&,$0147,0,0) = 9 :SetWaveFormat 1,8,11025
                Case Sendmessage(AudioChoice&,$0147,0,0) = 10 :SetWaveFormat 1,8,22050
                Case Sendmessage(AudioChoice&,$0147,0,0) = 11 :SetWaveFormat 1,8,44100
                Case Sendmessage(AudioChoice&,$0147,0,0) = 12 :SetWaveFormat 1,16,8
                Case Sendmessage(AudioChoice&,$0147,0,0) = 13 :SetWaveFormat 1,16,11025
                Case Sendmessage(AudioChoice&,$0147,0,0) = 14 :SetWaveFormat 1,16,22050
                Case Sendmessage(AudioChoice&,$0147,0,0) = 15 :SetWaveFormat 1,16,44100

            endif

        Endif

    endif

    If %Umessage = $03'$WM_Move

        SetWindowpos CapWindow& = 0,0 - 0,0
        SetWindowpos CapWindow& = 0,40 - 320,240

    Endif

    If GetFocus(EndeButton&)

        Ende% = 1

    Elseif GetFocus (OverlayButton&)

        If IsOverlay% = 1

            SetPreviev 1,25,1
            SetText OverlayButton&,"Overlay"
            IsOverlay% = 0
            SetFocus(0)

        else

            SetOverlay 1
            SetText OverlayButton&,"Preview"
            IsOverlay% = 1
            SetFocus(0)

        Endif

    Elseif GetFocus (CapBMPButton&)

        if GetText$(SingleNameEdit&) <> ""

            GrabFrame GetText$(SingleNameEdit&)

        Else

            @Messagebox("Keine Bitmapname vergeben","Fehler...",64)

        Endif

    Elseif GetFocus (StartCapButton&)

        if GetText$(AVINameEdit&) <> ""

            Capstart F:\Noname.aviGetText$(AVINameEdit&)

        Else

            @Messagebox("Keine AVI-Name vergeben","Fehler...",64)

        Endif

    Elseif GetFocus (StopCapButton&)

        CapStop

    Elseif GetFocus (SourceDialogButton&)

        VideoSourceDialog
        SetFocus(0)

    Elseif GetFocus (FormatDialogButton&)

        VideoFormatDialog
        GetVideoFormat
        SetText VideoFormatText&,"Video-Format : "+\
        Substr$(@$(0),1,",")+" x "+Substr$(@$(0),2,",")+"Pixel"
        SetFocus(0)

    Elseif GetFocus (KompressionDialogButton&)

        VideoKompressionDialog
        SetFocus(0)

    Endif

EndWhile

DisconnectDriver
CapExit
End

Computer: Gerät, daß es in Mikrosekunden erlaubt, 50.000 Fehler zu machen, zB 'daß' statt 'das'...

09.10.2018 ▲

Bei 2 verschiedenen USB DVBT Sticks (einmal MSI und einmal Haupauge) an Windows XP Home, habe ich keine Möglichkeit, diese Karten auszuwählen. So gesehen zeigt mir obiger Code nur die Liste der Webcams [...]

aber keine TV-Karten.

Das ist schade.

26.05.2009 ▲

Hans
Hermann

Wie kommt das bei diesem Script "WebCam TV Video Capture Aufzeichnen avicap32 Fernseh Cam": Das Bild einer angeschlossenen USB-Webcam wird nicht angezeigt (schwarz), aber ein AVI kann aufgezeichnet werden. Und bei einer im Notebook eingebauten Webcam wird das Bild angezeigt; während das AVI aufgenommen wird, friert das angezeigte Bild zum Standbild ein.
Was ist zu tun, um das Bild auch im ersten Fall anzuzeigen?
Vielen Dank!

30.06.2009 ▲

Wie reagiert [...]

bei Dir?

30.06.2009 ▲

Hans
Hermann

Fantacam zeigt die USB-Kamera auch nicht an (bleibt schwarz), die integrierte Notebook-Cam wird jedoch wiedergegeben..
Der einige Unterschied ist die Kompressionsanzeige unter "Videoformat" (und die Bytes) bei 640x480:
USB-Cam: MJPG (921600 B)
Int.-Cam: YUY2 (614400 B)

An FantaCam konnte ich bisher alle Cams anschliessen um deren Bild zu zeigen - ich zumindest habe keine Idee was da bei Deiner externen Kamera "schief läuft". Wird Dir diese ext. Kamera bei den Laufwerken im Arbeitsplatz angezeigt (wie normale Webcams)?

Hans
Hermann

...die USB-Cam wird unter Arbeitsplatz --> Scanner und Kameras als "USB-Videogerät" angezeigt und zeigt nach Doppelklick die momentanen Bilder...

Nenne doch bitte einige USB-Fabrikate/Modelle, mit denen die Anzeige funktioniert -- DANKE!

Microsoft und Herkules, bei letzterem die 3,99Euro, die 7,99Euro und die 16,99Euro-Varianten funktionieren bei mir definitiv.

Hans
Hermann

> 3,99Euro - 7,99Euro - 16,99Euro
Habe leider keine derartigen Preise bei Hercules gefunden. Gibts da evtl. auch Typenbezeichnungen?

Ich kauf solche bein Conrad, Classic steht z.B. drauf.

Imho funktionierte mit obigen Code bisher "jede" Cam, nur eben diese eine von Dir leider nicht.

Welche genau ist das?

Hans
Hermann

Besagte Webcam ist eine Megapixel D251 (Shenzen Xinyi Jingye Tec [xinyi2008.com]) und ein chinesisches Massenprodukt, welches neuerdings auf dem europäischen Markt unter vielen Aliasen auch via Ebay verscherbelt wird.

Habe die "Classic"-Kamera bestellt und will versuchen, den Unterschied zu finden...

02.07.2009 ▲

Jau!

02.07.2009 ▲