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

roych

       帮一个朋友做的，不过对GUI不太熟悉，这里提了一下，不过转到Access，加了这两个API声明还是没法实现，不知道大家对这方面有没有研究？

roych

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

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

风中漫步

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

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

复制代码

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. ErrHandler:
   
2.     'Oh oh, we've been bad..very bad
   
3.     fCmdButTextPic = False
   
4.     Resume ExitHere
   
5.   
   
6. End Function
   
7. 
   
8. 
   
9. ' Here's our Entry point from a Custom Menu Item
   
10. ' in Form Design View
    
11. 
    
12. Public Function CmdBut()
    
13. 
    
14. 'Form & Report Cntrol Objects
    
15. Dim ctl As Control
    
16. 
    
17. 'This object is either a Form or Report
    
18. Dim objFormReport As Object
    
19.       
    
20. Dim MyReport As Boolean
    
21. 'False = screen  True = report
    
22. 
    
23. Dim strTemp As String
    
24. Dim lngColor As Long
    
25. Dim boolTemp As Boolean
    
26. Dim lngRet As Long
    
27.     '************WARNING**********************************************
    
28. 'Do not step through in DEBUG mode until the StepOK LABEL
    
29. 'Obviously the desired Screen.ActiveControl assignment would fail!
    
30. 
    
31. On Error Resume Next
    
32.     Set ctl = Screen.ActiveControl
    
33.     If ctl Is Nothing Then
    
34.         lngRet = MsgBox("Sorry - you MUST select a Command Button Control!")
    
35.         GoTo ErrHandler
    
36.     End If
    
37. StepOK:
    
38. 
    
39.     If Not TypeOf ctl Is CommandButton Then
    
40.         lngRet = MsgBox("Sorry - you MUST select a Command Button Control!")
    
41.         GoTo ErrHandler
    
42.     End If
    
43. 
    
44.     Set objFormReport = ctl.Parent
    
45.     If objFormReport Is Nothing Then
    
46.         lngRet = MsgBox("Sorry - you MUST be in Form Design View!")
    
47.         GoTo ErrHandler
    
48.     End If
    
49. 
    
50.     'See if we are not in Form Design View
    
51.        If objFormReport.CurrentView <> 0 Then
    
52.         lngRet = MsgBox("Sorry - you MUST be in Form Design View!")
    
53.         GoTo ErrHandler
    
54.         End If
    
55.    
    
56.       
    
57.    ' Check Tag property to see if a Color is specified
    
58.    ' User allowed to place 2 items in Tag
    
59.    ' First is Color then Rotation in Degree
    
60.    ' seperated by ";"
    
61.    'If Len(ctl.Tag & "") = 0 Then
    
62.    ' Use White as Default
    
63.    'lngColor = RGB(255, 255, 255)
    
64.    'Else
    
65.    'strTemp = Left(ctl.Tag, (InStr(1, ctl.Tag, ";") - 1))
    
66.    'lngColor = Val(strTemp)
    
67.    'End If
    
68.    
    
69.    ' Uncomment above if you don't want to use Color Picker
    
70.    ' let's call Color Picker Dialog
    
71.    lngColor = aDialogColor()
    
72.    boolTemp = fCmdButTextPic(ctl, lngColor)
    
73.    
    
74. ErrHandler:
    
75.    
    
76.    Set ctl = Nothing
    
77. 
    
78. 'This object is either a Form or Report
    
79. Set objFormReport = Nothing
    
80. End Function

复制代码

roych

1. ' Get ready to Print!
   
2.     lngTextColor = apiSetTextColor(hMemDC, RGB(255, 255, 255)) 'White
   
3.     lngBackColor = apiSetBkColor(hMemDC, RGB(0, 0, 0)) 'Black
   
4.     ' I gave up on SetTextAlign and went with MoveToEx
   
5.     lngTemp = apiSetTextAlign(hMemDC, TA_UPDATECP)
   
6.    
   
7.     lngRet = apiMoveToEx(hMemDC, lpSZ.cx, lpSZ.cy, ByVal 0&) '(1), y(1), ByVal 0&)
   
8.     lngRet = apiTextOut(hMemDC, 0, 0, strname, Len(strname))
   
9.    
   
10.     'Clean up by deleting our created font.
    
