Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0755: Steganographie in Bildern

VB 5/6-Tipp 0755: Steganographie in Bildern

 von Dario

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [57,83 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 Projekt1.vbp -------------
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6)
' (MsComCtl.ocx)' wird benötigt.
' Die Komponente 'Microsoft Common Dialog Control 6.0 (comdlg32.ocx)' wird
' benötigt.
' ---- Anfang Formular "frmStegano" alias frmStegano.frm  ----
' Steuerelement: Standarddialog-Steuerelement "dlgFiles"
' Steuerelement: Fortschrittsanzeige "ProgressBar1"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Menü "mnuCtl"
' Steuerelement: Menü "mnuLoad" auf mnuCtl
' Steuerelement: Menü "mnuSave" auf mnuCtl
' Steuerelement: Menü "Seperator" auf mnuCtl
' Steuerelement: Menü "mnuEncode" auf mnuCtl
' Steuerelement: Menü "mnuDecode" auf mnuCtl
' Steuerelement: Menü "Separator2" auf mnuCtl
' Steuerelement: Menü "mnuQuit" auf mnuCtl
Option Explicit

Private Stream As New CryptoStream  ' Der Verschlüsselungsstream

' Verschlüsseln
Private Sub mnuEncode_Click()

    Dim i As Long
    
    Call Picture1.Cls
    Call Stream.SetPointer
    Call Stream.WritePixel(Len(Text1.Text))
    Call Stream.Increment
    
    ProgressBar1.Max = Len(Text1.Text)
    ProgressBar1.Value = 0
    
    For i = 1 To Len(Text1.Text)
    
        Call Stream.WriteByte(Asc(Mid$(Text1, i, 1)))
        
        ProgressBar1.Value = ProgressBar1.Value + 1
        
    Next i
    
    With Text1
    
        .SelStart = 0
        .SelLength = Len(.Text)
        .SetFocus
        
    End With
    
End Sub

' Entschlüsseln
Private Sub mnuDecode_Click()

    Dim i As Long, tmp As String, Length As Long
    
    Call Stream.SetPointer
    
    Length = Stream.ReadPixel
    
    Call Stream.Increment
    
    ProgressBar1.Max = Length
    ProgressBar1.Value = 0
    
    For i = 1 To Length
    
        tmp = tmp & Chr$(Stream.ReadByte(Picture2))
        ProgressBar1.Value = ProgressBar1.Value + 1
        
    Next i
    
    Text1.Text = tmp
    
End Sub

' Beenden
Private Sub mnuQuit_Click()

    Call Unload(Me)
    
    Set frmStegano = Nothing
    
End Sub

' Laden
Private Sub mnuLoad_Click()

    Set Picture1.Picture = LoadPicture(GetFile)
    
End Sub

' Speichern
Private Sub mnuSave_Click()

    Call SavePicture(Picture1.Image, GetFile)
    
End Sub

' Initialisieren
Private Sub Form_Load()

    Call Stream.Initialize(Picture1)
    
End Sub

' Datei aus Dialog lesen
Private Function GetFile() As String

    With dlgFiles
    
        .InitDir = CurDir
        .ShowOpen
        GetFile = .FileName
        
    End With
    
End Function

' ----- Ende Formular "frmStegano" alias frmStegano.frm  -----
' ------- Anfang Modul "mdlCrypt" alias mdlStegano.bas -------
Option Explicit

' Farbe in RGB umwandeln
Private Sub ToRGB(ByVal Color As Long, ByRef r As Long, ByRef g As Long, _
    ByRef b As Long)
    
    r = Color And &HFF&
    g = (Color And &HFF00&) \ &H100&
    b = (Color And &HFF0000) \ &H10000
    
End Sub

' Zahl in Ziffern (Hunterter, Zehner, Einer) umwandeln
Private Sub ToCiphers(ByVal Value As Long, ByRef h As Long, ByRef t As Long, _
    ByRef o As Long)
    
    h = Value \ 100
    t = (Value - h * 100) \ 10
    o = Value Mod 10
    
End Sub

