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