11.     hFont = apiSelectObject(hMemDC, prevfont)
    
12.     apiDeleteObject (hFont)
    
13.    
    
14.     'OK..let's start to build our bitmapinfo structure
    
15.     'Get our existing bitmap information for bitmapinfoheader
    
16.     lngRet = apiGetObject(hBitmap, LenB(MyBitmap), MyBitmap)
    
17.    
    
18. With MyBitmapInfoHeader
    
19.    .biSize = LenB(MyBitmapInfoHeader)
    
20.    .biWidth = MyBitmap.bmWidth
    
21.    .biHeight = MyBitmap.bmHeight
    
22.    .biPlanes = 1
    
23.    .biBitCount = MyBitmap.bmPlanes * MyBitmap.bmBitsPixel
    
24.    .biCompression = 0
    
25.    .biSizeImage = 0
    
26.    .biXPelsPerMeter = 0 'lngXdpi ' * 39.370854
    
27.    .biYPelsPerMeter = 0 'lngXdpi  ' * 39.370854
    
28.    .biClrUsed = 0
    
29.    .biClrImportant = 0
    
30. End With
    
31.       
    
32.     'Set MyBitmapInfoHeader to MyBitmapInfo.bmiHeader
    
33.     MyBitmapInfo.bmiHeader = MyBitmapInfoHeader
    
34.       
    
35.     'Deselect the bitmap out of the dc
    
36.     'Microsoft says the Bitmap MUST NOT be selected into an existing device context
    
37.     lngRet = apiSelectObject(hMemDC, hOrigBitmap)
    
38.    
    
39.     'Since we are converting to a monochrome bitmap we'll just
    
40.     'leave room for 2 colors, Foreground and Background
    
41.     lngNumColors = 2
    
42.     lngAllocMem = lngNumColors * LenB(MyRGBquad)
    
43.     'Will need above to perform total memory requirement calculation
    
44.       
    
45.     'Calculate biSizeImage
    
46.     MyBitmapInfo.bmiHeader.biSizeImage = MyBitmap.bmWidthBytes * MyBitmap.bmHeight
    
47.    
    
48.     'Calculate total memory requirements
    
49.     lngAllocMem = lngAllocMem + MyBitmapInfo.bmiHeader.biSize _
    
50.     + MyBitmapInfo.bmiHeader.biSizeImage
    
51.    
    
52.     'Allocate Calculate total storage required
    
53.     hlngMemory = apiGlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, _
    
54.     lngAllocMem) ' + 100)  'Safety First!
    
55.     lngMemoryLock = apiGlobalLock(hlngMemory)
    
56.    
    
57.     'Call DIBits with my allocated memory as pointer for the lbits parameter
    
58.     'Will transfer bits to our memory block
    
59.     'We offset by 48 bytes
    
60.     '40 = MyBitmapInfoHeader structure
    
61.     ' 8 = 2 RGB Quad structures for my color table
    
62.     lngRet = apiGetDIBits(hMemDC, hBitmap, 0, MyBitmapInfoHeader.biHeight, _
    
63.     ByVal lngMemoryLock + 48, MyBitmapInfo, DIB_RGB_COLORS)
    
64.    
    
65.     'Could probably use the original bitmap but I was having a lot
    
66.     'of problems around here so I maintained the 2 bitmaps for debugging
    
67.     'Create monochrome bitmap to receive the GetDIBits above
    
68.     hbitmapmono = apiCreateBitmap(MyBitmapInfoHeader.biWidth, _
    
69.     MyBitmapInfoHeader.biHeight, 1, 1, ByVal 0&)
    
70.         
    
71.     lngRet = apiSetDIBits(hMemDC, hbitmapmono, 0, MyBitmapInfoHeader.biHeight, _
    
72.     ByVal lngMemoryLock + 48, MyBitmapInfo, DIB_RGB_COLORS)
    
73.    
    
74.     'We need to build a bitmapinfo structure in memory
    
75.     '40 bytes bitmapinfo strucure
    
76.     '8 bytes 2 RGB QUAD structures
    
77.     'Followed by actual bitmap data of whatever size is required
    
78.    
    
79.     'copy MyBitmapInfoHeader structure to beginning of memory block
    
