Public Sub PlotText(Obj As Object, _
ByRef X As Single, _
ByRef Y As Single, _
ByRef Angle As Single, _
ByRef Fontsize As Long, _
ByVal Txt As String, _
ByVal DrawMode As DrawModeConstants, _
ByVal color As Long _
)
Dim savedDC As Long
Dim Langle As Long
Dim new_font As Long, old_font As Long
Dim dl As Long _
'dummy to receive API returns
Dim iROP2 As Long
Dim usebrush As Long, oldbrush As Long
If Fontsize < 0 Then Exit Sub _
'guard against nonsense
Langle = CLng(Angle * 10) Mod 3600 _
'convert angle to a Long in tenths of a degree
savedDC = SaveDC(Obj.hdc) _
'save Device Context
new_font = CreateFont(Fontsize, FONT_WIDTH, _
Langle, FONT_ORIENTATION, _
FONT_WEIGHT, FONT_ITALIC, FONT_UNDERLINE, _
FONT_STRIKEOUT, _
ANSI_CHARSET, FONT_OUTPUT_PRECISION, _
FONT_CLIP_PRECISION, _
FONT_QUALITY, FONT_PITCH_N_FAMILY, FONT_NAME) _
'create the rotated font
old_font = SelectObject(Obj.hdc, new_font) _
'select the new font, and save the old font
' (Important)!
'set background mode to draw text with a transparent
' background
'...obj.FontTransparent does NOT work for this
dl = SetBkMode(Obj.hdc, TRANSPARENT)
dl = BeginPath&(Obj.hdc) _
'start saving graphics output into a Path
dl = TextOut(Obj.hdc, X, Y, Txt, Len(Txt)) _
'draw the text into the Path ... obj.Print does NOT
' work for this
dl = EndPath(Obj.hdc) _
'finish saving to the Path
dl = SelectObject(Obj.hdc, old_font) _
'restore the original font
dl = DeleteObject(new_font) _
'free font resources (important!)
'... if we wanted to transform the Path points we could
' do it here
'... see MSDN for the demo C program TEXTFX.EXE
'now draw and fill the saved path
'... we don't get any outlines with just FillPath()
iROP2 = SetROP2(Obj.hdc, DrawMode) _
'set the drawmode, e.g., R2_NOTXORPEN/vbNotXorPen
' for Xor drawing
usebrush = CreateSolidBrush(color) _
'set the text color, create a brush to for the text
' areas
oldbrush = SelectObject(Obj.hdc, usebrush) _
'select the new brush, and save the old brush
' (Important!)
dl = FillPath(Obj.hdc) _
'draw the text saved in the Path, without outlines
dl = SetROP2(Obj.hdc, iROP2) _
'restore the original draw mode
dl = SelectObject(Obj.hdc, oldbrush) _
'restore the original Brush
dl = DeleteObject(usebrush) _
'free Brush resources (Important!)
dl = RestoreDC(Obj.hdc, savedDC) _
'restore the original Device Context (Important)
End Sub
|
