HTML-Code in der PictureBox darstellen Dieser Tipp zeigt, wie sich HTML-Code parsen und in einer PictureBox anzeigen lässt.
Autor:   E7	Bewertung:	Views:  18.245
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

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:
Sie benötigen ein Formular mit einem Button (Command1), einem MultiLine-Textfeld (Text1) für die Eingabe des HTML-Codes, sowie ein Bildfeld (Picture1, AutoRedraw = True). Kopieren Sie dann folgenden Code vollständig in das Codefenster.

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.
 

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

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.