80.     Call apiCopyMemory(ByVal lngMemoryLock, MyBitmapInfo.bmiHeader.biSize, 40)
    
81.     'LenB(MyBitmapInfoHeader) = 40. I hardcoded because of trouble - not sure why.
    
82.       
    
83.     'SetDiBits writes into the bitmapinfo color table
    
84.     'We have to set the 2 RGB quads to match the original
    
85.     'Values the user chose for the text control
    
86.     'I'd really rather leave the background transparent
    
87.     'so user could simply specify the control's background color in
    
88.     'Form-> Design view. This would then require an ActiveX control
    
89.     'to redraw the text after the user selects a new background color
    
90.     MyBitmapInfo.bmiColors(1).rgbBlue = UnRGB(ctlCmdButton.ForeColor, 2)
    
91.     MyBitmapInfo.bmiColors(1).rgbGreen = UnRGB(ctlCmdButton.ForeColor, 1)
    
92.     MyBitmapInfo.bmiColors(1).rgbRed = UnRGB(ctlCmdButton.ForeColor, 0)
    
93.     MyBitmapInfo.bmiColors(1).rgbReserved = 0
    
94.    
    
95.     MyBitmapInfo.bmiColors(0).rgbBlue = UnRGB(BGColor, 2)
    
96.     MyBitmapInfo.bmiColors(0).rgbGreen = UnRGB(BGColor, 1)
    
97.     MyBitmapInfo.bmiColors(0).rgbRed = UnRGB(BGColor, 0)
    
98.     MyBitmapInfo.bmiColors(0).rgbReserved = 0
    
99.                        
    
100.     'The most difficult problems cropped up with the CopyMemory sub.
     
101.     'It's much easier in Assembler, or even C, to tell if you are
     
102.     'working with a pointer, or a pointer to a pointer.
     
103.     'ByRef...ByVal I'm still learning by trial and error.
     
104.     'copy MyBitmapInfo.bmiColors(0 to 1) structure to memory block + 40
     
105.     Call apiCopyMemory(ByVal lngMemoryLock + 40, MyBitmapInfo.bmiColors(0), 8)
     
106.       
     
107.     'DEBUG Leave in so next girl/guy can check and see if memcopy is working
     
108.     'I miss my Assembly Debugger!
     
109.     'Dim mys(60) as byte
     
110.     'Call apiCopyMemory(mys(0), ByVal lngMemoryLock, 60)
     
111.    
     
112.     ReDim varpicture(lngAllocMem - 1) ' + 10) 'Safety First!
     
113.     Call apiCopyMemory(varpicture(0), ByVal lngMemoryLock, lngAllocMem) ' + 10)
     
114.    
     
115.     'release memory lock
     
116.     lngRet = apiGlobalUnlock(hlngMemory)
     
117.         
     
118.     'release memory block
     
119.     lngRet = apiGlobalFree(hlngMemory)
     
120.    
     
121.    
     
122.     ' Save the Bitmap to a disk file
     
123.     With FileHeader
     
124.       .bfType = &H4D42
     
125.       .bfSize = Len(FileHeader) + Len(MyBitmapInfo) + MyBitmapInfo.bmiHeader.biSize
     
126.       .bfOffBits = Len(FileHeader) + Len(MyBitmapInfo)
     
127.     End With
     
128. 
     
129.     ' Get next avail file handle
     
130.     Fnum = FreeFile
     
131. 
     
132.     ' Get the Systems Temp path
     
133.     ' Returns Length of path(num characters in path)
     
134.     lngRet = GetTempPath(PathLen, strPath)
     
135.     ' Chop off NULLS and trailing ""
     
136.     strPath = Left(strPath, lngRet) & Chr(0)
     
137.    
     
138.     ' Now need a unique Filename
     
139.     ' locked from a previous aborted attemp.
     
140.     ' Needs more work!
     
141.     strPathandFileName = GetUniqueFilename(strPath, "SLC" & Chr(0), "BMP")
     
142.    
     
143.     Open strPathandFileName For Binary As Fnum
     
144.     Put Fnum, , FileHeader
     
145.     Put Fnum, , varpicture
     
146.     Close Fnum
     
147.    
     
148.     'Set newly created controls properties
     
149.     'to match properties the user setup in their label control.
     
