Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

Ein Beispiel von 2005 compilieren

 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC.
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
Roland Chastain



Anmeldungsdatum: 05.12.2011
Beiträge: 194
Wohnort: Frankreich
BeitragVerfasst am: 19.05.2012, 10:06    Titel: Ein Beispiel von 2005 compilieren Antworten mit Zitat
Hallo Freunde !

Ich habe hier ein Beispiel gefunden und ich möchte mit FB 0.23 compilieren.

Können Sie mich helfen bitte ?

Da ist das Code:

Code:
'#### Deklarationen aus der WinAPI
Declare Function mciSendString Lib "winmm.dll" _
  Alias "mciSendStringA" (ByVal lpszCommand As String, _
  ByVal lpszReturnString As String, _
  ByVal cchReturnLength As Long, _
  ByVal hwndCallback As Long) As Long
Declare Function GetShortPathName Lib "kernel32" _
  Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
  ByVal lpszShortPath As String, _
  ByVal cchBuffer As Long) As Long
 
'#### Lokale Subs und Functions
DECLARE Function FileExist(sDatei AS STRING) AS INTEGER
DECLARE Function InstrR(Zeichenkette AS STRING, SuchenNach AS STRING) AS LONG
DECLARE Function GetType(ByVal sFile As String, ByRef bVideo As Integer) As String
DECLARE Function mGetLength(sAlias AS STRING) As Long
DECLARE Function mCurPos(sAlias AS STRING) As Long
DECLARE Sub mResume(sAlias AS STRING)
DECLARE Sub mPause(sAlias AS STRING)
DECLARE Sub mStop(sAlias AS STRING)
DECLARE Sub mClose(sAlias AS STRING)
DECLARE Function PlaySound(sFile As String, sAlias As String) As Integer
DECLARE Function ZweiStellen(Zahl AS BYTE) AS STRING
DECLARE Function SMS(LaengeInSek AS LONG) AS STRING

Function PlaySound(sFile As String, sAlias As String) As Integer
  Dim sBuffer As String
  Dim lResult As Long
  Dim mResult AS LONG
  Dim sf AS STRING
  Dim gt AS STRING
  sf = Space$(255)
  sBuffer = Space$(255)
  sf = sFile
  lResult = GetShortPathName(sf, sBuffer, Len(sBuffer))
  If lResult <> 0 Then
    sBuffer = RTRIM$(sBuffer)
    gt = GetType (sBuffer, Video%)
    If Video% = -1 Then
        Print "Videos können im DOS-Fensterchen nicht abgespielt werden!"
        Sleep
        End
    End If
    mResult = mciSendString("open " + sBuffer +" type "+gt+" alias " + sAlias, 0, 0, 0)
    If mResult = 0 Then
      ' MP3 abspielen
      Print "L";CHR$(132);"nge deines Sounds: ";SMS(FIX(mGetLength(sAlias)/1000))
      PRINT ""
      If mciSendString("play " + sAlias + " from 0", 0, 0, 0) = 0 Then     
        PlaySound = -1
      End If
    End If
  End If
End Function

Sub mClose(sAlias AS STRING)
  mciSendString "close "+sAlias, 0, 0, 0
End Sub

Sub mStop(sAlias AS STRING)
  mciSendString "stop "+sAlias, 0, 0, 0
End Sub

Sub mPause(sAlias AS STRING)
  mciSendString "pause "+sAlias, 0, 0, 0
End Sub

Sub mResume(sAlias AS STRING)
  mciSendString "resume "+sAlias, 0, 0, 0
  mciSendString "put "+sAlias+" destination", 0, 0, 0
End Sub

Function mCurPos(sAlias AS STRING) As Long
  Dim sBuffer As String * 255
  mciSendString "status "+sAlias+" position", sBuffer, Len(sBuffer), 0
  mCurPos = Val(sBuffer)
End Function

Function mGetLength(sAlias AS STRING) As Long
  Dim sBuffer As String * 255
  mciSendString "status "+sAlias+" length", sBuffer, Len(sBuffer), 0
  mGetLength = Val(sBuffer)
End Function