' Farbe mit Wert kombinieren
Public Function EncryptColor(ByVal Color As Long, ByVal Value As Long) As Long

    Dim r As Long, g As Long, b As Long    ' RGB der Originalfarbe
    Dim h As Long, t As Long, o As Long    ' Ziffern des Wertes
    
    Call ToRGB(Color, r, g, b)
    Call ToCiphers(Value, h, t, o)
    
    ' Überlauf der Farbkomponenten vermeiden
    r = IIf(r > 244, 244, r)
    g = IIf(g > 253, 253, g)
    b = IIf(b > 244, 244, b)
    
    ' Farbkomponenten mit Stellen des Wertes addieren
    r = r + t
    g = g + h
    b = b + o
    
    ' Farbe zusammensetzen
    EncryptColor = RGB(r, g, b)
    
End Function

' Wert aus Farben rekonstruieren
Public Function DecryptColor(ByVal Color As Long, ByVal Original As Long) As _
    Long
    
    Dim r1 As Long, g1 As Long, b1 As Long ' Quellkomonenten
    Dim r2 As Long, g2 As Long, b2 As Long ' Verschlüsseltes RGB
    Dim h  As Long, t  As Long, o  As Long ' Die Stellen des Ergebnisses
    
    Call ToRGB(Original, r1, g1, b1)
    Call ToRGB(Color, r2, g2, b2)
    
    ' Überlaufschutz rekonstruieren
    r1 = IIf(r1 > 244, 244, r1)
    g1 = IIf(g1 > 253, 253, g1)
    b1 = IIf(b1 > 244, 244, b1)
    
    ' Differenz berechnen
    t = r2 - r1
    h = g2 - g1
    o = b2 - b1
    
    ' Wert zusammensetzen
    DecryptColor = 100 * h + 10 * t + o
    
End Function

' -------- Ende Modul "mdlCrypt" alias mdlStegano.bas --------
' --- Anfang Klasse "CryptoStream" alias CryptoStream.cls  ---
Option Explicit

' Verschlüsselungsklasse für die Steganographie in Pictureboxen
Private Pointer      As Long                          ' Zeiger
Private PositionX    As Long, PositionY      As Long  ' Entsprechende
                                                      ' x/y-Koordinaten
Private PictureBox   As PictureBox                    ' Quell/Zielpicturebox

' Ein Pixel an die aktuelle Position schreiben
Public Sub WritePixel(ByVal Color As Long)

    PictureBox.PSet (PositionX, PositionY), Color
    
End Sub

' Ein Pixel von der aktuellen Position lesen
Public Function ReadPixel() As Long

    ReadPixel = PictureBox.Point(PositionX, PositionY)
    
End Function

' Entsprechendes Originalpixel lesen
Private Function ReadOriginalPixel(ByVal From As PictureBox) As Long

    ReadOriginalPixel = From.Point(PositionX, PositionY)
    
End Function

' Einen Wert versteckt schreiben
Public Sub WriteByte(ByVal Value As Long)

    Dim EncryptedColor As Long
    
    EncryptedColor = EncryptColor(ReadPixel, Value)
    
    Call WritePixel(EncryptedColor)
    Call Increment
    
End Sub

' Einen Wert lesen
Public Function ReadByte(ByVal picOriginal As PictureBox) As Long

    ReadByte = DecryptColor(ReadPixel, ReadOriginalPixel(picOriginal))
    
    Call Increment
    
End Function

' **********************************************************************
' Initialisieren
Public Sub Initialize(ByVal PicBox As PictureBox)

    Set PictureBox = PicBox
    
    Call SetPointer
    
End Sub

' Zeiger setzen
Public Sub SetPointer(Optional ByVal Pos As Long = 1)

    Pointer = Pos
    
    Call Calculate
    
End Sub

' Zeiger erhöhen
Public Sub Increment()

    Pointer = Pointer + 1
    
    Call Calculate
    
End Sub

' Positionen errechnen
Private Sub Calculate()

    PositionX = Pointer Mod PictureBox.ScaleWidth
    PositionY = Pointer \ PictureBox.ScaleWidth
    
End Sub

' ---- Ende Klasse "CryptoStream" alias CryptoStream.cls  ----
' -------------- Ende Projektdatei Projekt1.vbp --------------