【API】自定义字体如何消除锯齿化？

roych

1. Private Function UnRGB(RGBCol As Long, position As Integer) As Long
   
2. 'Part: 0=Red, 1=Green, 2=Blue
   
3. 
   
4. 'Can't divide by ZERO!
   
5.     If RGBCol = 0 Then
   
6.     UnRGB = 0
   
7.     Exit Function
   
8.     End If
   
9. 
   
10. Select Case position
    
11.     Case 0
    
12.     UnRGB = RGBCol And &HFF
    
13. 
    
14.     Case 1
    
15.     UnRGB = (RGBCol And &HFF00)
    
16.     If UnRGB = 0 Then Exit Function
    
17.     UnRGB = UnRGB / 256  '&HFF
    
18.     UnRGB = UnRGB And &HFF
    
19. 
    
20.     Case 2
    
21.     UnRGB = (RGBCol And &HFF0000)
    
22.     If UnRGB = 0 Then Exit Function
    
23.     UnRGB = UnRGB / 65536 '&HFFFF
    
24.     UnRGB = UnRGB And &HFF
    
25. 
    
26. End Select
    
27. 
    
28. End Function
    
29. 
    
30. 
    
31. 
    
32. Private Function GetUniqueFilename(Optional Path As String = "", _
    
33. Optional Prefix As String = "", _
    
34. Optional UseExtension As String = "") _
    
35. As String
    
36. 
    
37. ' originally Posted by Terry Kreft
    
38. ' to: comp.Databases.ms -Access
    
39. ' Subject:  Re: Creating Unique filename ??? (Dev code)
    
40. ' Date: 01/15/2000
    
41. ' Author: Terry Kreft <terry.kreft@mps.co.uk>
    
42. 
    
43. ' SL Note: Input strings must be NULL terminated.
    
44. ' Here it is done by the calling function.
    
45. 
    
46.   Dim wUnique As Long
    
47.   Dim lpTempFileName As String
    
48.   Dim lngRet As Long
    
49.   
    
50.   wUnique = 0
    
51.   If Path = "" Then Path = CurDir
    
52.   lpTempFileName = String(MAX_PATH, 0)
    
53.   lngRet = GetTempFileName(Path, Prefix, _
    
54.                             wUnique, lpTempFileName)
    
55. 
    
56.   lpTempFileName = Left(lpTempFileName, _
    
57.                         InStr(lpTempFileName, Chr(0)) - 1)
    
58.   Call Kill(lpTempFileName)
    
59.   If Len(UseExtension) > 0 Then
    
60.     lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
    
61.   End If
    
62.   GetUniqueFilename = lpTempFileName
    
63. End Function
    
64. 
    
65. 
    
66. Private Function BoundBox(ByRef lpSZ As Size, ByRef lpRect As RECT, ByVal lngRotate As Long) As SizeX2
    
67. 
    
68. ' *****************************************************
    
69. ' I would like to thank Rod Stephen's for Permission to
    
70. ' use his Trig Calculations from his book
    
71. ' "Custom Controls Library". I also highly reccommend his
    
72. ' book "Visual Basic Graphics Programming".
    
73. ' *****************************************************
    
74. 
    
75.     Dim x(1 To 4) As Single
    
76.     Dim y(1 To 4) As Single
    
77.     Dim xmin As Single
    
78.     Dim xmax As Single
    
79.     Dim ymin As Single
    
80.     Dim ymax As Single
    
81.     Dim stheta As Single
    
82.     Dim ctheta As Single
    
83.     Dim i As Integer
    
84.     Dim tmp As Single
    
85.     Dim bbsz As SizeX2
    
86.             
    
87.         ' Calculate a bounding box for the text.
    
88.         x(1) = 0
    
89.         x(2) = lpSZ.cx
    
90.         x(3) = x(2)
    
91.         x(4) = 0
    
92.         y(1) = 0
    
93.         y(2) = 0
    
94.         y(3) = lpSZ.cy
    
95.         y(4) = y(3)
    
96.    
    
97.         ' Rotate the bounding box.
    
98.         stheta = Sin(Abs(lngRotate) * PI_180)
    
99.         ctheta = Cos(Abs(lngRotate) * PI_180)
    
100.         For i = 2 To 4
     
101.             tmp = x(i) * ctheta + y(i) * stheta
     
102.             y(i) = -x(i) * stheta + y(i) * ctheta
     
103.             x(i) = tmp
     
104.         Next i
     
105.         
     
106.         ' Bound the rotated bounding box.
     
107.         xmin = x(1)
     
108.         xmax = xmin
     
109.         ymin = y(1)
     
110.         ymax = ymin
     
111.         For i = 2 To 4
     
112.             If xmin > x(i) Then xmin = x(i)
     
113.             If xmax < x(i) Then xmax = x(i)
     
114.             If ymin > y(i) Then ymin = y(i)
     
115.             If ymax < y(i) Then ymax = y(i)
     