Function GetType(ByVal sFile As String, ByRef bVideo As Integer) As String
  Dim sExt As String
  Dim GtType AS STRING
  bVideo = 0
  If InStr(sFile, ".") > 0 Then
    sExt = Right$(sFile, InstrR(sFile,"."))
    Select Case LCase(sExt)
      Case "mid", "midi"
        GtType = "Sequencer"
      Case "rmi"
        GtType = "Sequencer"
      Case "wav"
        GtType = "waveaudio"
      Case "cda"
        GtType = "CDAudio"
      Case "aif", "aifc", "aiff", "au", "mp3", "snd"
        GtType = "MPEGVideo"
      Case "wma"
        GtType = "MPEGVideo2"
      Case "mpeg", "mpg", "m1v", "mp2", "mpa", "mpe"
        GtType = "MPEGVideo"
        bVideo = True
      Case "avi"
        GtType = "AVIVideo"
        bVideo = True
      Case "wmv"
        GtType = "MPEGVideo2"
        bVideo = True
      Case Else
        GtType = "MPEGVideo"
    End Select
  End If
  GetType = GtType
End Function

Function InstrR(Zeichenkette AS STRING, SuchenNach AS STRING) AS LONG
count&=0
    For i& = LEN(Zeichenkette) TO 1 STEP -1
        If MID$(Zeichenkette,i&,LEN(SuchenNach)) = SuchenNach Then
            InstrR = count&
            Exit Function
        End If
        count&=count&+1
    Next i&
End Function

Function FileExist(sDatei AS STRING) AS INTEGER
    Open sDatei FOR BINARY ACCESS READ AS #1
    l& = LOF(1)
    CLOSE #1
    If l& <1 Then
        Kill sDatei
        FileExist =0
        Exit Function
    Else
        FileExist = -1
        Exit Function
    End If
End Function

Function ZweiStellen(Zahl AS BYTE) AS STRING
 If LEN(LTRIM$(STR$(Zahl))) <2 Then
     ZweiStellen = "0"+LTRIM$(STR$(Zahl))
     EXIT FUNCTION
 Else
     ZweiStellen = LTRIM$(STR$(Zahl))
     Exit FUNCTION
 End If
End Function

Function SMS(LaengeInSek AS LONG) AS STRING
    Dim RestL AS LONG
    Dim Stunden AS BYTE
    Dim Minuten AS BYTE
    Dim Sekunden AS BYTE
    RestL = LaengeInSek
    Do
        If RestL > 3599 Then
            Stunden=Stunden+1
            RestL=RestL - 3600
        Else
            Exit Do
        End If
    Loop
    Do
        If RestL > 59 Then
            Minuten = Minuten +1
            RestL=RestL -60
        Else
            Exit Do
        End If
    Loop
    Sekunden = RestL
    SMS = ZweiStellen(Stunden)+":"+ZweiStellen(Minuten)+":"+ZweiStellen(Sekunden)
End FUNCTION

'KURZE BESCHREIBUNG
'
'Dieses FreeBasic Beispielprogramm spielt einen Sound mit der WinAPI ab.
'Es werden die gängigen Formate wie MP3, WAV, MIDI usw. unterstützt.
'Der Primitivplayer gibt die aktuelle Position und die Gesamtlänge des
'Sounds wieder und spielt ihn ab. Die Wiedergabe kann unterbrochen und
'wieder fortgesetzt werden. Der Source ist zum Experimentieren und kann
'von Jedermann beliebig verwendet und in eigene Programme eingebaut werden.
'Viel Spaß damit!
'
' Sebastian Steiner
' eMail:    sebastian_steiner[ätt]gmx.de
' Homepage: www.sebastian-steiner.de

Beginn:
CLS
COLOR 14
PRINT "FreeBasic Demonstrationscode - Sound ";CHR$(129);"ber die WinAPI"
PRINT ""
COLOR 15
PRINT "Gib den Dateinamen deiner Audiodatei ein oder gib quit ein,"
PRINT "um das Programm zu beenden: ";
COLOR 11
INPUT "",datei$
COLOR 15
if UCASE$(datei$) = "QUIT" Then End
If FileExist(datei$) = 0 Then
    Print "Deine Datei existiert nicht."
    Sleep
    Goto Beginn
