Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0726: Morsezeichen erzeugen

VB 5/6-Tipp 0726: Morsezeichen erzeugen

 von Philipp Burch

Schwierigkeitsgrad:

Verwendete API-Aufrufe: PlaySoundA (PlaySoundData), RtlMoveMemory, RtlZeroMemory

Download: Download des Beispielprojektes [19,11 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'----------- Anfang Projektdatei MorseCreator.vbp -----------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Standarddialog-Steuerelement "cdlDialog"
' Steuerelement: Horizontale Scrollbar "hsbFreq"
' Steuerelement: Schaltfläche "cmdClear"
' Steuerelement: Schaltfläche "cmdSave"
' Steuerelement: Schaltfläche "cmdPlay"
' Steuerelement: Horizontale Scrollbar "hsbSpeed"
' Steuerelement: Textfeld "txtText"
' Steuerelement: Beschriftungsfeld "lblFreq"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "lblFileSize"
' Steuerelement: Beschriftungsfeld "lblSpeed"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

'Erzeugung von Morsezeichen aus Textdaten
'17.06.2008, Philipp Burch

Private Declare Function PlaySoundData Lib "winmm.dll" _
 Alias "PlaySoundA" (lpData As Any, _
  ByVal hModule As Long, _
  ByVal dwFlags As Long) As Long
                 
Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
  ByRef Dst As Any, _
  ByRef Src As Any, _
  ByVal Length As Long)
                   
Private Declare Sub RtlZeroMemory Lib "kernel32.dll" ( _
  ByRef Dst As Any, _
  ByVal Length As Long)
  
Const pi = 3.14159265358979

Private Type Standard_Wave_Header
    Riff As Long       'Sollte immer "RIFF" enthalten = 1179011410
    Rl As Long         'Groesse des folgenden "Chunks"
    Typ As Long        'Typinformation 4 byte "WAVE" = 1163280727
    Fmt As Long        'Muss "fmt " enthalten = 544501094
    CSize As Long      'Chunksize
    Tag As Integer     'Meist unbenutzt
    nChan As Integer   'Zahl der Kanäle
    SPps As Long       'Samples pro Sekunde
    Bps As Long        'Bytes pro Sekunde
    Bla As Integer     'Blockalign (Byte pro Sample)
    SPl As Integer     'Samplelänge
    Data As Long       'Muss "DATA" enthalten = 1096040772
    Dl As Long         'Datenlänge
End Type

Private Const CodeAE As Byte = 21
Private Const CodeOE As Byte = 30
Private Const CodeUE As Byte = 19
    
Private Const SPps As Long = 44100      'Samples pro Sekunde
Private Const BpSP As Long = 2          'Bytes pro Sample
Private Const DpC As Double = 12        'Dits pro Zeichen (Bei vvvvv)
Private Const Amp As Integer = 32000    'Maximale Amplitude

Private MorseCodes As String            'Bei Zeichen 36 beginnend

Private Dit() As Integer
Private Dah() As Integer
Private Mem() As Byte

Private Sub Form_Load()
    'Aus diesem String werden die Töne für die einzelnen Zeichen
    'generiert. Zur einfachen Speicherung wird folgendes Verfahren
    'angewandt:
    'Jedes Byte (8 Bit) repräsentiert den Morsecode für ein
    'bestimmtes Zeichen im ANSI-Zeichensatz. Da die Zeichen
    'unterhalb 36 ohnehin keine Entsprechung im Morsecode haben,
    'bzw. gar nicht darstellbar sind, wurden sie weggelassen.
    'Jedes Bit dieser Bytes stellt nun ein Dit oder ein Dah dar.
    'Da die Morsezeichen aber nicht alle gleich lang sind, sind
    'die Zeichendaten innerhalb der Bytes rechts ausgerichtet und
    'ganz oben mit einem Startbit versehen.
    '
    'Beispiele:
    '
    'Buchstabe n (dahdit):
    '0b0000 0110 (6)
    '/       ^^^
    '/       ||`-- Dit
    '/       |`--- Dah
    '/       `---- Startbit
    '
    'Zahl 0 (dadadadadah)
    '0b0011 1111 (63)
    '/   ^^ ^^^^
    '/   || |||`-- Dah
    '/   || ||`--- Dah
    '/   || |`---- Dah
    '/   || `----- Dah
    '/   |`------- Dah
    '/   `-------- Startbit
    '
    'Der Wert 255 (theoretisch sieben Dahs) entspricht keinem
    'Zeichen, sondern markiert leere Bytes.
    MorseCodes = _
      Chr$(255) & Chr$(255) & Chr$(255) & Chr$(94) & _
      Chr$(54) & Chr$(109) & Chr$(255) & Chr$(42) & _
      Chr$(115) & Chr$(97) & Chr$(85) & Chr$(50) & _
      Chr$(63) & Chr$(47) & Chr$(39) & Chr$(35) & _
      Chr$(33) & Chr$(32) & Chr$(48) & Chr$(56) & _
      Chr$(60) & Chr$(62) & Chr$(120) & Chr$(106) & _
      Chr$(255) & Chr$(49) & Chr$(255) & Chr$(76) & _
      Chr$(90) & Chr$(5) & Chr$(24) & Chr$(26) & _
      Chr$(12) & Chr$(2) & Chr$(18) & Chr$(14) & _
      Chr$(16) & Chr$(4) & Chr$(23) & Chr$(13) & _
      Chr$(20) & Chr$(7) & Chr$(6) & Chr$(15) & _
      Chr$(22) & Chr$(29) & Chr$(10) & Chr$(8) & _
      Chr$(3) & Chr$(9) & Chr$(17) & Chr$(11) & _
      Chr$(25) & Chr$(27) & Chr$(28) & Chr$(255)
      
    ReDim Mem(0)