150.     'need to match TRANSPARENT background setting in next revision.
     
151.     ctlCmdButton.Picture = strPathandFileName
     
152.    
     
153.     ' add other border/backcolor paramters here
     
154.     'ctlCmdButton.Tag = "Rotated:" & lngRotation & " Degrees"
     
155.    
     
156.     ' If we have Rotated Text let's set the
     
157.     ' Contol's dimensions to display all of
     
158.     ' Rotated Text
     
159.     If lngRotation <> 0 Then
     
160.     With lpRect
     
161.         If .right * (1440 / lngXdpi) > ctlCmdButton.Width Then _
     
162.         ctlCmdButton.Width = .right * (1440 / lngXdpi)
     
163.   
     
164.         If .Bottom * (1440 / lngXdpi) > ctlCmdButton.Height Then _
     
165.         ctlCmdButton.Height = .Bottom * (1440 / lngXdpi)
     
166.   End With
     
167.   End If
     
168.    
     
169.    
     
170.     'Normal Function Clean up
     
171.     lngRet = apiDeleteObject(hBitmap)
     
172.     lngRet = apiDeleteObject(hbitmapmono)
     
173.     Set ctlCmdButton = Nothing
     
174.     Set objFormReport = Nothing
     
175.    
     
176.     'Add any other cleanup code here.
     
177.     Call apiDeleteDC(hMemDC)
     
178.     Call apiReleaseDC(hwnd, hdc)
     
179.    
     
180.     ' Delete Temp file
     
181.     Kill strPathandFileName
     
182.    
     
183.     'Signal Function return OK
     
184.     fCmdButTextPic = True
     
185.    
     
186. ExitHere:
     
187.     'Perform any additional cleanup your code requires
     
188.    
     
189. Exit Function

复制代码

roych

1. 'Copy font stuff from Text Control's property sheet
   
2.     fontsize = ctlCmdButton.fontsize
   
3.     myfont.lfWeight = ctlCmdButton.FontWeight
   
4.     myfont.lfItalic = ctlCmdButton.FontItalic
   
5.     myfont.lfUnderline = ctlCmdButton.FontUnderline
   
6.     'Must be a negative figure for height or system will return
   
7.     'closest match on character cell not glyph
   
8.     myfont.lfHeight = (fontsize / 72) * -lngXdpi
   
9.                  
   
10.     hFont = apiCreateFontIndirect(myfont)
    
11.     prevfont = apiSelectObject(hMemDC, hFont)
    
12.                
    
13.     'Let's get length and height of non rotated of output string
    
14.     Dim lenStep As Integer, mystrTemp As String
    
15.     For lenStep = 1 To Len(strname)
    
16.         mystrTemp = Mid(strname, lenStep, 1)
    
17.         strname = strname & IIf(Asc(mystrTemp) = AscB(mystrTemp), "", mystrTemp)
    
18.     Next
    
19.     lnglength = Len(strname)
    
20.     lngTemp = apiGetTextExtentPoint32(hMemDC, strname, lnglength, stfsize)
    
21.      
    
22. With lpRect
    
23.     'Compute the coords for the text control
    
24.     .Left = 1
    
25.     .top = 1
    
26.     .right = ctlCmdButton.Width
    
27.     .Bottom = ctlCmdButton.Height
    
28. 
    
29.     'All previous measurements were in Twips.
    
30.     'ConvertTwipsToPixels = lngTwips / nTwipsPerInch * lngPixelsPerInch
    
31.     .Left = .Left / 1440 * lngScreenXdpi
    
32.     .top = .top / 1440 * lngScreenXdpi
    
33.     .Bottom = .Bottom / 1440 * lngScreenXdpi
    
34.     .right = .right / 1440 * lngScreenXdpi
    
35.   
    
36.   ' If use wants Rotated Text we need to make
    
37.   ' the Bitmap large enough to display it.
    
38.   lpSZ = BoundBox(stfsize, lpRect, lngRotation)
    
39.   If .right < lpSZ.widthX Then .right = lpSZ.widthX
    
40.   If .Bottom < lpSZ.widthY Then .Bottom = lpSZ.widthY
    
41.    
    
42.     'Force alignment to - 32  pixels for Access monochrome bitmap
    
