Tisk textu zarovnaného do bloku

Postup:
Na formulář přidejte PictureBox. Pak vložte následující kód:

Private Sub PrintJust(Text As String, Target As Object)

   Dim i As Long
   Dim WordWidth As Long
   Dim NumWords As Long
   Dim LineWidth As Long
   Dim StartLine As Long
   Dim StopLine As Long
   Dim SpaceW As Long

   If Not TypeOf Target Is Printer And Not TypeOf Target Is Picture Then
      Exit Sub
   End If

   If Trim(Text) = "" Then
      Target.Print
      Exit Sub
   End If

   Text = Replace(Text, "<b>", Chr(1), 1, -1, vbTextCompare)
   Text = Replace(Text, "</b>", Chr(2), 1, -1, vbTextCompare)
   Text = Replace(Text, "<u>", Chr(3), 1, -1, vbTextCompare)
   Text = Replace(Text, "</u>", Chr(4), 1, -1, vbTextCompare)
   Text = Replace(Text, "<i>", Chr(5), 1, -1, vbTextCompare)
   Text = Replace(Text, "</i>", Chr(6), 1, -1, vbTextCompare)

   Target.FontBold = False
   Target.FontItalic = False
   Target.FontUnderLine = False

   LineWidth = 0
   WordWidth = 0
   NumWords = 0
   StartLine = 1
   SpaceW = 0
   i = 1

   Do While StartLine <= Len(Text)
      Select Case Mid(Text, i, 1)
         Case Chr(1)
            Target.FontBold = True
         Case Chr(2)
            Target.FontBold = False
         Case Chr(3)
            Target.FontUnderLine = True
         Case Chr(4)
            Target.FontUnderLine = False
         Case Chr(5)
            Target.FontItalic = True
         Case Chr(6)
            Target.FontItalic = False
         Case " ", ""
            SpaceW = SpaceW + Target.TextWidth(" ")
            If LineWidth + WordWidth + SpaceW > Target.ScaleWidth Then
               If NumWords > 0 Then
                  PrintLine Mid(Text, StartLine, StopLine - StartLine + 1), _
                  (Target.ScaleWidth - LineWidth) / (NumWords - 1), Target
               Else
                  PrintLine Mid(Text, StartLine, StopLine - StartLine + 1), 0, Target
               End If
               Target.Print
               StartLine = StopLine + 2
               LineWidth = 0
               NumWords = 0
               SpaceW = 0
            End If
            StopLine = i - 1
            LineWidth = LineWidth + WordWidth
            NumWords = NumWords + 1
            WordWidth = 0
         Case Else
            WordWidth = WordWidth + Target.TextWidth(Mid(Text, i, 1))
      End Select
      i = i + 1
   Loop

   Target.FontBold = False
   Target.FontItalic = False
   Target.FontUnderLine = False
   PrintLine "", 0, Target

End Sub

Private Sub PrintLine(Text As String, SpaceWidth As Single, Target As Object)

   Dim i As Integer
   Dim cx As Single
   Dim OldBold As Boolean
   Dim OldUnderLine As Boolean
   Dim OldItalic As Boolean
   Static FontBold As Boolean
   Static FontUnderLine As Boolean
   Static FontItalic As Boolean

   OldBold = Target.FontBold
   OldUnderLine = Target.FontUnderLine
   OldItalic = Target.FontItalic
   Target.FontBold = FontBold
   Target.FontUnderLine = FontUnderLine
   Target.FontItalic = FontItalic
   cx = 0

   For i = 1 To Len(Text)
      Select Case Mid(Text, i, 1)
         Case Chr(1)
            Target.FontBold = True
         Case Chr(2)
            Target.FontBold = False
         Case Chr(3)
            Target.FontUnderLine = True
         Case Chr(4)
            Target.FontUnderLine = False
         Case Chr(5)
            Target.FontItalic = True
         Case Chr(6)
            Target.FontItalic = False
         Case " "
            cx = cx + SpaceWidth
            Target.CurrentX = cx
         Case Else
            Target.Print Mid(Text, i, 1);
            cx = cx + Target.TextWidth(Mid(Text, i, 1))
      End Select
   Next

   FontBold = Target.FontBold
   FontUnderLine = Target.FontUnderLine
   FontItalic = Target.FontItalic
   Target.FontBold = OldBold
   Target.FontUnderLine = OldUnderLine
   Target.FontItalic = OldItalic

End Sub

Private Sub Picture1_Click()

   Dim Var As String

   Picture1.Cls
   Var = "Tento kód umožňuje tisk textu zarovnaného do bloku, lze používat HTML Tagy pro specifikaci
   <b>tučného písma</b>, <i>kurzívy</i> nebo <u>podtržené písmo</u>...Doufám, že se vám to bude
   zamlouvat."
   Call PrintJust(Var, Picture1)
   Call PrintJust("", Picture1)
   Call PrintJust("Nazdar,", Picture1)
   Call PrintJust(" ", Picture1)
   Var = "<b>Dnes</b>, po dlouhé době jsem se zmohl zase na nějaké aktualizace (konečně). <i>
   Je totiž čím dál víc těžší něco nového vymýšlet, protože jednak je venku VB.NET a jednak už 
   je toho plno popsáno</i>. Navíc mám spoustu práce. <b><i>A nakoupil jsem nějaký speciální 
   komponenty, tak testuju jak fungujou.</i></b>"
   Call PrintJust(Var, Picture1)
   Call PrintJust("", Picture1)
   Call PrintJust("Veškerý tento text by měl být zarovnán do bloku. Pokud chcete místo PictureBoxu 
   použít tiskárnu, stačí změnit <b>'picture1'</b> na <b>'printer'</b> v argumentech procedury
   <i>'PrintJust'</i>.", Picture1)

End Sub

Zpět