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. Zum betrachten des Anaglyph-Bildes benötigen Sie eine Rot/Grün- oder Rot/Cyan-Brille. Weitere Stereo-Bilder und eine Anleitung finden Sie unter Bilder | 3D-Stereo.

Projekt - Download
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code
Option Explicit
 
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() PicDummy4.Picture = LoadPicture(App.Path & "/Links.jpg") PicDummy5.Picture = LoadPicture(App.Path & "/Rechts.jpg") End Sub
Private Sub Command1_Click() Dim i%, j%, col$, col1&, col2&, col3& Hinweis.Visible = True Screen.MousePointer = 11 PicDatei.Picture = LoadPicture("") PicDatei.Width = PicDummy4.Width PicDatei.Height = PicDummy4.Height PicDummy.Picture = LoadPicture("") PicDummy.Width = PicDummy4.Width PicDummy.Height = PicDummy4.Height PicDummy2.Picture = LoadPicture("") PicDummy2.Width = PicDummy4.Width PicDummy2.Height = PicDummy4.Height PicDummy3.Picture = LoadPicture("") PicDummy3.Width = PicDummy4.Width PicDummy3.Height = PicDummy4.Height PicDummy4.AutoRedraw = True PicDummy5.AutoRedraw = True PicDummy.AutoRedraw = True PicDummy2.AutoRedraw = True PicDummy3.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 col = RGB(G(col1), G(col1), G(col1)) Next j Next i Screen.MousePointer = 0 Select Case MsgBox("Möchten Sie ein Rot-Cyan" & vbCrLf & _ "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 ' Tools.WinPos PicDatei.AutoRedraw = True '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 ' PicDummy3.BackColor = vbWhite 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
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