43.     'We will be converting this bitmap to monochrome later on.
    
44.     .right = ((.right + 31) And &HFFFFFE0)
    
45.     '.right = ((stfsize.cx + 31) And &HFFFFFE0)
    
46.    
    
47.     lpSZ = BoundBox(stfsize, lpRect, lngRotation)
    
48.   'If .right < lpSZ.cx Then .right = lpSZ.cx
    
49.   'If .Bottom < lpSZ.cy Then .Bottom = lpSZ.cy
    
50.   'End If
    
51.    
    
52.     'Create a bitmap compatible
    
53.     'with the device associated with the specified device context
    
54.     'with size same as the size of the label control BUT MONOCHROME
    
55.     hBitmap = apiCreateBitmap(.right, .Bottom, 1, 1, ByVal 0&)
    
56. End With
    
57.       
    
58.     'Select the Bitmap into the specified device context
    
59.     hOrigBitmap = apiSelectObject(hMemDC, hBitmap)
    
60.          
    
61. With lpRect
    
62.      'Set all pixels to BLACK - better safe than sorry
    
63.      'because you just never know!
    
64.       lngRet = apiBitBlt(hMemDC, 0&, 0&, .right - .Left, _
    
65.              .Bottom - .top, hMemDC, .Left, .top, BLACKNESS)  '&H42)
    
66. End With

复制代码

roych

1. Function fCmdButTextPic(ctl As CommandButton, Optional ByVal BGColor As Long = 16777215) As Boolean
   
2. If BGColor = 0 Then BGColor = Val(Left(ctl.Tag, InStr(1, ctl.Tag, ";")))
   
3. '*******************************************
   
4. 'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 VBA ONLY
   
5. 'Supports TRUE TYPE FONTS ONLY!
   
6. '
   
7. 'Copyright: Stephen Lebans 1999  - May not be resold
   
8. '           Shareware - Cost $0.01
   
9. '           Please include this header in its entirety if you use
   
10. '           this function within your code.
    
11. '
    
12. 'Name:      fCmdBut (Function) Design View
    
13. '           fCmdButTextPic(function) Form View at Runtime
    
14. '
    
15. 'Version:   1.0a
    
16. 
    
17. 'Author:    Stephen Lebans
    
18. 'Email:     Stephen@lebans.com
    
19. 'Web Site:  www.lebans.com
    
20. 'Date:      Jan 26, 2000, 10:50:18 PM
    
21. '
    
22. On Error GoTo ErrHandler
    
23. 
    
24. 'Pardon my mess....
    
25. 
    
26. 
    
27. 'GDI Handles
    
28. Dim hFont As Long, prevfont As Long
    
29. Dim hwnd As Long
    
30. Dim hdc As Long
    
31. Dim hMemDC As Long
    
32. Dim hBitmap As Long
    
33. Dim holdbitmap As Long
    
34. Dim hOrigBitmap As Long
    
35. Dim hbitmapmono As Long
    
36. Dim lngIC As Long
    
37. 
    
38. 'To create our Rotated Font
    
39. Dim strname As String
    
40. Dim fontsize As Long
    
41. Dim lnglength As Long, lngTemp As Long
    
42. Dim stfsize As Size
    
43. Dim lpSZ As SizeX2
    
44. Dim lngXposition As Long
    
45. Dim lngYposition As Long
    
46. Dim lngRotation As Long
    
47. Dim myfont As LOGFONT
    
48. Dim lngXdpi As Long
    
49. Dim lngScreenXdpi As Long
    
50. Dim lngTextWidth As Long
    
51. Dim lngTextHeight As Long
    
52. Dim lngBackColor As Long
    
53. Dim lngTextColor As Long
    
54. 
    
55. 'building a better bitmap :-)
    
56. Dim lpRect As RECT
    
57. Dim MyBitmap As BITMAP
    
58. Dim MyBitmapInfo As BITMAPINFO
    
59. Dim MyBitmapInfoHeader As BITMAPINFOHEADER
    
60. Dim MyRGBquad As RGBQUAD
    
61. Dim lngNumColors As Long
    
62. Dim lngAllocMem As Long
    
63. Dim hlngMemory As Long
    
64. Dim lngMemoryLock As Long
    
65. 
    
66. 
    