End If
PRINT ""
Dim Ergebnis AS INTEGER
Ergebnis = PlaySound(datei$, "MeinSoundNr1")
If Ergebnis = 0 Then
    Print "Leider ist ein Fehler passiert. Hat nicht geklappt."
    Sleep
    End
End if
PRINT "================================================="
PRINT "|  S - Stop  |  P - Pause  |  W - Weitermachen  |"
PRINT "================================================="
'Leider werden die Umlaute falsch dargestellt, wenn man sie in der fbIDE
'schreibt. Daher diese Ersatzform mit CHR$()
Print "Sound l";CHR$(132);"uft, aktuelle Position =>>";
p% = CSRLIN
Print ""
Dim Dateilaenge AS LONG
DIM AktuellePosition AS LONG
Dim TASTE AS STRING
Dateilaenge = mGetLength("MeinSoundNr1")
Do
    Sleep 200
    AktuellePosition = mCurPos("MeinSoundNr1")
    Locate p%,36: PRINT "        "
    Locate p%,36: PRINT SMS(FIX(AktuellePosition/1000))
    Taste = Inkey$
    If UCASE$(Taste) = "S" Then
        mStop "MeinSoundNr1"
        mClose "MeinSoundNr1"
        PRINT ""
        PRINT "Sound gestoppt.":SLEEP:END
    END IF
    If UCASE$(Taste) = "P" Then
        mPause "MeinSoundNr1"
        Do
            SLEEP 100
            If UCASE$(Inkey$) = "W" Then
                mResume "MeinSoundNr1"
                Exit Do
            End If
        Loop
    End If
    If Taste$ = CHR$(27) Then End
    If AktuellePosition +5 >=Dateilaenge Then Exit Do
Loop
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
St_W



Anmeldungsdatum: 22.07.2007
Beiträge: 956
Wohnort: Austria
BeitragVerfasst am: 19.05.2012, 17:09    Titel: Antworten mit Zitat
z.B. so:
Code:
#Include "windows.bi"
#Include "win/mmsystem.bi"
#Include "vbcompat.bi"
 
'#### Lokale Subs und Functions
Declare Function GetType(ByVal sFile As String, ByRef bVideo As Integer) As String
DECLARE Function mGetLength(sAlias AS STRING) As Long
DECLARE Function mCurPos(sAlias AS STRING) As Long
DECLARE Sub mResume(sAlias AS STRING)
DECLARE Sub mPause(sAlias AS STRING)
DECLARE Sub mStop(sAlias AS STRING)
DECLARE Sub mClose(sAlias AS STRING)
DECLARE Function PlaySound2(sFile As String, sAlias As String) As Integer
DECLARE Function ZweiStellen(Zahl AS BYTE) AS STRING
DECLARE Function SMS(LaengeInSek AS LONG) AS STRING

Function PlaySound2(sFile As String, sAlias As String) As Integer
  Dim sBuffer As String
  Dim lResult As Long
  Dim mResult AS LONG
  Dim sf AS STRING
  Dim gt AS String
  Dim Video As Integer
  sf = Space(255)
  sBuffer = Space(255)
  sf = sFile
  lResult = GetShortPathName(sf, sBuffer, Len(sBuffer))
  If lResult <> 0 Then
    sBuffer = RTRIM(sBuffer)
    gt = GetType (sBuffer, Video)
    If Video = -1 Then
        Print "Videos können im DOS-Fensterchen nicht abgespielt werden!"
        Sleep
        End
    End If
    mResult = mciSendString("open " + sBuffer +" type "+gt+" alias " + sAlias, 0, 0, 0)
    If mResult = 0 Then
      ' MP3 abspielen
      Print "L";CHR(132);"nge deines Sounds: ";SMS(FIX(mGetLength(sAlias)/1000))
      PRINT ""
      If mciSendString("play " + sAlias + " from 0", 0, 0, 0) = 0 Then     
        PlaySound2 = -1
      End If
    End If
  End If
End Function

Sub mClose(sAlias AS STRING)
  mciSendString "close "+sAlias, 0, 0, 0
End Sub

Sub mStop(sAlias AS STRING)
  mciSendString "stop "+sAlias, 0, 0, 0
End Sub

Sub mPause(sAlias AS STRING)
  mciSendString "pause "+sAlias, 0, 0, 0
End Sub

