Grafik in RGB-Kanäle trennen Mit diesem Script werden zwei Stereo-Bilder in RGB-Kanäle getrennt und als 3D-Anaglyph-Bild wieder zusammengestellt.
Autor:   Jürgen Fienau	Bewertung:	Views:  12.230
computer.net-berlin.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Mit diesem Script werden zwei Stereo-Bilder in RGB-Kanäle getrennt und als 3D-Anaglyph-Bild wieder zusammengestellt. Zum betrachten des Anaglyph-Bildes benötigen Sie eine Rot/Grün- oder Rot/Cyan-Brille.

Erstellen Sie ein neues Projekt mit folgenden Controls:

• CommandButton (Command1) mit Caption "Anaglyph wandeln"
• PictureBox (picDatei) mit integriertem Label-Control (lblHinweis) und Caption "Anaglyph-Bild wird zusammengestellt", Visible = False
• PictureBox (picDummy4) für Stereobild links und PictureBox (picDummy5) für Stereobild rechts
• 3 x PictureBox (picDummy, picDummy2 und picDummy3) für die Anzeige der Farbkanäle rot, grün und blau

Fügend Sie jetzt noch nachfolgenden Code ein:

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Function GetPixel Lib "gdi32" ( _
  ByVal hDC As Long, _
  ByVal x1 As Long, _
  ByVal y1 As Long) As Long
 
Private Declare Function SetPixel Lib "gdi32" ( _
  ByVal hDC As Long, _
  ByVal x As Long, _
  ByVal y As Long, _
  ByVal crColor As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal ByteLen As Long)
 
Private Declare Function GetSysColor Lib "user32" ( _
  ByVal nIndex As Long) As Long
 
Private Type OLECOLOR
  RedOrSys As Byte
  Green As Byte
  Blue As Byte
  Type As Byte
End Type

Private Sub Form_Load()
  ' Stereobilder laden und anzeigen
  PicDummy4.Picture = LoadPicture(App.Path & "/Links.jpg")
  PicDummy5.Picture = LoadPicture(App.Path & "/Rechts.jpg")
End Sub

Private Sub Command1_Click()
  ' Anaglyph wandeln
  Dim i As Long
  Dim j As Long
  Dim col As Long
  Dim col1 As Long
  Dim col2 As Long
  Dim col3 As Long
 
  ' Hinweis-Label sichtbar machen
  Hinweis.Visible = True
  Screen.MousePointer = 11
 
  ' Größe der PictureBox'en anpassen
  SetPictureSize PicDatei, PicDummy4, True
  SetPictureSize PicDummy, PicDummy4, True
  SetPictureSize PicDummy2, PicDummy4, True
  SetPictureSize PicDummy3, PicDummy4, True
 
  PicDummy4.AutoRedraw = True
  PicDummy5.AutoRedraw = True
 
  ' R-Bild splitten
  For i = 0 To PicDummy4.ScaleWidth
    For j = 0 To PicDummy4.ScaleHeight
      col1 = GetPixel(PicDummy4.hDC, i, j)
      col = RGB(r(col1), r(col1), r(col1))
      SetPixel PicDummy.hDC, i, j, col ' R
    Next j
  Next i
  Screen.MousePointer = 0
 
  Select Case MsgBox("Möchten Sie ein Rot-Cyan Bild erstellen?", vbYesNo + vbQuestion, "Anaglyph-Bild")
    Case vbYes
      Screen.MousePointer = 11
 
      ' GB-Bilder splitten
      For i = 0 To PicDummy5.ScaleWidth
        For j = 0 To PicDummy5.ScaleHeight
          col1 = GetPixel(PicDummy5.hDC, i, j)
          col = RGB(G(col1), G(col1), G(col1))
          SetPixel PicDummy2.hDC, i, j, col ' G
          col = RGB(B(col1), B(col1), B(col1))
          SetPixel PicDummy3.hDC, i, j, col ' B
        Next j
      Next i
 
    Case vbNo
      Screen.MousePointer = 11
 
      ' G-Bild splitten
      For i = 0 To PicDummy5.ScaleWidth
        For j = 0 To PicDummy5.ScaleHeight
          col1 = GetPixel(PicDummy5.hDC, i, j)
          col = RGB(G(col1), G(col1), G(col1))
          SetPixel PicDummy2.hDC, i, j, col ' G
        Next j
      Next i
 
      ' B-Bild schwärzen
      PicDummy3.BackColor = vbBlack
      PicDummy3.Picture = PicDummy3.Image
  End Select
 
  ' RGB-Bilder zusammenfügen
  For i = 0 To PicDatei.ScaleWidth
    For j = 0 To PicDatei.ScaleHeight
      col1 = GetPixel(PicDummy.hDC, i, j)  ' R
      col2 = GetPixel(PicDummy2.hDC, i, j) ' G
      col3 = GetPixel(PicDummy3.hDC, i, j) ' B
      col = RGB(r(col1), G(col2), B(col3))
      SetPixel PicDatei.hDC, i, j, col
    Next j
  Next i
 
  PicDatei.Refresh
  PicDatei.AutoRedraw = False
 
  PicDummy4.AutoRedraw = False
  PicDummy4.Cls
 
  PicDummy5.AutoRedraw = False
  PicDummy5.Cls
 
  PicDummy.AutoRedraw = False
  PicDummy.Cls
 
  PicDummy2.AutoRedraw = False
  PicDummy2.Cls
 
  PicDummy3.AutoRedraw = False
  PicDummy3.Cls
 
  Screen.MousePointer = 0
  Hinweis.Visible = False
End Sub

Function WinColor(VBColor As Long) As Long
  Dim SysClr As OLECOLOR
 
  CopyMemory SysClr, VBColor, Len(SysClr)
 
  If SysClr.Type = &H80 Then
    ' Es ist eine Systemfarbe
    WinColor = GetSysColor(SysClr.RedOrSys)
  Else
    ' Es ist keine Systemfarbe
    WinColor = VBColor
  End If
End Function

' Hilfsfunktionen
Public Function r(ByVal Color As Long) As Byte
  CopyMemory r, WinColor(Color), 1
End Function
 
Public Function G(ByVal Color As Long) As Byte
  CopyMemory G, ByVal VarPtr(WinColor(Color)) + 1, 1
End Function
 
Public Function B(ByVal Color As Long) As Byte
  CopyMemory B, ByVal VarPtr(WinColor(Color)) + 2, 1
End Function

Private Sub SetPictureSize(oDestPic As Object, oSourcePic As Object, _
  Optional ByVal bAutoRedraw As Variant)
 
  ' PictureBox-Größe anpassen
  With oDestPic
    .Picture = LoadPicture("")
    .Width = oSourcePic.Width
    .Height = oSourcePic.Height
    If Not IsMissing(bAutoRedraw) Then .AutoRedraw = bAutoRedraw
  End With
End Sub

Hinweis:
Weitere Stereo-Bilder und eine Anleitung finden Sie unter  www.web-computerecke.de - Rubrik Bilder | 3D-Stereo.
 

Copyright ©2000-2025 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.