67. 'Temp variables
    
68. Dim lngRet As Long
    
69. Dim intReturn As Integer
    
70. 
    
71. ' For System Temp Folder
    
72. ' and temp unique filename
    
73. Dim strPath  As String * PathLen
    
74. Dim strPathandFileName  As String
    
75. Dim FileHeader As BITMAPFILEHEADER
    
76. Dim Fnum As Integer
    
77. 
    
78. 
    
79. 'Holds the actual bitmap file
    
80. Dim varpicture() As Byte
    
81. 'Form & Report Cntrol Objects
    
82. Dim ctlCmdButton As Control
    
83. Dim objFormReport As Object
    
84.       
    
85. Dim MyReport As Boolean
    
86. 'False = screen  True = report
    
87. 
    
88. Dim strTemp As String
    
89. 
    
90. 
    
91.     Set ctlCmdButton = ctl
    
92.    
    
93.     Set objFormReport = ctlCmdButton.Parent
    
94.      hwnd = objFormReport.hwnd
    
95.   
    
96.     'retrieve a handle to a display device context (DC)
    
97.     'for the client area of the specified window
    
98.     hdc = apiGetDC(hwnd)
    
99.     'create a memory device context (DC) compatible
    
100.     'with the specified device
     
101.     hMemDC = apiCreateCompatibleDC(hdc)
     
102.   
     
103.          
     
104.     'OK setup font and print into the supplied bitmap
     
105.     'First grab text from control's name property
     
106.     strname = IIf(ctlCmdButton.Caption = "", "?", ctlCmdButton.Caption)
     
107.     'If Asc(strname) < 0 Then strname = strname & strname
     
108.     'Escapement = rotation is specified in tenths of a degree
     
109.     'user defined from Tag Property
     
110.     If Len(ctl.Tag & "") = 0 Then
     
111.    ' Use White as Default
     
112.    lngRotation = 0
     
113.    Else
     
114.    strTemp = Mid(ctl.Tag, (InStr(1, ctl.Tag, ";") + 1))
     
115.    lngRotation = Val(strTemp)
     
116.     End If
     
117.    
     
118.    ' lngRotation = IIf(ctlCmdButton.Tag = "", 0, ctlCmdButton.Tag)
     
119.     If lngRotation < 360 Then lngRotation = Abs(lngRotation)
     
120.     If lngRotation > 360 Then lngRotation = 0
     
121.    
     
122.     myfont.lfClipPrecision = OUT_TT_ONLY_PRECIS
     
123.     myfont.lfEscapement = Abs(lngRotation) * 10
     
124.     myfont.lfFaceName = ctlCmdButton.FontName & Chr$(0)  'Null character at end
     
125.          
     
126. 'If MyReport = False Then
     
127.     lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
     
128.     'If the call to CreateIC didn't fail, then get the Screen X resolution.
     
129.     If lngIC <> 0 Then
     
130.         lngXdpi = apiGetDeviceCaps(lngIC, LOGPIXELSX)
     
131.         lngScreenXdpi = lngXdpi
     
132.         'Release the information context.
     
133.         apiDeleteDC (lngIC)
     
134.     Else
     
135.         ' Something has gone wrong. Assume an average value.
     
136.        lngXdpi = 120
     
137.        lngScreenXdpi = lngXdpi
     
138. End If

复制代码

roych

风中漫步 发表于 2012-8-22 11:57
斑竹直接贴代码可否,3Q

好吧，挖坟。

1. Private Const LF_FACESIZE = 32
   
2. 
   
3. Private Type RECT
   
4.   Left As Long
   
5.   right As Long
   
6.   top As Long
   
7.   Bottom As Long
   
8. End Type
   
9. 
   
10. Private Type Size
    
11.         cx As Long
    
12.         cy As Long
    
13. End Type
    
14. 
    
15. Private Type SizeX2
    
16.         cx As Long
    
17.         cy As Long
    
18.         widthX As Long
    
19.         widthY As Long
    
20. End Type
    
21. 
    
22. Private Type LOGFONT
    
23.         lfHeight As Long
    
24.         lfWidth As Long
    
25.         lfEscapement As Long
    
26.         lfOrientation As Long
    
27.         lfWeight As Long
    
28.         lfItalic As Byte
    