Sub mResume(sAlias AS STRING)
  mciSendString "resume "+sAlias, 0, 0, 0
  mciSendString "put "+sAlias+" destination", 0, 0, 0
End Sub

Function mCurPos(sAlias AS STRING) As Long
  Dim sBuffer As String * 255
  mciSendString "status "+sAlias+" position", sBuffer, Len(sBuffer), 0
  mCurPos = Val(sBuffer)
End Function

Function mGetLength(sAlias AS STRING) As Long
  Dim sBuffer As String * 255
  mciSendString "status "+sAlias+" length", sBuffer, Len(sBuffer), 0
  mGetLength = Val(sBuffer)
End Function

Function GetType(ByVal sFile As String, ByRef bVideo As Integer) As String
  Dim sExt As String
  Dim GtType AS STRING
  bVideo = 0
  If InStr(sFile, ".") > 0 Then
    sExt = Right(sFile, InstrRev(sFile,"."))
    Select Case LCase(sExt)
      Case "mid", "midi"
        GtType = "Sequencer"
      Case "rmi"
        GtType = "Sequencer"
      Case "wav"
        GtType = "waveaudio"
      Case "cda"
        GtType = "CDAudio"
      Case "aif", "aifc", "aiff", "au", "mp3", "snd"
        GtType = "MPEGVideo"
      Case "wma"
        GtType = "MPEGVideo2"
      Case "mpeg", "mpg", "m1v", "mp2", "mpa", "mpe"
        GtType = "MPEGVideo"
        bVideo = True
      Case "avi"
        GtType = "AVIVideo"
        bVideo = True
      Case "wmv"
        GtType = "MPEGVideo2"
        bVideo = True
      Case Else
        GtType = "MPEGVideo"
    End Select
  End If
  GetType = GtType
End Function

Function ZweiStellen(Zahl AS BYTE) AS STRING
 If LEN(LTRIM(STR(Zahl))) <2 Then
     ZweiStellen = "0"+LTRIM(STR(Zahl))
     EXIT FUNCTION
 Else
     ZweiStellen = LTRIM(STR(Zahl))
     Exit FUNCTION
 End If
End Function

Function SMS(LaengeInSek AS LONG) AS STRING
    Dim RestL AS LONG
    Dim Stunden AS BYTE
    Dim Minuten AS BYTE
    Dim Sekunden AS BYTE
    RestL = LaengeInSek
    Do
        If RestL > 3599 Then
            Stunden=Stunden+1
            RestL=RestL - 3600
        Else
            Exit Do
        End If
    Loop
    Do
        If RestL > 59 Then
            Minuten = Minuten +1
            RestL=RestL -60
        Else
            Exit Do
        End If
    Loop
    Sekunden = RestL
    SMS = ZweiStellen(Stunden)+":"+ZweiStellen(Minuten)+":"+ZweiStellen(Sekunden)
End FUNCTION

'KURZE BESCHREIBUNG
'
'Dieses FreeBasic Beispielprogramm spielt einen Sound mit der WinAPI ab.
'Es werden die gängigen Formate wie MP3, WAV, MIDI usw. unterstützt.
'Der Primitivplayer gibt die aktuelle Position und die Gesamtlänge des
'Sounds wieder und spielt ihn ab. Die Wiedergabe kann unterbrochen und
'wieder fortgesetzt werden. Der Source ist zum Experimentieren und kann
'von Jedermann beliebig verwendet und in eigene Programme eingebaut werden.
'Viel Spaß damit!
'
' Sebastian Steiner
' eMail:    sebastian_steiner[ätt]gmx.de
' Homepage: www.sebastian-steiner.de

Beginn:
Dim datei As String
CLS
COLOR 14
PRINT "FreeBasic Demonstrationscode - Sound ";Chr(129);"ber die WinAPI"
PRINT ""
COLOR 15
PRINT "Gib den Dateinamen deiner Audiodatei ein oder gib quit ein,"
PRINT "um das Programm zu beenden: ";
COLOR 11
INPUT "",datei
COLOR 15
if UCASE(datei) = "QUIT" Then End
If FileExists(datei) = 0 Then
    Print "Deine Datei existiert nicht."
    Sleep
    Goto Beginn
