forked from lee-soft/ViPad
-
Notifications
You must be signed in to change notification settings - Fork 0
/
ViText2.cls
154 lines (110 loc) · 4.39 KB
/
ViText2.cls
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "ViTextLayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Const BLUR_SCALE As Single = 5
Private m_width As Long
Private m_Y As Long
Private m_X As Long
Private m_textSize As Single
Private m_redrawRequested As Boolean
Private m_children As Collection
Private m_pth As GDIPGraphicPath
Private m_bitmap As GDIPBitmap
Private m_form As Form
Private Function HasChildrenChanged() As Boolean
Dim thisText As ViText
For Each thisText In m_children
If thisText.Changed Then
'Dont exit, because it resets all other children
HasChildrenChanged = True
End If
Next
End Function
Public Function CreateChild(ByVal szText As String, ByVal X As Long, ByVal Y As Long, Optional szFontFace As String = "Tahoma", Optional fontSize As Long = 9) As ViText
Dim thisChild As New ViText
m_children.Add thisChild
thisChild.Caption = szText
thisChild.FontFace = szFontFace
thisChild.Size = fontSize
thisChild.X = X
thisChild.Y = Y
Set CreateChild = thisChild
End Function
Public Property Let Parent(newForm As Form)
Set m_form = newForm
End Property
Public Function RedrawRequest() As Boolean
RedrawRequest = m_redrawRequested
m_redrawRequested = False
End Function
Private Function ReconstructPaths()
Dim thisChild As ViText
If m_form Is Nothing Then Exit Function
Set m_bitmap = New GDIPBitmap: m_bitmap.CreateFromSizeFormat m_form.ScaleWidth / BLUR_SCALE, m_form.ScaleHeight / BLUR_SCALE, PixelFormat.Format32bppArgb
Set m_pth = New GDIPGraphicPath: m_pth.Constructor FillModeWinding
Dim thisFontF As GDIPFontFamily
For Each thisChild In m_children
Set thisFontF = New GDIPFontFamily
thisFontF.Constructor (thisChild.FontFace)
m_pth.AddString thisChild.Caption, CreateFontFamily(thisChild.FontFace), FontStyle.FontStyleRegular, thisChild.Size, CreateRectF(thisChild.X, thisChild.Y, thisChild.Height, thisChild.Width), thisChild.StringFormat
Next
Dim G As New GDIPGraphics: G.FromImage m_bitmap.Image
Dim mx As New GDIPMatrix: mx.Constructor2 1# / BLUR_SCALE, 0, 0, 1# / BLUR_SCALE, 1# / BLUR_SCALE, 1# / BLUR_SCALE
'1.0f/5,0,0,1.0f/5,-(1.0f/5),-(1.0f/5)
G.SmoothingMode = SmoothingModeHighQuality
G.Transform mx
Dim p As New GDIPPen: p.Constructor CreateWebColour("FFFFF2"), 1, 128
G.DrawPath p, m_pth
G.FillPath Custom_Brush(CreateWebColour("FFFFF2")), m_pth
G.Dispose
End Function
Public Property Get Dimensions_Serialized() As String
Dimensions_Serialized = Serialize_RectL(Me.GenerateObjectRect)
End Property
Public Function GenerateObjectRect() As RECTL
Dim returnRect As RECTL
With returnRect
.Top = m_Y
.Left = m_X
.Height = 16
.Width = m_width
End With
GenerateObjectRect = returnRect
End Function
Public Function onMouseMove(MouseButton As Long, X As Single, Y As Single)
End Function
Public Function onMouseDown(MouseButton As Long, X As Single, Y As Single)
End Function
Public Function onMouseUp(MouseButton As Long, X As Single, Y As Single)
End Function
Public Function Draw(ByRef theGraphics As GDIPGraphics)
If m_form Is Nothing Then Exit Function
If m_bitmap Is Nothing Then ReconstructPaths
If HasChildrenChanged Then
ReconstructPaths
End If
theGraphics.DrawImageStretchAttrL m_bitmap.Image, _
CreateRectL(m_form.ScaleHeight, m_form.ScaleWidth, 0, 0), _
0, 0, m_bitmap.Image.Width, m_bitmap.Image.Height, UnitPixel, 0, 0, 0
'theGraphics.DrawImageStretchAttrL m_bitmap.Image, _
CreateRectL(m_form.ScaleHeight, m_form.ScaleWidth, 0, 0), _
0, 0, m_bitmap.Image.Width, m_bitmap.Image.Height, UnitPixel, 0, 0, 0
'theGraphics.DrawImageStretchAttrL m_bitmap.Image, _
CreateRectL(m_form.ScaleHeight, m_form.ScaleWidth, 0, 0), _
0, 0, m_bitmap.Image.Width, m_bitmap.Image.Height, UnitPixel, 0, 0, 0
theGraphics.FillPath Brushes_Black, m_pth
End Function
Private Sub Class_Initialize()
Set m_children = New Collection
End Sub