29.         lfUnderline As Byte
    
30.         lfStrikeOut As Byte
    
31.         lfCharSet As Byte
    
32.         lfOutPrecision As Byte
    
33.         lfClipPrecision As Byte
    
34.         lfQuality As Byte
    
35.         lfPitchAndFamily As Byte
    
36.         lfFaceName As String * LF_FACESIZE
    
37. End Type
    
38. 
    
39. Private Type RGBQUAD
    
40.         rgbBlue As Byte
    
41.         rgbGreen As Byte
    
42.         rgbRed As Byte
    
43.         rgbReserved As Byte
    
44. End Type
    
45. 
    
46. Private Type BITMAP
    
47.   bmType As Long
    
48.   bmWidth As Long
    
49.   bmHeight As Long
    
50.   bmWidthBytes As Long
    
51.   bmPlanes As Integer
    
52.   bmBitsPixel As Integer
    
53.   bmBits As Long
    
54. End Type
    
55. 
    
56. Private Type BITMAPINFOHEADER '40 bytes
    
57.         biSize As Long
    
58.         biWidth As Long
    
59.         biHeight As Long
    
60.         biPlanes As Integer
    
61.         biBitCount As Integer
    
62.         biCompression As Long
    
63.         biSizeImage As Long
    
64.         biXPelsPerMeter As Long
    
65.         biYPelsPerMeter As Long
    
66.         biClrUsed As Long
    
67.         biClrImportant As Long
    
68. End Type
    
69. 
    
70. Private Type BITMAPINFO
    
71.         bmiHeader As BITMAPINFOHEADER
    
72.         bmiColors(1) As RGBQUAD
    
73.         ' we need two colors for monochrome bitmap
    
74. End Type
    
75. 
    
76. Private Type BITMAPFILEHEADER    '14 bytes
    
77.   bfType As Integer
    
78.   bfSize As Long
    
79.   bfReserved1 As Integer
    
80.   bfReserved2 As Integer
    
81.   bfOffBits As Long
    
82. End Type
    
83. 
    
84. Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    
85.     (destination As Any, source As Any, ByVal Length As Long)
    
86. 
    
87. Private Declare Function apiCreateBitmap Lib "gdi32" Alias "CreateBitmap" _
    
88. (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, _
    
89. ByVal nBitCount As Long, lpBits As Any) As Long
    
90. 
    
91. Private Declare Function apiGlobalAlloc Lib "kernel32" Alias "GlobalAlloc" _
    
92. (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    
93. 
    
94. Private Declare Function apiGlobalFree Lib "kernel32" Alias "GlobalFree" _
    
95. (ByVal hMem As Long) As Long
    
96. 
    
97. Private Declare Function apiGlobalLock Lib "kernel32" Alias "GlobalLock" _
    
98. (ByVal hMem As Long) As Long
    
99. 
    
100. Private Declare Function apiGlobalUnlock Lib "kernel32" Alias "GlobalUnlock" _
     
101. (ByVal hMem As Long) As Long
     
102. 
     
103. Private Declare Function apiGetStockObject Lib "gdi32" Alias "GetStockObject" _
     
104. (ByVal nIndex As Long) As Long
     
105. 
     
106. Private Declare Function apiGetDIBits Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, _
     
107. ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, _
     
108. lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
     
109. 
     
110. Private Declare Function apiSetDIBits Lib "gdi32" Alias "SetDIBits" (ByVal hdc As Long, _
     
111. ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, _
     
112. lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
     
113. 
     
114. Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
     
115. (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
     
116. ByVal lpOutput As String, lpInitData As Any) As Long
     
117. 
     
118. Private Declare Function apiSelectObject Lib "gdi32" _
     
119. Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As Long) As Long
     
120. 
     
121. Private Declare Function apiSetTextAlign Lib "gdi32" Alias "SetTextAlign" _
     
122. (ByVal hdc As Long, ByVal wFlags As Long) As Long
     
123. 
     
124. Private Declare Function apiSetTextColor Lib "gdi32" Alias "SetTextColor" _
     
125. (ByVal hdc As Long, ByVal crColor As Long) As Long
     
126. 
     
127. Private Declare Function apiSetBkColor Lib "gdi32" Alias "SetBkColor" _
     
128. (ByVal hdc As Long, ByVal crColor As Long) As Long
     
129. 
     
130. Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _
     
131. Alias "GetTextExtentPoint32A" _
     
132. (ByVal hdc As Long, ByVal lpSZ As String, ByVal cbString As Long, _
     
133. lpsize As Size) As Long
     
134. 
     
135. Private Declare Function apiTextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As _
     
136. Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal _
     
137. nCount As Long) As Long
     
