Ovako.Na formu stavi jednu textbox kontrolu (Text1) i jednu picturebox kontrolu (Picture1), a zatim stavi ovo u modul.
Code:
Option Explicit
Public Enum qeFitPictureChar
eNone
eSpace
eDash
eLine
eOops
End Enum
Private Type qtFitPictureLine
sLine As String
eEnd As qeFitPictureChar
End Type
Public Function TextToPicture(Picture As PictureBox, sString As String) As Boolean
Dim tLine() As qtFitPictureLine
Dim iLine As Integer, iCount As Integer, iFont As Integer
Dim iSpace As Integer, iMarker As Integer
Dim sSizeX As Single, sSizeY As Single
Dim sHeight As Single, sWidth As Single, sArea As Single
Dim sLineHeight As Single, sCharWidth As Single
Dim sWord As String, sChar As String
Dim eCharType As qeFitPictureChar
Dim bNewLine As Boolean, bFound As Boolean
Dim sOffsetX As Single, sOffsetY As Single
Dim lForeColor As Long
Dim sborder As Long
sborder = 100 ' definise razmak od ivica
iSpace = StringCount(sString, vbCrLf)
With Picture
If sborder * 2 > .ScaleWidth Then
GoTo TextToPictureError
End If
If sborder * 2 > .ScaleHeight Then
Stop
End If
sWidth = .ScaleWidth - sborder * 2
sHeight = .ScaleHeight - sborder * 2
Do
iCount = 1
iLine = 1
ReDim tLine(1)
sWord = ""
Do
Do
eCharType = eNone
sChar = Mid$(sString, iCount, 1)
Select Case sChar
Case " "
eCharType = eSpace
Case "-"
sSizeX = .TextWidth(tLine(iLine).sLine & sWord & sChar)
If sSizeX > sWidth Then
eCharType = eOops
Else
eCharType = eDash
End If
Case vbLf
sChar = ""
eCharType = eLine
Case vbCr
If iCount < Len(sString) Then
If Mid$(sString, iCount + 1, 1) = vbLf Then
iCount = iCount + 1
End If
End If
sChar = ""
eCharType = eLine
Case Else
sSizeX = .TextWidth(tLine(iLine).sLine & sWord & sChar)
If sSizeX > sWidth Then
eCharType = eOops
Else
sWord = sWord & sChar
End If
End Select
iCount = iCount + 1
Loop While iCount <= Len(sString) And eCharType = eNone
bNewLine = False
Select Case eCharType
Case qeFitPictureChar.eNone
tLine(iLine).sLine = tLine(iLine).sLine & sWord
tLine(iLine).eEnd = eLine
Case qeFitPictureChar.eOops
If tLine(iLine).eEnd = eNone Then
tLine(iLine).sLine = sWord
sWord = sChar
Else
tLine(iLine).sLine = Trim$(tLine(iLine).sLine)
sWord = sWord & sChar
End If
bNewLine = True
Case qeFitPictureChar.eDash, qeFitPictureChar.eSpace
tLine(iLine).eEnd = eCharType
tLine(iLine).sLine = tLine(iLine).sLine & sWord & sChar
sWord = ""
Case qeFitPictureChar.eLine
tLine(iLine).sLine = tLine(iLine).sLine & sWord
tLine(iLine).eEnd = eLine
sWord = ""
bNewLine = True
End Select
If bNewLine Then
iLine = iLine + 1
ReDim Preserve tLine(iLine)
End If
Loop While iCount <= Len(sString)
bFound = CBool(iLine * .TextHeight("X") > sHeight)
If bFound Then
iFont = iFont - 1
End If
Loop While bFound
iCount = 1
.CurrentY = sborder + sOffsetY
Do
.CurrentX = sborder + sOffsetX
tLine(iCount).sLine = Trim(tLine(iCount).sLine)
If tLine(iCount).eEnd <> eLine Then
sCharWidth = .TextWidth(" ")
iSpace = 0
iMarker = 0
Do
iMarker = InStr(iMarker + 1, tLine(iCount).sLine, " ")
If iMarker > 0 Then
iSpace = iSpace + 1
End If
Loop While iMarker > 0
sSizeX = sWidth - .TextWidth(tLine(iCount).sLine)
bFound = False
If iSpace > 0 Then
If sSizeX \ iSpace > sCharWidth * 3 Then
bFound = True
End If
Else
bFound = True
End If
If bFound Then
sSizeY = Len(tLine(iCount).sLine) - 1 + (iSpace * 2)
sSizeY = sSizeX / sSizeY
sSizeX = sSizeY * 3
Else
sSizeX = sSizeX / iSpace
sSizeY = 0
End If
iMarker = 1
Do While iMarker <= Len(tLine(iCount).sLine)
sChar = Mid$(tLine(iCount).sLine, iMarker, 1)
sCharWidth = .CurrentX + .TextWidth(sChar)
sLineHeight = .CurrentY
Picture.Print sChar
If sChar = " " Then
sCharWidth = sCharWidth + sSizeX
Else
sCharWidth = sCharWidth + sSizeY
End If
.CurrentX = sCharWidth
.CurrentY = sLineHeight
iMarker = iMarker + 1
Loop
Picture.Print ""
Else
Picture.Print tLine(iCount).sLine
End If
iCount = iCount + 1
Loop While iCount <= iLine
End With
TextToPicture = True
Exit Function
TextToPictureError:
TextToPicture = False
End Function
Public Function StringCount(ByVal Expression As String, _
Item As String) As Integer
Dim lPosition As Integer
Dim lCount As Integer
Do
lPosition = InStr(lPosition + 1, Expression, Item)
If lPosition > 0 Then
lCount = lCount + 1
End If
Loop While lPosition > 0
StringCount = lCount
End Function
Poravnanje pozivaš na sledeći način
Code:
Dim eGreska As Boolean
eGreska = TextToPicture(Picture1, Text1.Text)
If eGreska = False Then MsgBox "Doslo je do greske prilikom poravnanja"
-Odracuonogakomijedrpiorazmaknicu.
-Ne rxdi mi txstxturx, kxd god hocu dx
ukucxm "x" onx ukucx "x".
-Ko kaaz e da ja neuummem da kuuca
m.
-Piše "Insert disk 3", a jedva sam i ova
dva ugurao u drajv
-Postoje samo dve osobe kojima
verujem, jedna sam ja, a druga nisi ti