-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathgdipTextClock.bas
239 lines (201 loc) · 7.42 KB
/
gdipTextClock.bas
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
' Text Clock文字时钟
' Copyright (c) 2024 CM.Wang
' Freeware. Use at your own risk.
#include once "gdipTextClock.bi"
Private Constructor TextClock
WLet(mBackFile, "")
WLet(mFontName, WStr("Arial"))
WLet(mColon, WStr(":"))
mTxt.mFontStyle = mFontStyle
End Constructor
Private Destructor TextClock
If mFontName Then Deallocate mFontName
mFontName = NULL
If mBackFile Then Deallocate mBackFile
mBackFile = NULL
If mColon Then Deallocate mColon
mColon = NULL
If mDt Then Deallocate mDt
mDt = NULL
End Destructor
Private Sub TextClock.Release()
End Sub
Private Property TextClock.FileName(ByRef fFileName As WString)
WLet(mBackFile, fFileName)
mBackImage.ImageFile = *mBackFile
If Dir(*mBackFile) = "" Then
mBackScale = mTxtScale
Else
mBackScale = mBackImage.Height / mBackImage.Width
End If
End Property
Private Property TextClock.FileName() ByRef As WString
If mBackFile Then
Return *mBackFile
Else
Return ""
End If
End Property
Private Sub TextClock.TextFont(pName As WString, pStyle As FontStyle)
WLet(mFontName, pName)
mFontStyle = pStyle
End Sub
Private Sub TextClock.Background(ByVal pWidth As Single = 400, ByVal pHeight As Single = 300)
mWidth = pWidth
mHeight = pHeight
CalculateSize()
mBackBitmap.Initial(mWidth, mHeight)
Dim sTmpBitmap As gdipBitmap
If mPanelEnabled Then
sTmpBitmap.Initial(mWidth, mHeight)
GdipGraphicsClear(sTmpBitmap.Graphics, mPanelAlpha Shl 24 Or mPanelColor)
mBackBitmap.DrawImage(sTmpBitmap.Image, 0, 0)
End If
If mBackEnabled Then
sTmpBitmap.Initial(mWidth, mHeight)
sTmpBitmap.DrawScaleImage(mBackImage.Image)
If mBackBlur Then FastBoxBlurHV(sTmpBitmap.Image, mBackBlur)
mBackBitmap.DrawAlphaImage(sTmpBitmap.Image, mBackAlpha)
End If
If mOutlineEnabled Then
sTmpBitmap.Initial(mWidth, mHeight)
Dim sPen As GpPen Ptr
GdipCreatePen1((mOutlineAlpha Shl 24) Or mOutlineColor, mOutlineSize, UnitPixel, @sPen)
GdipDrawRectangle(sTmpBitmap.Graphics, sPen, 0, 0, mWidth, mHeight)
GdipDeletePen(sPen)
mBackBitmap.DrawImage(sTmpBitmap.Image, 0, 0)
End If
mUpdate = True
End Sub
Private Function TextClock.ImageUpdate() As GpImage Ptr
Static sTimer As Integer
Static sBlink As Boolean
Dim dTimer As Integer = Int(VBTimer())
Dim sImg As gdipBitmap
sImg.Initial(mWidth, mHeight)
If (mUpdate = True) Or (sTimer <> dTimer) Then
mUpdate = False
sTimer = dTimer
sBlink = IIf(mBlinkColon, True , False)
'绘制有冒号的文字时钟
sImg.DrawImage(DrawClock(True), mClockLeft, mClockTop)
If mTextBlur Then FastBoxBlurHV(sImg.Image, mTextBlur)
mUpdateBitmap.Initial(mWidth, mHeight)
mUpdateBitmap.DrawImage(mBackBitmap.Image, 0, 0)
mUpdateBitmap.DrawImage(sImg.Image, 0, 0)
If mBlur Then FastBoxBlurHV(mUpdateBitmap.Image, mBlur)
Else
If (mBlinkColon = True) And (sBlink = True) And (VBTimerMS() > 0.5) Then
sBlink = False
'绘制没有冒号的文字时钟
sImg.DrawImage(DrawClock(False), mClockLeft, mClockTop)
If mTextBlur Then FastBoxBlurHV(sImg.Image, mTextBlur)
mUpdateBitmap.Initial(mWidth, mHeight)
mUpdateBitmap.DrawImage(mBackBitmap.Image, 0, 0)
mUpdateBitmap.DrawImage(sImg.Image, 0, 0)
If mBlur Then FastBoxBlurHV(mUpdateBitmap.Image, mBlur)
End If
End If
Return mUpdateBitmap.Image
End Function
Private Sub TextClock.CalculateSize()
mTxt.Initial(mWidth, mWidth)
mUpdateBitmap.Initial(mWidth, mHeight)
If mByHeight Then
mFontSize = mHeight '时分字体大小
Else
If mShowSecond Then
mFontSize = mWidth / 3.8 '时分字体大小
Else
mFontSize = mWidth / 2.8 '时分字体大小
End If
End If
mTxt.SetFont(*mFontName, mFontSize, mFontStyle)
mW(1) = mTxt.TextWidth(WStr("00")) '时宽度
mW(2) = 0
'mW(2) = mTxt.TextWidth(*mColon) '冒号宽度, 不知道为啥一个冒号的宽度这么宽
mH(0) = mTxt.TextHeight(WStr("00")) '整体高度
mW(3) = mW(1) '分宽度
If mShowSecond Then
mFontSize2 = mFontSize / 2.5 '秒字体大小
mTxt.SetFont(*mFontName, mFontSize2, mFontStyle)
mW(4) = mTxt.TextWidth(WStr("IM")) '秒宽度
mH(1) = mTxt.TextHeight(("IM")) '秒高度
mW(0) = mW(1) + mW(2) + mW(3) + mW(4) '整体宽度
Else
mW(0) = mW(1) + mW(2) + mW(3) '整体宽度
End If
mClockWidth = mW(0)
mClockHeight = mH(0) * 0.9
mClockLeft = (mWidth - mClockWidth) / 2 'x偏移
mClockTop = (mHeight - mClockHeight) / 2 'y偏移
mTxtScale = mClockHeight / mClockWidth
If mBackScale = 0 Then mBackScale = mTxtScale
End Sub
Private Function TextClock.DrawClock(ByVal pColon As Boolean = True) As GpImage Ptr
Static sBitmap As gdipBitmap
Static sBitmapSardow As gdipBitmap
mTxt.SetFont(*mFontName, mFontSize, mFontStyle)
'时
WLet(mDt, Format(Hour(Now), "0"))
Dim sofx As Single
sofx = mTxt.TextWidth(*mDt)
mTxt.TextPath(mW(1) - sofx, 0, *mDt, True)
'冒号
sofx = mTxt.TextWidth(*mColon)
If pColon Then mTxt.TextPath(mW(1) + (mW(2) - sofx) / 2, 0, *mColon)
'分
WLet(mDt, Format(Minute(Now), "00"))
mTxt.TextPath(mW(1) + mW(2), 0, *mDt)
If mShowSecond Then
'上下午
mTxt.SetFont(*mFontName, mFontSize2, mFontStyle)
WLet(mDt, IIf(Hour(Now) > 12, "PM", "AM"))
sofx = mTxt.TextWidth(*mDt)
mTxt.TextPath(mW(1) * 2 + mW(2) + mW(4) / 3 - sofx / 2 , mH(0) / 2 - mH(1), *mDt)
'秒
WLet(mDt, Format(Second(Now), "00"))
sofx = mTxt.TextWidth(*mDt)
mTxt.TextPath(mW(1) * 2 + mW(2) + mW(4) / 3 - sofx / 2 , mH(0) / 2 - mH(1) * 0.12, *mDt)
End If
Dim sBrush As Any Ptr
Dim sPen As GpPen Ptr
Dim sBordyGradientMode As LinearGradientMode = LinearGradientModeVertical ' LinearGradientModeHorizontal
Dim sBordyWrapMode As GpWrapMode= WrapModeTile
Dim sTextDRectF As GpRectF
With sTextDRectF
.X = 0 ' - sSize
.Y = 0 ' - sSize
.Width = mClockWidth ' + sSize
.Height = mClockHeight ' + sSize
End With
sBitmap.Initial(mClockWidth, mClockHeight)
If mShadowEnabled Then
sBitmapSardow.Initial(mClockWidth, mClockHeight)
GdipCreateLineBrushFromRect(@sTextDRectF, mTextAlpha1 Shl 24 Or &H000000, mTextAlpha2 Shl 24 Or &H000000, sBordyGradientMode, sBordyWrapMode, @sBrush)
GdipFillPath(sBitmapSardow.Graphics, sBrush, mTxt.mPath)
GdipDeleteBrush(sBrush)
sBitmap.DrawImage(sBitmapSardow.Image, mFontSize * mShadowSize, mFontSize * mShadowSize)
FastBoxBlurHV(sBitmap.Image, mFontSize * mShadowSize)
End If
GdipCreateLineBrushFromRect(@sTextDRectF, mTextAlpha1 Shl 24 Or mTextColor1, mTextAlpha2 Shl 24 Or mTextColor2, mGradientMode, sBordyWrapMode, @sBrush)
GdipFillPath(sBitmap.Graphics, sBrush, mTxt.mPath)
If mBorderEnabled Then
GdipCreatePen1(mBorderAlpha Shl 24 Or mBorderColor, mBorderSize, mUnitPixel, @sPen)
GdipDrawPath(sBitmap.Graphics, sPen, mTxt.mPath)
GdipDeletePen(sPen)
End If
GdipDeleteBrush(sBrush)
'GdipCreateSolidFill(mBorderAlpha Shl 24 Or mBorderColor, @sBrush)
'GdipFillRectangle(sBitmap.Graphics, sBrush, 0, 0, mWidth, mH(0))
'GdipDeleteBrush(sBrush)
Return sBitmap.Image
End Function
Private Sub TextClock.TextAlpha(ByVal pTextAlpha1 As ARGB = &HFF, ByVal pTextAlpha2 As ARGB = &HFF)
mTextAlpha1 = pTextAlpha1
mTextAlpha2 = pTextAlpha2
End Sub
Private Sub TextClock.TextColor(ByVal pTextColor1 As ARGB = &H000000, ByVal pTextColor2 As ARGB = &H000000)
mTextColor1 = pTextColor1
mTextColor2 = pTextColor2
End Sub