End If
PRINT ""
Dim Ergebnis AS INTEGER
Ergebnis = PlaySound2(datei, "MeinSoundNr1")
If Ergebnis = 0 Then
    Print "Leider ist ein Fehler passiert. Hat nicht geklappt."
    Sleep
    End
End if
PRINT "================================================="
PRINT "|  S - Stop  |  P - Pause  |  W - Weitermachen  |"
PRINT "================================================="
'Leider werden die Umlaute falsch dargestellt, wenn man sie in der fbIDE
'schreibt. Daher diese Ersatzform mit CHR()
Print "Sound l";CHR(132);"uft, aktuelle Position =>>";
Dim p As Integer
p = CSRLIN
Print ""
Dim Dateilaenge AS LONG
DIM AktuellePosition AS LONG
Dim Taste AS String
Dateilaenge = mGetLength("MeinSoundNr1")
Do
    Sleep 200
    AktuellePosition = mCurPos("MeinSoundNr1")
    Locate p,36: PRINT "        "
    Locate p,36: PRINT SMS(FIX(AktuellePosition/1000))
    Taste = InKey()
    If UCase(Taste) = "S" Then
        mStop "MeinSoundNr1"
        mClose "MeinSoundNr1"
        PRINT ""
        PRINT "Sound gestoppt.":SLEEP:END
    END IF
    If UCase(Taste) = "P" Then
        mPause "MeinSoundNr1"
        Do
            SLEEP 100
            If UCASE(InKey()) = "W" Then
                mResume "MeinSoundNr1"
                Exit Do
            End If
        Loop
    End If
    If Taste = CHR(27) Then End
    If AktuellePosition +5 >=Dateilaenge Then Exit Do
Loop

Ich habe die WinAPI Deklarationen durch ein include der entsprechenden Windows-Header ersetzt und
die ehemalige FileExist Methode durch die FileExists Methode aus vbcompat.bi (bzw. file.bi) ersetzt.
Die InstrR Funktion kann mit der im Compiler integrierten InstrRev Funktion ersetzt werden (die InstrRev Funktion war damals zwar im Compiler, aber funktionierte nicht ordnungsgemäß - darum diese manuelle Implementierung vermute ich).
Ein paar wenige Variablendeklarationen hinzugefügt und ein paar Datentypen-postfixe ($, %, &, !, #) entfernt.

Ich hab es allerdings noch nicht getestet, ob das Programm an sich auch funktioniert! Aber es kann schon ohne Fehler compiliert werden.
_________________
Aktuelle FreeBasic Builds, Projekte, Code-Snippets unter http://users.freebasic-portal.de/stw/
http://www.mv-lacken.at Musikverein Lacken (MV Lacken)
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Roland Chastain



Anmeldungsdatum: 05.12.2011
Beiträge: 194
Wohnort: Frankreich
BeitragVerfasst am: 19.05.2012, 19:08    Titel: Antworten mit Zitat
St_W hat Folgendes geschrieben:
Ich habe die WinAPI Deklarationen durch ein include der entsprechenden Windows-Header ersetzt und
die ehemalige FileExist Methode durch die FileExists Methode aus vbcompat.bi (bzw. file.bi) ersetzt.
Die InstrR Funktion kann mit der im Compiler integrierten InstrRev Funktion ersetzt werden (die InstrRev Funktion war damals zwar im Compiler, aber funktionierte nicht ordnungsgemäß - darum diese manuelle Implementierung vermute ich).
Ein paar wenige Variablendeklarationen hinzugefügt und ein paar Datentypen-postfixe ($, %, &, !, #) entfernt.

Ich hab es allerdings noch nicht getestet, ob das Programm an sich auch funktioniert! Aber es kann schon ohne Fehler compiliert werden.


Vielen Dank !

Ich habe mit WAV und WMA getestet: es funktioniert perfekt.

Es freut mich. happy

[EDIT]

Es funktioniert also mit MP3: Abschied

Zitat:
Mein Gott! wann kommt das schöne: Nun!
Da ich im Frieden fahren werde
Und in dem Sande kühler Erde
Und dort bei dir im Schoße ruhn.
Der Abschied ist gemacht:
Welt, gute Nacht!

In memoriam Dietrich Fischer-Dieskau (1925-2012).
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC. Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
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.

 Impressum :: Datenschutz