116.         Next i
     
117.    
     
118. 
     
119.         ' Let's set the size our finished Image Control
     
120.         ' to be exactly the  size of the Rotated Text
     
121.     With lpRect
     
122.         .top = 0
     
123.         .Left = 0
     
124.                
     
125.         ' Horizontal Alignment is only LEFT for this version
     
126.         tmp = .right / 2 - (xmin + xmax) / 2
     
127.         For i = 1 To 4
     
128.         x(i) = tmp + x(i)
     
129.         Next i
     
130.         
     
131.         ' Vertical Alignment is only Center for this version
     
132.         tmp = .Bottom / 2 - (ymin + ymax) / 2
     
133.         For i = 1 To 4
     
134.         y(i) = tmp + y(i)
     
135.         Next i
     
136.     End With
     
137.       
     
138.        bbsz.cx = x(1)
     
139.        bbsz.cy = y(1)
     
140.        bbsz.widthX = (xmax - xmin) + 1
     
141.        bbsz.widthY = (ymax - ymin) + 1
     
142.    
     
143.    BoundBox = bbsz
     
144. ' ******************************
     
145. ' END OF ROTATED TEXT TRIG CALCS
     
146. ' ******************************
     
147. End Function
     
148. 
     
149. 
     
150. 
     
151. ' Original Code by Terry Kreft
     
152. ' Modified by Stephen Lebans
     
153. ' Contact Stephen@lebans.com
     
154. 
     
155. '***********  Code Start  ***********
     
156. Public Function aDialogColor() As Long
     
157.   Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
     
158. 
     
159.   CS.lStructSize = Len(CS)
     
160.   CS.hwnd = hWndAccessApp
     
161.   CS.Flags = CC_SOLIDCOLOR
     
162.   CS.lpCustColors = String$(16 * 4, 0)
     
163.   x = ChooseColor(CS)
     
164.   If x = 0 Then
     
165.     ' ERROR - use Default White
     
166.     'Access Maps Pure White(R255,G255,B255) to its
     
167.     ' standard Grey color. Get around this by
     
168.     ' selecting (R254,G254,B254)
     
169.     aDialogColor = RGB(254, 254, 254) ' White
     
170.     Exit Function
     
171.   Else
     
172.     ' Normal processing
     
173.     If CS.rgbResult = RGB(255, 255, 255) Then
     
174.         aDialogColor = RGB(254, 254, 254)
     
175.     Else
     
176.         aDialogColor = CS.rgbResult
     
177.     End If
     
178.   End If
     
179. End Function
     
180. '***********  Code End   ***********
     
181. 
     
182. 
     
183. ' To call it from your Form with use code like:
     
184. 
     
185. ' ***Code Start
     
186. 'Private Sub CmdChooseBackColor_Click()
     
187. ' Pass the TextBox Control to the function
     
188. 'Me.textCtl.BackColor = DialogColor(Me.textCtl)
     
189. 'End Sub
     
190. ' ***Code End
     

复制代码

roych

1. '报表模块
   
2. '*********************************************************************************
   
3. '调用函数简要说明：
   
4. '
   
5. '实现原理：创建自定义逻辑字体，保存在内存中，创建场景将内容保存为图片，再进行读取。
   
6. '
   
7. 'Call fCmdButTextPic(ctl, BGColor)
   
8. '参数说明：
   
9. 'ctl：必选，按钮控件
   
10. 'BGColor：可选，已修改默认为白色。
    
11. '*********************************************************************************
    
12. Private Sub 主体_Format(Cancel As Integer, FormatCount As Integer)
    
13. '显示按钮标题
    
14. Me.CmdColorNum.Caption = Me.ColorNumber
    
15. '调整角度
    
16. Me.CmdColorNum.Tag = 180
    
17. fCmdButTextPic Me.CmdColorNum
    
18. Me.ImgColorNum.PictureData = Me.CmdColorNum.PictureData
    
19. '处理标签部分。
    
20. Me.CmdPrimary.Caption = "Primary:Daylight D65"
    
21. Me.CmdPrimary.Tag = 180
    
22. fCmdButTextPic Me.CmdPrimary
    
23. Me.ImgPrimary.PictureData = Me.CmdPrimary.PictureData
    
24. 
    
25. Me.CmdIIIuminat.Caption = "IIIuminat used:"
    
26. Me.CmdIIIuminat.Tag = 180
    
27. fCmdButTextPic Me.CmdIIIuminat
    
28. Me.ImgIIIuminat.PictureData = Me.CmdIIIuminat.PictureData
    
29. End Sub

复制代码

风中漫步

{:soso_e134:}这么多
得慢慢看了.谢谢斑竹了

roych

风中漫步 发表于 2015-7-9 17:04
这么多
得慢慢看了.谢谢斑竹了

贴的时候每个帖子不能超过10000字，所以就只能全部贴上来了……晕，为什么没想到导出txt再传上来呢？