War es schon immer ihr Traum, Ihren eigenen Webbrowser zu programmieren? Sind sie dann immer über Probleme bei der Anzeige ohne Fremdcontrols gestolpert? Schreiben sie sich ihr Control selbst! Nun ja, ganz so komfortable wie es das WebBrowser-Control macht, ist nachfolgender Code (noch) nicht - aber die HTML-Grundfunktionen wie Schriftfarbe, Größe, Aufzählung usw. werden schon unterstützt. Und so geht's: Option Explicit ' Schrift Private Type myFont Name As String Size As Byte Bold As Boolean Italic As Boolean Underline As Boolean Color As Long End Type Private Sub Command1_Click() ' Bildfeld löschen Picture1.Cls ' HTML-Code erzeugen und anzeigen DrawHTML Picture1, Text1.Text End Sub ' Wandelt HTML-Code entsprechend um und zeigt diesen ' in einer PictureBox an. Sub DrawHTML(Pic As PictureBox, ByVal HCode As String) Dim I As Long Dim aC As String Dim T As String Dim aX As Long Dim aY As Long Dim R As String Dim n As Long Dim aEinzug As Long Dim aFont() As myFont Dim aFontID As Long Dim LLW As Long Dim aLW As Long ' Zeilenhöhe ReDim aFont(0) As myFont HCode = Replace(HCode, vbCrLf, " ") With aFont(0) .Name = "Times New Roman" .Size = 12 .Bold = False .Italic = False .Underline = False .Color = vbBlack End With setFont Pic, aFont(0) aEinzug = 2 aX = aEinzug Do I = I + 1 aC = Mid(HCode, I, 1) Select Case aC Case "<" ' <a href=""> [...] aC = Mid(HCode, I) aC = Left(aC, InStr(1, aC, ">")) I = I + Len(aC) - 1 If InStr(1, aC, " ") Then T = Left(aC, InStr(1, aC, " ") - 1) & ">" R = Right(aC, Len(aC) - Len(T)) R = Left(R, Len(R) - 1) Else T = aC R = vbNullString End If T = Right(T, Len(T) - 1) T = Left(T, Len(T) - 1) Select Case T Case "b" ' Fett Pic.Font.Bold = True Case "/b" Pic.Font.Bold = False Case "i" ' Kursiv Pic.Font.Italic = True Case "/i" Pic.Font.Italic = False Case "u" ' Unterstrichen Pic.Font.Underline = True Case "/u" Pic.Font.Underline = False Case "p" ' Neuer Absatz aX = aEinzug aY = aY + Pic.TextHeight("fg") * 2 Case "/p" ' ignorieren Case "pre" ' Unformatiert GoSub NewLine Pic.Font.Name = "Courier New" Case "/pre" GoSub NewLine Pic.Font.Name = aFont(aFontID).Name Case "blockquote" ' Zitat aEinzug = aEinzug + 12 Pic.Font.Italic = True aX = aEinzug Case "/blockquote" Pic.Font.Italic = False aEinzug = aEinzug - 12 aX = aEinzug Case "ul" ' Aufzählung Umfassung GoSub NewLine aEinzug = aEinzug + 15 Case "/ul" GoSub NewLine aEinzug = aEinzug - 15 Case "li" ' Aufzählung Punkt GoSub NewLine Pic.DrawWidth = 4 Pic.PSet (aX - 4, aY + Pic.TextHeight("fg") / 2), vbBlack Pic.DrawWidth = 1 Case "/li" ' ignorieren Case "br" ' Zeilenumbruch GoSub NewLine Case "font" ' Schriftart GoSub NewFont initFont R, aFont(aFontID) setFont Pic, aFont(aFontID) Case "/font" GoSub OldFont Case "h1" ' Überschrift #1 GoSub NewLine GoSub NewFont With aFont(aFontID) .Bold = True .Size = 18 .Italic = True End With setFont Pic, aFont(aFontID) Case "/h1" GoSub OldFont Case "a" ' Link GoSub NewFont With aFont(aFontID) .Color = vbBlue .Underline = True End With setFont Pic, aFont(aFontID) Case "/a" GoSub OldFont End Select Case Else Pic.CurrentX = aX Pic.CurrentY = aY Pic.Print aC aX = aX + Pic.TextWidth(aC) If Pic.TextHeight(aC) > aLW Then aLW = Pic.TextHeight(aC) End If aC = vbNullString End Select Loop While I < Len(HCode) Exit Sub NewLine: ' Beginnt neue Zeile aX = aEinzug aY = aY + aLW LLW = aLW aLW = 0 Return NewFont: ' Beginnt neue Schrift aFontID = aFontID + 1 ReDim Preserve aFont(aFontID) As myFont aFont(aFontID) = aFont(aFontID - 1) Return OldFont: ' Welchselt zur alten Schrift aFontID = aFontID - 1 ReDim Preserve aFont(aFontID) As myFont setFont Pic, aFont(aFontID) Return End Sub ' ------ HILFSFUNKTIONEN Private Sub setFont(Pic As PictureBox, F As myFont) With Pic.Font .Name = F.Name .Size = F.Size .Bold = F.Bold .Italic = F.Italic .Underline = F.Underline Pic.ForeColor = F.Color End With End Sub Private Sub initFont(R As String, F As myFont) Dim V As Variant Dim I As Long Dim S1 As String Dim S2 As String V = SplitS(R) For I = 0 To UBound(V) If Len(V(I)) > 3 Then S1 = Left(V(I), InStr(1, V(I), "=") - 1) S2 = Mid(V(I), Len(S1) + 2) S2 = Replace(S2, """", vbNullString) Select Case S1 Case "face", "name" If InStr(1, S2, ",") Then S2 = Left(S2, InStr(1, S2, ",") - 1) End If F.Name = S2 Case "size" F.Size = getSize(S2) Case "color" F.Color = Hex2Lng(S2) End Select End If Next I End Sub Private Function Hex2Lng(H As String) As Long If Left(H, 1) = "#" Then ' HEX Hex2Lng = RGB(CLng("&H" & Mid(H, 2, 2)), _ CLng("&H" & Mid(H, 4, 2)), _ CLng("&H" & Mid(H, 6, 2))) Else Select Case H Case "red" Hex2Lng = vbRed Case "yellow" Hex2Lng = vbYellow Case "green" Hex2Lng = vbGreen Case "blue" Hex2Lng = vbBlue Case "white" Hex2Lng = vbWhite Case "black" Hex2Lng = vbBlack Case Else Hex2Lng = vbBlack End Select End If End Function Function getSize(sStr As String) As Byte Select Case sStr Case "1", "+1" getSize = 8 Case "2", "+2" getSize = 10 Case "3", "+3" getSize = 12 Case "4", "+4" getSize = 14 Case "5", "+5" getSize = 18 Case "6", "+6" getSize = 24 Case "7", "+7" getSize = 36 Case Else getSize = 12 End Select End Function Function SplitS(Str As String, _ Optional Tr As String = " ") Dim I As Long Dim V() As Variant Dim A As String Dim G As Boolean Dim VC As Long ReDim V(0) As Variant For I = 1 To Len(Str) A = Mid(Str, I, 1) If A = """" Then G = Not G Else If A = " " And G = False Then VC = VC + 1 ReDim Preserve V(VC) As Variant Else V(VC) = V(VC) & A End If End If Next I SplitS = V End Function Nach dem Start des Programmes können Sie einen mehr oder weniger beliebigen Quellcode eingeben. Der hier gezeigte Code enthält Grundfunktionen wie Fett, Schriftgröße und -art etc. Dieser Tipp wurde bereits 18.248 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. |
TOP! Unser Nr. 1 Neu! sevDataGrid 3.0 Mehrspaltige Listen, mit oder ohne DB-Anbindung. Autom. Sortierung, Editieren von Spalteninhalten oder das interaktive Hinzufügen von Datenzeilen sind ebenso möglich wie das Erstellen eines Web-Reports. 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 Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |