vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Zippen wie die Profis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2015
 
zurück
Rubrik: HTML/Internet/Netzwerk · HTML/Email   |   VB-Versionen: VB4, VB5, VB609.12.02
HTML-Code in der PictureBox darstellen

Dieser Tipp zeigt, wie sich HTML-Code parsen und in einer PictureBox anzeigen lässt.

Autor:   E7Bewertung:     [ Jetzt bewerten ]Views:  13.782 
www.e7o.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8 Beispielprojekt auf CD 

Summer-Special bei Tools & Components!
Gute Laune Sommer bei Tools & Components
Top Summer-Special - Sparen Sie teilweise über 100,- EUR
Alle sev-Entwicklerkomponenten und Komplettpakete jetzt bis zu 25% reduziert!
zum Beispiel:
  • Developer CD nur 455,- EUR statt 569,- EUR
  • sevDTA 2.0 nur 224,30 EUR statt 299,- EUR
  •  
  • vb@rchiv   Vol.6 nur 18,70 EUR statt 24,95 EUR
  • sevCoolbar 3.0 nur 58,70 EUR statt 69,- EUR
  • - Werbung -Und viele weitere Angebote           Aktionspreise nur für kurze Zeit gültig

    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.
     

    Dieser Tipp wurde bereits 13.782 mal aufgerufen.

    Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

    Über diesen Tipp im Forum diskutieren
    Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

    Neue Diskussion eröffnen

    nach obenzurück


    Anzeige

    Kauftipp Unser Dauerbrenner!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.
     
       

    Druckansicht Druckansicht Copyright ©2000-2015 vb@rchiv Dieter Otter
    Alle 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.

    Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel