Attribute VB_Name = "ModText"
' ModText.bas

Option Explicit
Option Base 1


Private Const EM_GETLINECOUNT = &HBA

Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Type TEXTMETRIC
   tmHeight As Long
   tmAscent As Long
   tmDescent As Long
   tmInternalLeading As Long
   tmExternalLeading As Long
   tmAveCharWidth As Long
   tmMaxCharWidth As Long
   tmWeight As Long
   tmOverhang As Long
   tmDigitizedAspectX As Long
   tmDigitizedAspectY As Long
   tmFirstChar As Byte
   tmLastChar As Byte
   tmDefaultChar As Byte
   tmBreakChar As Byte
   tmItalic As Byte
   tmUnderlined As Byte
   tmStruckOut As Byte
   tmPitchAndFamily As Byte
   tmCharSet As Byte
End Type

Private Declare Function GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" _
   (ByVal hDC As Long, ByRef lpMetrics As TEXTMETRIC) As Long

Private tm As TEXTMETRIC

Public tInternal As Long  'tInternal = tm.tmInternalLeading

Private Const FE_FONTSMOOTHINGCLEARTYPE As Long = &H2
Private Const NONANTIALIASED_QUALITY As Byte = 3
Private Const ANTIALIASED_QUALITY As Byte = 4
Private Const CLEARTYPE_QUALITY As Byte = 5 '6

Private Const LF_FACESIZE = 32
Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
'        lfFaceName(LF_FACESIZE - 1) As Byte
        lfFaceName As String * LF_FACESIZE
End Type
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private RotateFont As LOGFONT
'------------------------------------------------------------------------------

' Structures for GetDIBits
Private Type BITMAPINFOHEADER ' 40 bytes
   biSize As Long
   biWidth As Long
   biHeight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Private Type BITMAPINFO
   bmi As BITMAPINFOHEADER
   Colors(0 To 255) As RGBQUAD
End Type

Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
'Private Const DIB_PAL_COLORS = 1 '  system colors
' -----------------------------------------------------------
Private Declare Function GetDIBits Lib "gdi32" _
   (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
   ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long


Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDC As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hDC As Long) As Long
'----------------------------------------------------------------

Public TextColor As Long
Public wt As Long, ht As Long
Public Slant As Long
Public SlantX As Long
Public SlantY As Long

Public NumOfLines As Long
Public TIndex As Integer   ' Text1 index = 0 Single- & = 1 Multi-Line

Public TheFontName$
Public TheFontSize As Long
Public TheFontBold As Boolean
Public TheFontItalic As Boolean
Public TheFontUnderline As Boolean
Public TheFontStrikeThru As Boolean


Public ShadowFactor As Single
Public zangtext As Single
Public aText As Boolean
Public TextLine$(0 To 1) ' (0) Single- & = (1) Multi-Line
Public NSTOREXY As Long
Public STOREX() As Long, STOREY() As Long
Public xpred As Single, ypred As Single
Public bT() As Long '^^^^^^^^^^^
Public aClearType As Boolean

Dim CurFont As StdFont

Public Sub ShowText()
Dim xp As Single, yp As Single
Dim zAng As Single

   TextLine$(TIndex) = frmText.Text1(TIndex).Text
   If Len(TextLine$(TIndex)) = 0 Then
      frmText.picText.Picture = LoadPicture
      Exit Sub
   End If
   
'   wt = Len(TextLine$)
'   a$ = String$(wt, "FullW")
'   wt = picText.TextWidth(a$)
   
   With frmText.picText
      .Picture = LoadPicture
      .Cls
      .ForeColor = TextColor
      .FontName = TheFontName$
      .FontSize = TheFontSize
      .FontItalic = TheFontItalic
      .FontBold = TheFontBold
      .FontUnderline = TheFontUnderline
      .FontStrikethru = TheFontStrikeThru
   End With
   
   GetTextMetrics frmText.picText.hDC, tm
   tInternal = tm.tmInternalLeading + tm.tmExternalLeading

   
   If TIndex = 0 Then ' Single line
      wt = frmText.picText.TextWidth(TextLine$(TIndex)) + frmText.picText.TextWidth("W")
      ht = frmText.picText.TextHeight("_") + 8
      Slant = Sqr(ht ^ 2 + wt ^ 2) + 16 '8      ' Arbitrary ?
      If Slant < wt Then Slant = wt + frmText.picText.TextWidth("W")
      Slant = (Slant + 3) And &HFFFFFFFC ' Fix on 4 byte boundary
      frmText.LabPicSize = " Square size =" & Str$(Slant)
      SlantX = Slant
      SlantY = Slant
      ' Ensure rotated string within the slant*slant picbox
      zAng = zangtext * pi# / 180
      xp = Slant / 2 - wt / 2 * Cos(zAng) + ht / 2 * Sin(zAng)
      yp = Slant / 2 - ht / 2 * Cos(zAng) - wt / 2 * Sin(zAng)
      
   Else  ' TIndex = 1 Then ' MultiLine - no rotation
      NumOfLines = SendMessage(frmText.Text1(1).hwnd, EM_GETLINECOUNT, 0&, 0&)
      SlantX = frmText.picText.TextWidth(TextLine$(TIndex)) + 8
      SlantY = NumOfLines * frmText.picText.TextHeight("_") + 8
      SlantX = (SlantX + 3) And &HFFFFFFFC ' Fix on 4 byte boundary
      xp = 0
      yp = 8 'Avoid Right color @ 0,0
      zangtext = 0
      frmText.LabPicSize = " Size =" & Str$(SlantX) & " by" & Str$(SlantY)
      
   End If
   
   With frmText.picText
      .Width = SlantX * 1.05
      .Height = SlantY * 1.05
      .CurrentX = xp
      .CurrentY = yp - tInternal
   End With
   
   RotateText frmText.picText, zangtext, TextLine$(TIndex)
   If aClearType Then
      xpred = xp
      If TIndex = 0 Then
         ypred = yp - tInternal
      Else  ' Multi-line
         ypred = yp
      End If
   End If

