设为首页收藏本站Access中国
开启辅助访问 切换到宽版

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步，快速开始

Office中国论坛/Access中国论坛»论坛首页 › ACCESS 与Sql Server 讨论区 › Access常规交流 › 【API】自定义字体如何消除锯齿化？
12下一页
返回列表 发新帖
查看: 4016|回复: 13
打印 上一主题 下一主题

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

[复制链接]
roych
跳转到指定楼层
1#
发表于 2012-8-21 23:55:36 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
本帖最后由 roych 于 2012-8-21 23:59 编辑

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有帐号？注册

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏 分享分享 分享淘帖 订阅订阅
回复

使用道具 举报

jinzhanxi
2#
发表于 2012-8-22 08:24:09 | 只看该作者
学习学习
回复 支持 反对

使用道具 举报

风中漫步
3#
发表于 2012-8-22 11:57:35 | 只看该作者
斑竹直接贴代码可否,3Q
回复 支持 反对

使用道具 举报

tmtony

点击这里给我发消息
4#
发表于 2012-8-22 12:40:07 | 只看该作者
谢谢分享
回复 支持 反对

使用道具 举报

roych
5#
 楼主| 发表于 2012-8-22 18:49:54 | 只看该作者
风中漫步 发表于 2012-8-22 11:57
斑竹直接贴代码可否,3Q

不知道你说的贴代码是指哪方面。如果是指我的例子的话，请留意报表中的事件。
而至于搜索到的那个帖子，由于是基于VB的，部分内容不适用于Access，所用的API函数部分参数，虽然之前用新字体（myfont）相应属性来处理，但没见到什么效果。

点评

风中漫步
呵呵,没装ACC啊  发表于 2012-8-23 11:58
回复 支持 反对

使用道具 举报

roych
6#
 楼主| 发表于 2015-7-9 11:30:01 | 只看该作者
风中漫步 发表于 2012-8-22 11:57
斑竹直接贴代码可否,3Q

好吧，挖坟。
  1. Private Const LF_FACESIZE = 32

  3. Private Type RECT
  4.   Left As Long
  5.   right As Long
  6.   top As Long
  7.   Bottom As Long
  8. End Type

  10. Private Type Size
  11.         cx As Long
  12.         cy As Long
  13. End Type

  15. Private Type SizeX2
  16.         cx As Long
  17.         cy As Long
  18.         widthX As Long
  19.         widthY As Long
  20. End Type

  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

  39. Private Type RGBQUAD
  40.         rgbBlue As Byte
  41.         rgbGreen As Byte
  42.         rgbRed As Byte
  43.         rgbReserved As Byte
  44. End Type

  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

  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

  70. Private Type BITMAPINFO
  71.         bmiHeader As BITMAPINFOHEADER
  72.         bmiColors(1) As RGBQUAD
  73.         ' we need two colors for monochrome bitmap
  74. End Type

  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

  84. Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  85.     (destination As Any, source As Any, ByVal Length As Long)

  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

  91. Private Declare Function apiGlobalAlloc Lib "kernel32" Alias "GlobalAlloc" _
  92. (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

  94. Private Declare Function apiGlobalFree Lib "kernel32" Alias "GlobalFree" _
  95. (ByVal hMem As Long) As Long

  97. Private Declare Function apiGlobalLock Lib "kernel32" Alias "GlobalLock" _
  98. (ByVal hMem As Long) As Long

  100. Private Declare Function apiGlobalUnlock Lib "kernel32" Alias "GlobalUnlock" _
  101. (ByVal hMem As Long) As Long

  103. Private Declare Function apiGetStockObject Lib "gdi32" Alias "GetStockObject" _
  104. (ByVal nIndex As Long) As Long

  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

  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

  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

  118. Private Declare Function apiSelectObject Lib "gdi32" _
  119. Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As Long) As Long

  121. Private Declare Function apiSetTextAlign Lib "gdi32" Alias "SetTextAlign" _
  122. (ByVal hdc As Long, ByVal wFlags As Long) As Long

  124. Private Declare Function apiSetTextColor Lib "gdi32" Alias "SetTextColor" _
  125. (ByVal hdc As Long, ByVal crColor As Long) As Long

  127. Private Declare Function apiSetBkColor Lib "gdi32" Alias "SetBkColor" _
  128. (ByVal hdc As Long, ByVal crColor As Long) As Long

  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

  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

  139. Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
  140.         "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

  142. Private Declare Function apiGetDC Lib "user32" _
  143.   Alias "GetDC" (ByVal hwnd As Long) As Long

  145. Private Declare Function apiReleaseDC Lib "user32" _
  146.   Alias "ReleaseDC" (ByVal hwnd As Long, _
  147.   ByVal hdc As Long) As Long

  149. Private Declare Function apiCreateCompatibleDC Lib "gdi32" _
  150.   Alias "CreateCompatibleDC" (ByVal hdc As Long) As Long

  152. Private Declare Function apiDeleteDC Lib "gdi32" _
  153.   Alias "DeleteDC" (ByVal hdc As Long) As Long

  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

  160. Private Declare Function apiDeleteObject Lib "gdi32" _
  161.   Alias "DeleteObject" (ByVal hObject As Long) As Long

  163. Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" _
  164. (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

  166. Private Declare Function apiGetDeviceCaps Lib "gdi32" _
  167.   Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long

  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

  173. ' For Terry Kreft's API Colro Dialog Function
  174. Private Const CC_SOLIDCOLOR = &H80

  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

  188. Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
  189.   (pChoosecolor As COLORSTRUC) As Long

  191. Private Declare Function GetTempPath Lib "kernel32" _
  192. Alias "GetTempPathA" (ByVal nBufferLength As Long, _
  193. ByVal lpBuffer As String) As Long

  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

  202. Private Const MAX_PATH = 260

  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

  216. Private Const PI_180 = PI / 180#
  217.   'Use True Type Fonts ONLY!
  218. Private Const OUT_TT_ONLY_PRECIS = 7

  220. Private Const PathLen = 255

  222. Private Const DEFAULT_PALETTE = 15
  223.   'Global Memory Flags
  224. Private Const GMEM_MOVEABLE = &H2
  225. Private Const GMEM_ZEROINIT = &H40
复制代码

(代码太多，待续）
回复 支持 反对

使用道具 举报

roych
7#
 楼主| 发表于 2015-7-9 11:33:19 | 只看该作者
  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

  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

  24. 'Pardon my mess....


  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

  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

  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


  67. 'Temp variables
  68. Dim lngRet As Long
  69. Dim intReturn As Integer

  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


  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

  88. Dim strTemp As String


  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
8#
 楼主| 发表于 2015-7-9 11:34:15 | 只看该作者
  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

  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
9#
 楼主| 发表于 2015-7-9 11:34:40 | 只看该作者
  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

  129.     ' Get next avail file handle
  130.     Fnum = FreeFile

  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
10#
 楼主| 发表于 2015-7-9 11:35:04 | 只看该作者
  1. ErrHandler:
  2.     'Oh oh, we've been bad..very bad
  3.     fCmdButTextPic = False
  4.     Resume ExitHere
  5.   
  6. End Function


  9. ' Here's our Entry point from a Custom Menu Item
  10. ' in Form Design View

  12. Public Function CmdBut()

  14. 'Form & Report Cntrol Objects
  15. Dim ctl As Control

  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

  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!

  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:

  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

  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

  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

  78. 'This object is either a Form or Report
  79. Set objFormReport = Nothing
  80. End Function
复制代码
回复 支持 反对

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-4-19 13:20 , Processed in 0.113143 second(s), 35 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表