End Sub

Private Sub CreateDitDah(speed As Integer, frequency As Integer)
    If speed < 30 Or speed > 300 Then Exit Sub
    If frequency < 100 Or frequency > 5000 Then Exit Sub
    
    Dim spD As Double       'Zeit in Sekunden für ein Dit
    Dim i As Long
    Dim a As Byte           'Amplitudenmultiplikator (0 - 200)
    Dim phi As Double       'Winkel
    Dim phistep As Double   'Winkelinkrement pro Sample
    
    'Die Zeit für ein Dit (Ein Dah hat die Länge von drei Dits)
    'ergibt sich aus der Geschwindigkeit in Zeichen pro Minute
    'und der Anzahl Dits eines "Norm-Zeichens", in diesem Fall
    'ein 'v' (Didididah)
    spD = 60 / (speed * DpC)
    
    ReDim Dit(SPps * spD - 1)
    ReDim Dah(3 * (UBound(Dit) + 1))
    
    'Die Winkelgeschwindigkeit beträgt "frequency" Vollkreise pro Sekunde
    phistep = 2 * pi * frequency / SPps
    
    'Um "Tastklicks" zu vermeiden, wird die Amplitude kontinuierlich
    'erhöht, bzw. verringert.
    
    phi = 0
    For i = 0 To UBound(Dit)
        If i <= 200 Then a = i
        If i >= UBound(Dit) - 200 Then a = UBound(Dit) - i
        
        Dit(i) = Amp * (a / 200#) * Sin(phi)
        
        phi = phi + phistep
    Next i
    
    phi = 0
    For i = 0 To UBound(Dah)
        If i <= 200 Then a = i
        If i >= UBound(Dah) - 200 Then a = UBound(Dah) - i
        
        Dah(i) = Amp * (a / 200#) * Sin(phi)
        
        phi = phi + phistep
    Next i
End Sub

Private Sub CreateWave(text As String)
    Dim code() As Byte  '0 = Pause, >0 = Ton (Dit)
    Dim c As Integer    'Aktuelles Zeichen
    Dim i As Long
    Dim bits As Byte
    Dim hd As Standard_Wave_Header
    Dim memptr As Long  '"Zeiger"
    Dim minlen As Long  'Minimaler Platz für ein Zeichen (0)
    
    If Len(text) = 0 Then Exit Sub
    
    'Minimalen Platz pro Zeichen (0 = Worst case) berechnen
    minlen = (5 * (UBound(Dah) + 1) + 4 * (UBound(Dit) + 1)) * LenB(Dit(0))
    
    'Genügend Platz schaffen
    If UBound(Mem) < Len(text) * minlen - 1 Then
        ReDim Mem(Len(text) * minlen - 1)
    End If
    Call RtlZeroMemory(Mem(0), UBound(Mem) + 1)
    
    'Erstmal den Header überspringen
    memptr = LenB(hd)

    'Bei Kleinbuchstaben passen die Adressen in der Zeichentabelle nicht
    text = UCase$(text)
    
    For i = 1 To Len(text)
        'Platz überprüfen und gegebenenfalls Länge verdoppeln
        If (UBound(Mem) + 1) - memptr < minlen Then
            Dim cnt As Long
            cnt = UBound(Mem) + 1
            ReDim Preserve Mem(2 * cnt)
            'Müll wegräumen
            Call RtlZeroMemory(Mem(cnt), cnt)
        End If
    
        If Mid$(text, i, 1) <> " " Then
            'Umlaute erfordern eine Spezialbehandlung, da sie nicht
            'in der Zeichentabelle enthalten sind
            If LCase$(Mid$(text, i, 1)) = "ä" Then
                c = CodeAE
            ElseIf LCase$(Mid$(text, i, 1)) = "ö" Then
                c = CodeOE
            ElseIf LCase$(Mid$(text, i, 1)) = "ü" Then
                c = CodeUE
            Else
                c = Asc(Mid$(MorseCodes, Asc(Mid$(text, i, 1)) - 35, 1))
            End If
            
            'Startbit suchen
            bits = 7
            Do While (c And &H80) = 0
                c = c * 2   'Leider gibt es in VB6 keinen Shift-Befehl...
                bits = bits - 1
            Loop
            c = c * 2
            Do While bits
                If (c And &H80) = &H80 Then
                    'Dah
                    Call RtlMoveMemory(Mem(memptr), _
                                       Dah(0), _
                                       (UBound(Dah) + 1) * LenB(Dah(0)))
                    memptr = memptr + (UBound(Dah) + 1) * LenB(Dah(0))
                Else
                    'Dit
                    Call RtlMoveMemory(Mem(memptr), _
                                       Dit(0), _
                                       (UBound(Dit) + 1) * LenB(Dit(0)))
                    memptr = memptr + (UBound(Dit) + 1) * LenB(Dit(0))
                End If
                
                'Pause (1 Dit)
                memptr = memptr + (UBound(Dit) + 1) * LenB(Dit(0))
                
                c = c * 2
                bits = bits - 1
            Loop
        Else
            'Leerzeichen (7 Dits - Buchstabenabstand - Zeichenabstand)
            memptr = memptr + 3 * (UBound(Dit) + 1) * LenB(Dit(0))
        End If
        'Pause zwischen den Buchstaben (3 Dits)
        memptr = memptr + 3 * (UBound(Dit) + 1) * LenB(Dit(0))
    Next i
    
    'Pause am Ende wieder entfernen
    memptr = memptr - 3 * (UBound(Dit) + 1) * LenB(Dit(0))

    'Überschüssigen Platz vernichten
    ReDim Preserve Mem(memptr - 1)

    'Die Dateilänge entspricht jetzt der Länge von Mem, die Datenlänge
    'jedoch der Länge von Mem abzüglich der Headergrösse
    
    'Nun fehlt noch der Header
    With hd
        .Riff = 1179011410  '= "RIFF"
        .Rl = 36 + UBound(Mem) + 1 - LenB(hd)
        .Typ = 1163280727   '= "WAVE"
        .Fmt = 544501094    '= "fmt "
        .CSize = 16         'Länge des folgenden Chunks
        .Tag = 1
        .nChan = 1
        .SPps = SPps
        .Bla = BpSP         'Bei Mono entspricht Bla gerade den Bytes/Sample
        .Bps = .SPps * .Bla
        .SPl = BpSP * 8
        .Data = 1635017060
        .Dl = UBound(Mem) + 1 - LenB(hd)
    End With
    
    Call RtlMoveMemory(Mem(0), hd, LenB(hd))
    
    'Dateigrösse anzeigen
    lblFileSize.Caption = formatsize(UBound(Mem) + 1)
End Sub


'--- Ereignisprozeduren ---

Private Sub txtText_Change()
    txtText.Tag = 1
End Sub

Private Sub txtText_Validate(Cancel As Boolean)
    If txtText.Tag = 1 Then validate
End Sub

Private Sub txtText_KeyPress(KeyAscii As Integer)
    If KeyAscii = 8 Then Exit Sub   'Backspace
    KeyAscii = Asc(LCase$(Chr$(validchar(KeyAscii))))
End Sub

Private Sub hsbFreq_Change()
    Call hsbFreq_Scroll
End Sub

Private Sub hsbFreq_Scroll()
    lblFreq.Caption = CStr(hsbFreq.Value) & " Hz"
    hsbFreq.Tag = 1
End Sub

Private Sub hsbFreq_Validate(Cancel As Boolean)
    If hsbFreq.Tag = 1 Then validate
End Sub

Private Sub hsbSpeed_Change()
    Call hsbSpeed_Scroll
End Sub

Private Sub hsbSpeed_Scroll()
    lblSpeed.Caption = CStr(hsbSpeed.Value) & " Zpm"
    hsbSpeed.Tag = 1
End Sub

Private Sub hsbSpeed_Validate(Cancel As Boolean)
    If hsbSpeed.Tag = 1 Then validate
End Sub

Private Sub cmdPlay_Click()
    If txtText.Tag = 1 Or _
       hsbSpeed.Tag = 1 Or _
       hsbFreq.Tag = 1 Then validate
    
    If Mem(0) = Asc("R") Then
        Const SND_MEMORY As Long = &H4
        Const SND_ASYNC As Long = &H1
        'Wird SND_ASYNC (asynchrone Tonausgabe) auch verwendet, muss eine
        'Veränderung der Tondaten während der Ausgabe unbedingt verhindert
        'werden, sonst kann das Programm abstürzen!
        Call PlaySoundData(Mem(0), 0, SND_MEMORY)
    End If
End Sub

Private Sub cmdSave_Click()
    If txtText.Tag = 1 Or _
       hsbSpeed.Tag = 1 Or _
       hsbFreq.Tag = 1 Then validate
    
    cdlDialog.CancelError = True
    cdlDialog.DefaultExt = ".wav"
    cdlDialog.DialogTitle = "Save"
    cdlDialog.FileName = escape(Trim$(txtText.text)) & ".wav"
    cdlDialog.Filter = "Wave files|*.wav"
    cdlDialog.Flags = cdlOFNHideReadOnly Or _
                      cdlOFNOverwritePrompt Or _
                      cdlOFNPathMustExist
    
    On Error Goto cancelled
    Call cdlDialog.ShowSave
    
    Dim ff As Integer
    
    ff = FreeFile()
    Open cdlDialog.FileName For Binary As #ff
    Put ff, , Mem
    Close #ff
    
cancelled:

    txtText.SelStart = 0
    txtText.SelLength = Len(txtText.text)
    Call txtText.SetFocus
End Sub

Private Sub cmdClear_Click()
    txtText.text = ""
    Call txtText.SetFocus
End Sub


'--- Hilfsfunktionen ---

'Wandelt ein Zeichen in ein darstellbares Zeichen um (0 = nicht darstellbar)
Private Function validchar(char As Integer) As Integer
    If InStr(1, _
             "'()+,-./0123456789:;=?@abcdefghijklmnopqrstuvwxyzäöü ", _
             LCase$(Chr$(char))) Then

        validchar = char
    Else
        validchar = 0
    End If
End Function

Private Sub validate()
    Dim s As String
    Dim i As Long
    Dim c As Integer
    
    For i = 1 To Len(txtText.text)
        c = validchar(Asc(Mid$(txtText.text, i, 1)))
        If c Then s = s & LCase$(Chr$(c))
    Next i
    
    'Mehrfache Leerzeichen entfernen
    Do While InStr(1, s, "  ")
        s = Replace$(s, "  ", " ")
    Loop
       
    'Der Ton muss neu erstellt werden
    If hsbSpeed.Tag = 1 Or hsbFreq.Tag = 1 Then
        'Auch die "Bausteine" müssen neu erstellt werden
        Call CreateDitDah(hsbSpeed.Value, hsbFreq.Value)
    End If
    
    txtText.Tag = 0
    hsbSpeed.Tag = 0
    hsbFreq.Tag = 0
     
     Call CreateWave(txtText.text)
End Sub

Private Function formatsize(size As Long) As String
    Dim pref As String
    pref = "kMG"
    
    Dim sz As Double
    Dim p As Long
    Dim s As String
    
    sz = size
    p = 0
    Do While sz >= 1024
        sz = sz / 1024
        p = p + 1
    Loop
    
    s = Format$(sz, "#0.00") & " "
    If p > 0 Then s = s & Mid$(pref, p, 1) & "i"
    s = s & "B"
    
    formatsize = s
End Function

Private Function escape(text As String) As String
    Dim i As Long
    Dim c As Integer
    Dim s As String
    
    text = Replace$(LCase$(text), " ", "_")
    
    For i = 1 To Len(text)
        If InStr(1, _
                 "+,.0123456789abcdefghijklmnopqrstuvwxyzäöü", _
                 Mid$(text, i, 1)) Then
    
            s = s & Mid$(text, i, 1)
        Else
            c = Asc(Mid$(text, i, 1))
            s = s & "%"
            If c < 16 Then s = s & 0
            s = s & LCase$(Hex$(c))
        End If
    Next i
    
    escape = s
End Function
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'------------ Ende Projektdatei MorseCreator.vbp ------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.