End Sub


Private Sub RotateText(PIC As PictureBox, zangle As Single, TextLine$)
'NB NOT ALL FONTS CAN BE ROTATED
'PIC CurrentX & Y set
'Set rotation in tenths of a degree, i.e., 1800 = 180 degrees
'TextLine$ = Text2.Text

Dim rfont As Long
Dim CurFont As Long

   'Make +ve angles rotate clockwise
   RotateFont.lfEscapement = -zangle * 10
   'RotateFont.lfWidth = 10
   With RotateFont
      If PIC.FontBold Then .lfWeight = 1200 / 2 Else .lfWeight = 400 / 2
      If PIC.FontItalic Then .lfItalic = 1 Else .lfItalic = 0
      .lfUnderline = PIC.FontUnderline
      .lfStrikeOut = PIC.FontStrikethru
      .lfCharSet = 1   '0,1
      .lfOutPrecision = 0
      .lfFaceName = PIC.FontName & Chr$(0)
      .lfHeight = (PIC.FontSize * -20) / STY
      .lfWidth = 0 '(PIC.FontSize) * -7 / STX
      '.lfQuality = FE_FONTSMOOTHINGCLEARTYPE ' ClearType XP
      '.lfQuality = ANTIALIASED_QUALITY
      If ShadowFactor <> 0 Or Not aClearType Then
         .lfQuality = NONANTIALIASED_QUALITY
      Else  ' No effects
         'If zangle = 0 Then
         If aClearType Then
            .lfQuality = CLEARTYPE_QUALITY
         Else
            .lfQuality = NONANTIALIASED_QUALITY
         End If
      End If
   End With
   '------------------------------------
   rfont = CreateFontIndirect(RotateFont)
   CurFont = SelectObject(PIC.hDC, rfont)
   
   PIC.Print TextLine$;
   PIC.Refresh
   'Restore CurFont
   SelectObject PIC.hDC, CurFont
   DeleteObject rfont
   '------------------------------------
End Sub

'Private Sub GetTextBYTES(ByVal picIN As Long, bA() As Byte, LW As Long, LH As Long)
Public Sub GetTextBYTES(ByVal picIN As Long, bA() As Long, LW As Long, LH As Long)
' picIn = pixText.Image
' bA() = bT()
' LW & LH = slantx & slanty

Dim mHDC As Long, mBMPold As Long
Dim BS As BITMAPINFO
'Dim BytesPerScanLine As Long
'  Not nec since width is already multiple of 4
'  BytesPerScanLine = (bWidth + 3) And &HFFFFFFFC
   With BS.bmi
      .biSize = 40
      .biWidth = LW
      .biHeight = -LH ' As require for scanning
      .biPlanes = 1
      .biBitCount = 32 '8
   End With
   mHDC = CreateCompatibleDC(0)
   mBMPold = SelectObject(mHDC, picIN)
   GetDIBits mHDC, picIN, 0, LH, bA(1, 1), BS, 0
   SelectObject mHDC, mBMPold
   DeleteDC mHDC
   DeleteObject mBMPold

End Sub

Public Sub ShowTextOnPic(PIC As PictureBox, x As Single, y As Single)
' PIC = Form1.picDraw
Dim A$
Dim n As Long
   With PIC
      .ForeColor = TextColor
      .FontName = TheFontName$
      .FontSize = TheFontSize
      .FontItalic = TheFontItalic
      .FontBold = TheFontBold
      .FontUnderline = TheFontUnderline
      .FontStrikethru = TheFontStrikeThru
   End With
   
'   GetTextMetrics PIC.hDC, tm   ' Done in ShowText
'   tInternal = tm.tmInternalLeading
   
   If TIndex = 0 Then ' Single line
      With PIC
         .CurrentX = x - 1
         .CurrentY = y
      End With
      RotateText PIC, zangtext, TextLine$(TIndex)
      
   Else  ' TIndex = 1 Then ' MultiLine - no rotation
      zangtext = 0
      ' Prelims
      If Len(TextLine$(1)) = 0 Then
         NumOfLines = 0
         Exit Sub
      End If
      If Len(TextLine$(1)) = 2 Then
         A$ = Mid$(TextLine$(1), 1, 1)
         If Asc(A$) = 13 Then   ' CR LF
            NumOfLines = 0
            Exit Sub
         Else  ' AA  no CRLF
            NumOfLines = 1
            ReDim ARR$(1)
            ARR$(1) = TextLine$(1)
            PIC.CurrentX = x
            PIC.CurrentY = y
            RotateText PIC, zangtext, ARR$(n)
            Exit Sub
         End If
      End If
   
      ARR$ = Split(TextLine$(1), Chr$(13) + Chr$(10), -1, vbTextCompare)
      For n = 0 To UBound(ARR$)
         PIC.CurrentX = x
         PIC.CurrentY = y + n * PIC.TextHeight("W") - tInternal
         zangtext = 0
         ShadowFactor = 0
         RotateText PIC, zangtext, ARR$(n)
      Next n
   End If
End Sub

