vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
NEU! sevCoolbar 3.0 - Professionelle Toolbars im modernen Design!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Grafik und Font · Sonstiges   |   VB-Versionen: VB4, VB5, VB610.10.05
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 FienauBewertung:     [ Jetzt bewerten ]Views:  10.064 
computer.net-berlin.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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.
 

Dieser Tipp wurde bereits 10.064 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle 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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel