Как печатать цветной текст с переносами?

cdl1.DialogPrompt = 'Printing: ' & lblText(acttext).Caption
cdl1.Flags = cdlPDAllPages
cdl1.CancelError = True
cdl1.ShowPrinter
If cdl1.errCancel = True Then Exit Sub
Printer.ScaleMode = vbCentimeters
Printer.CurrentX = 1
Printer.CurrentY = 1
 Printer.Font.Name = Text1.Font.Name
 Printer.Font.Size = Text1.Font.Size
 Printer.Font.Italic = Text1.Font.Italic
 Printer.Font.Strikethrough = Text1.Font.Strikethrough
 Printer.Font.Underline = Text1.Font.Underline
 Printer.ColorMode = vbPRCMColor
 Printer.FillStyle = vbFSTransparent
 Printer.ForeColor = Text1.ForeColor
 Printer.DrawMode = vbCopyPen
 Printer.DrawStyle = vbSolid
If Printer.TextWidth(Text1.Text) + 1 > Printer.ScaleWidth Then
    ret = MsgBox('Your text is larger than paper's width' & vbCrLf & 'Text will be printed with clipping.' & vbCrLf & 'Proceed?', vbCritical Or vbYesNo, 'DCP Print System')
If ret <> vbYes Then Exit Sub
End If
Printer.CurrentX = 0.2
Printer.CurrentY = 0.2
Printer.Print fname(acttext)
Printer.CurrentX = 1
Printer.CurrentY = 1
Printer.Print Text1.Text
Printer.EndDoc

Private Sub Command1_Click()
Printer.ColorMode = vbPRCMColor
Printer.ForeColor = vbRed
Printer.Print '!!!!!!!!!!!'
Printer.EndDoc
End Sub

Option Explicit
 
Private Const HWND_BROADCAST As Long = &HFFFF
Private Const WM_WININICHANGE As Long = &H1A
 
Private Declare Function GetProfileString Lib 'kernel32' _
   Alias 'GetProfileStringA' _
  (ByVal lpAppName As String, _
   ByVal lpKeyName As String, _
   ByVal lpDefault As String, _
   ByVal lpReturnedString As String, _
   ByVal nSize As Long) As Long
 
Private Declare Function WriteProfileString Lib 'kernel32' _
   Alias 'WriteProfileStringA' _
  (ByVal lpszSection As String, _
   ByVal lpszKeyName As String, _
   ByVal lpszString As String) As Long
 
Private Declare Function SendMessage Lib 'user32' _
   Alias 'SendMessageA' _
  (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lparam As Any) As Long
 
Private Sub Form_Load()
    ProfileLoadWinIniList List1, 'PrinterPorts'
    Command1.Enabled = False
End Sub
 
Private Sub Command1_Click()
    Call SetDefaultPrinterWinNT
End Sub
 
Private Sub List1_Click()
    Command1.Enabled = List1.ListIndex > -1
End Sub
 
Private Sub SetDefaultPrinter(ByVal PrinterName As String, _
                              ByVal DriverName As String, _
                              ByVal PrinterPort As String)
Dim DeviceLine As String
 
'Строим строку для принтера
DeviceLine = PrinterName & ',' & DriverName & ',' & PrinterPort
 
'Сохранить информацию о новом принтере в секции
'[WINDOWS] файла WIN.INI для ключа DEVICE=
Call WriteProfileString('windows', 'Device', DeviceLine)
 
'Заставить все приложения перезагрузить INI-файл
Call SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, ByVal 'windows')
 
End Sub
 
Private Sub GetDriverAndPort(ByVal Buffer As String, _
        DriverName As String, PrinterPort As String)
 
Dim posDriver As Long
Dim posPort As Long
DriverName = ''
PrinterPort = ''
 
'Имя драйвера идет вначале строки
posDriver = InStr(Buffer, ',')
 
If posDriver > 0 Then
    'Получение имени драйвера
    DriverName = Left(Buffer, posDriver - 1)
    'Имя порта идет после запятой
    posPort = InStr(posDriver + 1, Buffer, ',')
    
    If posPort > 0 Then
        'Получение имени порта
        PrinterPort = Mid(Buffer, posDriver + 1, _
                posPort - posDriver - 1)
    End If
End If
   
End Sub
 
'Создаем listbox из данных win.ini
Public Function ProfileLoadWinIniList(lst As ListBox, _
        lpSectionName As String) As Long
 
 Dim success As Long
 Dim nSize As Long
 Dim lpKeyName As String
 Dim ret As String
 
 ret = Space$(8102)
 nSize = Len(ret)
 success = GetProfileString(lpSectionName, vbNullString, _
        '', ret, nSize)
 
'Возращаемая строка является списком, разделенным
'нулевыми символами
 If success Then
  
    ret = Left$(ret, success)
    Do Until ret = ''
       lpKeyName = StripNulls(ret)
       lst.AddItem lpKeyName
    Loop
 
 End If
 
'вернем число принтеров (кол-во элементов)
ProfileLoadWinIniList = lst.ListCount
 
End Function
 
Private Function StripNulls(startstr As String) As String
 
Dim pos As Long
 
pos = InStr(startstr$, Chr$(0))
  
If pos Then
    StripNulls = Mid$(startstr, 1, pos - 1)
    startstr = Mid$(startstr, pos + 1, Len(startstr))
End If
 
End Function