Im Tipp Ersatz für die VB6-LoadPicture-Funktion werden Bild-Dateien durch GDIPlus geladen und über das Bild-Handle unter Verwendung der Funktion 'OLECREATEPICTUREINDIRECT' in ein VB-Picture-Objekt umgewandelt. Dabei können Informationen verloren gehen - z.B. die Transparenz-Information bei entsprechenden GIF-Bildern. Einen direkteren Weg zum Laden von Bildern durch 'GDIPlus' bietet das Zeichnen in eine VB.PictureBox unter Verwendung des Gerätekontexts dieses Objekts. Bei dieser Vorgehensweise gehen weniger Bild-Informationen verloren - nur diejenigen, die von der VB.PictureBox nicht unterstützt werden können. ' ============================================================== ' Start Quellcode modLoadPicBox ' ============================================================== Option Explicit ' Bilddatei per 'GDIPlus.DLL' in 'VB.PictureBox' laden ' =============================================================== ' Benötigte GDIPlus-Deklarationen zum Laden/Zeichnen eines Bildes ' =============================================================== Private Type GDIPlusStartupInput Version As Long etctetera(1 To 12) As Byte End Type ' Verbindung herstellen Private Declare Function GdiplusStartup Lib "gdiplus" ( _ ByRef GDIP_Connection As Long, _ ByRef udtInput As GDIPlusStartupInput, _ Optional ByRef udtOutput As Any) As Long ' Verbindung zum DeviceKontext herstellen Private Declare Function GdipCreateFromHDC Lib "gdiplus" ( _ ByVal hDC As Long, _ ByRef Graphics As Long) As Long ' Bild aus Datei laden (in Bitmap) Private Declare Function GdipLoadImageFromFile Lib "gdiplus" ( _ ByVal FileName As Long, _ ByRef image As Long) As Long ' Abmessungen des Bildes ermitteln Private Declare Function GdipGetImageDimension Lib "gdiplus" ( _ ByVal image As Long, _ ByRef Width As Single, _ ByRef Height As Single) As Long ' Bild zeichnen Private Declare Function GdipDrawImageRect Lib "gdiplus" ( _ ByVal Graphics As Long, _ ByVal image As Long, _ ByVal X As Single, _ ByVal Y As Single, _ ByVal Width As Single, _ ByVal Height As Single) As Long ' Bild-Ressource freigeben Private Declare Function GdipDisposeImage Lib "gdiplus" ( _ ByVal image As Long) As Long ' Graphik-Ressource freigeben Private Declare Function GdipDeleteGraphics Lib "gdiplus" ( _ ByVal Graphics As Long) As Long ' GDIPLus freigeben Private Declare Function GdiplusShutdown Lib "gdiplus" ( _ ByVal token As Long) As Long Public Function LoadPicBox(ByVal DateiName As String, _ ByRef PicBox As VB.PictureBox, _ Optional ByVal AdjustPicBoxSize As Boolean = True, _ Optional ByRef Meldung As String) As Boolean ' Öffnet die Bilddatei 'DateiName' und trägt sie ' unter Verwendung des Gerätekontexts der Picturebox ' in die Zeichenfläche der PictureBox ein ' Falls AdjustPicBoxSize = true ' die Picturebox wird ggf. vergrößert, ' um das gesamte Bild zeichnen zu können Dim retcode As Long ' Funktions-Rückgaben Dim Bitmap As Long Dim Graphics As Long Dim picWidth As Single ' Bildabmessungen Dim picHeight As Single Dim GDIP_Connection As Long ' Verbindung zu GDIPlus Dim GDIP_Startup As GDIPlusStartupInput Dim w As Long, h As Long ' Bildgröße in Twips On Error GoTo exitfunction Err.Clear If Trim(DateiName) = "" Or PicBox Is Nothing Then Meldung = "Eingabeparameter fehlen" Exit Function End If If Dir(DateiName, vbNormal Or vbReadOnly) = "" Then Meldung = "Datei existiert nicht" Exit Function End If Meldung = "" GDIP_Startup.Version = 1 retcode = GdiplusStartup(GDIP_Connection, GDIP_Startup, ByVal 0&) If retcode <> 0 Then Meldung = "GDIPlus nicht verfügbar" Exit Function End If ' Trägt das Bild aus der Datei in die Bitmap ein retcode = GdipLoadImageFromFile(StrPtr(DateiName), Bitmap) If retcode <> 0 Then Meldung = "Bitmap kann nicht geöffnet werden" GoTo exitfunction End If ' Abfrage der Abmessungen der Bitmap retcode = GdipGetImageDimension(Bitmap, picWidth, picHeight) If retcode <> 0 Then Meldung = "Bitmap-Abmessungen nicht verfügbar" GoTo exitfunction End If ' PictureBox einrichten und ggf. ' auf die benötigten Bildabmessungen einstellen With PicBox .AutoRedraw = True .BorderStyle = 0 .Picture = LoadPicture() 'PictureBox löschen If AdjustPicBoxSize Then ' Skala: Pixel --> Twips umrechnen w = .ScaleX(picWidth, vbPixels, vbTwips) h = .ScaleY(picHeight, vbPixels, vbTwips) ' PictureBox-Arbeitsfläche ggf. vergrößern If .Width < w Then .Width = w If .Height < h Then .Height = h End If End With ' Erzeugen eines GDIPlus Grafikobjekts ' für die Verwendung mit Hdc retcode = GdipCreateFromHDC(PicBox.hDC, Graphics) If retcode <> 0 Then Meldung = "Graphikobjekt nicht verfügbar" GoTo exitfunction End If ' Bitmap in die PictureBox zeichnen retcode = GdipDrawImageRect(Graphics, Bitmap, 0, 0, picWidth, picHeight) If retcode <> 0 Then Meldung = "Bild kann nicht gezeichnet werden" GoTo exitfunction End If ' Rückgabe: alles OK Meldung = "" LoadPicBox = True exitfunction: ' Fehler ? If Err.Number <> 0 Then Meldung = Err.Description End If ' Ressourcen und GDIPLus freigeben If Bitmap <> 0 Then ' Bitmap löschen GdipDisposeImage Bitmap End If If Graphics <> 0 Then ' GDIPLus-Grafikobjekt löschen GdipDeleteGraphics Graphics End If If GDIP_Connection <> 0 Then ' GDIPlus-DLL freigeben GdiplusShutdown GDIP_Connection End If End Function ' ============================================================== ' Ende Quellcode 'modLoadPicBox' ' ============================================================== Aufruf-Beispiel (in einem Formular): ' Bild_Datei: Pfad und Dateiname eines Bildes (BMP, JPG, GIF, PNG, TIF) ' Picture1: Name einer VB.PictureBox Dim Meldung As String If Not LoadPicBox(Bild_Datei, Picture1, , Meldung) Then MsgBox Meldung, vbExclamation End If Dieser Tipp wurde bereits 33.443 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. |
Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 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. |