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:
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: Dieser Tipp wurde bereits 11.620 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
sevOutBar 4.0 Vertikale Menüleisten á la Outlook Erstellen von Outlook ähnlichen Benutzer- interfaces - mit beliebig vielen Gruppen und Symboleinträgen. Moderner OfficeXP-Style mit Farbverläufen, Balloon-Tips, u.v.m. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
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. |