138. 
     
139. Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
     
140.         "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
     
141. 
     
142. Private Declare Function apiGetDC Lib "user32" _
     
143.   Alias "GetDC" (ByVal hwnd As Long) As Long
     
144. 
     
145. Private Declare Function apiReleaseDC Lib "user32" _
     
146.   Alias "ReleaseDC" (ByVal hwnd As Long, _
     
147.   ByVal hdc As Long) As Long
     
148. 
     
149. Private Declare Function apiCreateCompatibleDC Lib "gdi32" _
     
150.   Alias "CreateCompatibleDC" (ByVal hdc As Long) As Long
     
151. 
     
152. Private Declare Function apiDeleteDC Lib "gdi32" _
     
153.   Alias "DeleteDC" (ByVal hdc As Long) As Long
     
154. 
     
155. Private Declare Function apiBitBlt Lib "gdi32" _
     
156.   Alias "BitBlt" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
     
157.   ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
     
158.   ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
     
159. 
     
160. Private Declare Function apiDeleteObject Lib "gdi32" _
     
161.   Alias "DeleteObject" (ByVal hObject As Long) As Long
     
162. 
     
163. Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" _
     
164. (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
     
165. 
     
166. Private Declare Function apiGetDeviceCaps Lib "gdi32" _
     
167.   Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
     
168. 
     
169. Private Declare Function apiMoveToEx Lib "gdi32" Alias "MoveToEx" _
     
170. (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
     
171. 'above was lpPoint as POINTAPI, changed to Any to allow NULL
     
172. 
     
173. ' For Terry Kreft's API Colro Dialog Function
     
174. Private Const CC_SOLIDCOLOR = &H80
     
175. 
     
176. Private Type COLORSTRUC
     
177.   lStructSize As Long
     
178.   hwnd As Long
     
179.   hInstance As Long
     
180.   rgbResult As Long
     
181.   lpCustColors As String
     
182.   Flags As Long
     
183.   lCustData As Long
     
184.   lpfnHook As Long
     
185.   lpTemplateName As String
     
186. End Type
     
187. 
     
188. Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
     
189.   (pChoosecolor As COLORSTRUC) As Long
     
190. 
     
191. Private Declare Function GetTempPath Lib "kernel32" _
     
192. Alias "GetTempPathA" (ByVal nBufferLength As Long, _
     
193. ByVal lpBuffer As String) As Long
     
194. 
     
195. Private Declare Function GetTempFileName _
     
196.   Lib "kernel32" Alias "GetTempFileNameA" _
     
197.   (ByVal lpszPath As String, _
     
198.   ByVal lpPrefixString As String, _
     
199.   ByVal wUnique As Long, _
     
200.   ByVal lpTempFileName As String) As Long
     
201. 
     
202. Private Const MAX_PATH = 260
     
203. 
     
204. Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK
     
205.   'Number of pixels per logical inch along the screen width.
     
206. Private Const LOGPIXELSX = 88
     
207.   'Number of pixels per logical inch along the screen height.
     
208. Private Const LOGPIXELSY = 90
     
209.   'Width and height, in pixels, of the screen of the monitor.
     
210.   'DIB color table identifiers
     
211. Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
     
212.   'TextAlign Flags
     
213. Private Const TA_UPDATECP = 1
     
214. Private Const PI = 3.14159265
     
215. 
     
216. Private Const PI_180 = PI / 180#
     
217.   'Use True Type Fonts ONLY!
     
218. Private Const OUT_TT_ONLY_PRECIS = 7
     
219. 
     
220. Private Const PathLen = 255
     
221. 
     
222. Private Const DEFAULT_PALETTE = 15
     
223.   'Global Memory Flags
     
224. Private Const GMEM_MOVEABLE = &H2
     
225. Private Const GMEM_ZEROINIT = &H40

复制代码

(代码太多，待续）