设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

123下一页
返回列表 发新帖
查看: 9631|回复: 25

[Access本身] Access中自绘自定义“控件”

[复制链接]

点击这里给我发消息

发表于 2015-3-16 14:17:53 | 显示全部楼层 |阅读模式
本帖最后由 站到终点站 于 2015-3-16 20:17 编辑

       在论坛也混了蛮长时间了,一直没有发表过什么专题性质的文章。主要是论坛上高手如云,很多学习过程中的问题在论坛上都能找到答案,特别是论坛的精华帖。通过不断学习,我也开始对一些问题形成了些自己的想法。比如最近一段时间碰到一个问题:关于Access中动态添加控件的问题,Access中要给Form动态添加控件之类的,必须切换到窗体的设计模式,即使通过VBA代码也必须这么做。以往碰到这个问题,一般的做法是在窗体中先添加固定数目的控件,然后窗体加载时将其隐藏,当需要动态添加时就将其显示出来,但是这个方法一旦超出当初添加控件的数目时,就没办法解决了,并且控件添加多了对窗体加载速度也有一定影响。另外的话也可以通过一些ActiveX控件来做到这些,不过要找到适合Access且适合自己需求的ActiveX控件并不是件容易的事情,鉴于此我就想怎么才能在窗体上动态添加控件。
       其实这个问题纠结了差不多有1年了,当初也想到来自绘这个途径,但是有好几个问题都不懂,所以解决不了。这些问题包括:
1、自绘的话,用什么在窗体上自绘?      肯定不能用Access的控件,线条、框什么的都不能用,因为这些都不能动态添加到窗体上。只有选择通过API来绘图,可以使用的包括GDI、GDI+。但是我那时对GDI和GDI+是一点了解都没有,所以画了很长时间研究VBA中用API、GDI跟GDI+。
2、要用API绘图就要有窗体句柄、要获得设备环境(DC),Access里怎么获取这些了?
     可能有些人马上会想到Access窗体有个hwnd属性啊,不就可以了吗?其实这里面还有些曲折,后面我会详细说。这里大家所要了解的是Access的窗体下面还包含了好几个,包括窗体页眉、主体跟窗体页脚,它们都有句柄,要进行绘图的话,你得获取对应的句柄,而不是直接使用Access窗体的hwnd属性。
3、以上2个问题解决了,还只是完成了在窗体上自绘,要怎样才能将这些自绘窗体像控件一样使用到其他窗体上了?
     可能大家看完这个问题,对Access有些了解的朋友会马上想到子窗体。但是当时我是想了1个星期才想到用子窗体,因为当初对这个问题我的想法是怎么在Access中做自定义控件,而没有想到怎么将窗体放到窗体里面这个方法。使用子窗体作为类似“控件”容器的承载体,这就解决的自定义控件的“容器”问题。
     好了,说完这几个问题,那么我再总结下要读懂本文内容所需要储备的知识,如果你还对以下内容完全不了解的话,我建议你首先百度下或者找找相关的书什么的了解下,当然你也可以继续读下去,因为我会尽力讲的通俗易懂。不过如果你感觉阅读的很吃力的话,那你最好还是补一补相关的内容再来。
1、VBA中如何使用API?
2、GDI是用来干什么的?如何使用GDI?GDI句柄跟设备环境的关系,如何用GDI绘图?
3、Access窗体的构成。
4、Access子窗体是什么?怎么使用子窗体?
5、VBA中的类模块是什么?怎么使用类模块?类模块属性、方法、事件怎么建立?
6、Access窗体与类模块的关系;
7、使用VBA代码怎么调用自定义“控件”?
8、集合在类模块中的使用;
     另外我也想说明一下,由于本贴内容可能会比较长,我会分批将所写内容更新进来,由于平时工作比较忙,可能一次更新的内容也不会太多,所以希望大家也不要急躁,慢慢看慢慢消化。另外相应的代码部分也有很多在调试之中,但是大部分主体的代码已经完成,我暂时不把源代码随帖子一起发布,我会将其中的大部分代码写到本贴里面并讲解,希望有兴趣的将贴看下去。


下面我们就开始讲怎么在Access来做一个类似TabControl的“控件”。
首先,我们来看下最终的效果,示例中包含了2个窗体,frmTest是个测试窗体,TabControl就是我们所谓的当作控件来使用的子窗体。另外还有些模块跟类模块,有些模块是无用的,因为我在做这个的时候,借鉴了部分代码,只是没有删除,我在后面会说到有哪些模块跟代码会使用到的,所以这里就不再说明各个模块的作用了。
双击打开frmTest,默认会建立3个框,相当于3个Tab,点击添加按钮,会自动添加Tab,点删除按钮会从最后依次删除Tab,在某个Tab上点击,会弹出一个对话框显示当前Tab的序号。


实例附件已上传,可以下载,部分代码还需要修改:













本帖子中包含更多资源

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

x

本帖被以下淘专辑推荐:

点击这里给我发消息

 楼主| 发表于 2015-3-16 14:18:13 | 显示全部楼层

第一部分、建立clsAccTabBar类模块

本帖最后由 站到终点站 于 2015-3-16 16:37 编辑

     在动手编写代码前,首先我们得分析下TabControl控件的结构,搞清楚我们需要建立什么样的模块、类模块以及窗体模块。从上面我们已经看到了我们用了一个子窗体作为TabControl的容器,那么TabControl里面还包括了很多Tab,这些Tab会构成一个集合Tabs,所以这个控件的层级关系就是:
TabControl
+---Tabs
      +----Tab
      之所以要理清楚这个关系,是因为基于这个结构建立我们的“控件”,会大大方便对我们控件的访问。这里的TabControl对应我们的窗体,Tabs的话我们将在TabControl的窗体代码中建立一个私有集合变量mTabBars,而Tab这个东西就需要我们自己来写类模块了。我将这个类模块命名为clsAccTabBar,cls代码是类模块,Acc表示是Access中的,TabBar就是这个类模块的含义。
      下面我们来分析下这个类模块的内容,这个类模块所代表的是TabControl中的一个TabBar:
1、与属性相关的:包括TabBar的位置信息(Top、Left、Right、Bottom)、鼠标是否在其上(IsMouseOn)、是否被单击(Selected)、显示文字内容(Text)、标识字符串(Key)。可能大家还会说有与颜色相关的属性,这些我都放在了TabControl里面了,因为这些颜色是所有Tab共用的,而不是某一个Tab专属的,即使是选中色、鼠标移动其上的颜色。
2、与方法相关:Tab重画,这个方法我将它写在了TabControl里面了,当然你如果有兴趣可以为Tab建立一个ReDraw的方法;
3、与事件相关:TabBar被单击事件,TabBar鼠标移动事件,这2个事件的实现有些特殊,按道理应该在Tab类模块里建立这2个事件,但是鼠标的移动跟单击触发都是在TabControl里面,所以这2个事件我都把实现做到了TabControl窗体的事件代码里面了,后面讲述TabControl的时候我会再讲;
     从上面的描述来看,我基本上把这个clsAccTabBar类模块只让其用于保存各个Tab相关信息,下面是类模块里面的代码:
  1. Option Compare Database

  2. Private mIndex As Integer
  3. Private mKey As String
  4. Private mText As String
  5. Private mTargetFom As String
  6. Private mSelected As Boolean
  7. Private mIsMouseOn As Boolean

  8. Public Property Get Index() As Integer
  9.     Index = mIndex
  10. End Property

  11. Public Property Let Index(Value As Integer)
  12.     mIndex = Value
  13. End Property

  14. Public Property Get Key() As String
  15.     Key = mKey
  16. End Property

  17. Public Property Get Text() As String
  18.     Text = mText
  19. End Property

  20. Public Property Let Text(Value As String)
  21.     mText = Value
  22. End Property

  23. Public Property Get TargetFom() As String
  24.     TargetForm = mtargetform
  25. End Property

  26. Public Property Get Left() As Long
  27.     Left = mRect.Left
  28. End Property

  29. Public Property Let Left(Value As Long)
  30.     mRect.Left = Value
  31. End Property

  32. Public Property Get Right() As Long
  33.     Right = mRect.Right
  34. End Property

  35. Public Property Let Right(Value As Long)
  36.     mRect.Right = Value
  37. End Property

  38. Public Property Get Top() As Long
  39.     Top = mRect.Top
  40. End Property

  41. Public Property Let Top(Value As Long)
  42.     mRect.Top = Value
  43. End Property

  44. Public Property Get Bottom() As Long
  45.     Bottom = mRect.Bottom
  46. End Property

  47. Public Property Let Bottom(Value As Long)
  48.     mRect.Bottom = Value
  49. End Property

  50. Public Property Get Width() As Long
  51.     Width = Abs(mRect.Right - mRect.Left)
  52. End Property

  53. Public Property Get Height() As Long
  54.     Height = Abs(mRect.Bottom - mRect.Top)
  55. End Property

  56. Public Property Get IsMouseOn() As Boolean
  57.     IsMouseOn = mIsMouseOn
  58. End Property

  59. Public Property Let IsMouseOn(Value As Boolean)
  60.     mIsMouseOn = Value
  61. End Property

  62. Public Property Get Selected() As Boolean
  63.     Selected = mSelected
  64. End Property

  65. Public Property Let Selected(Value As Boolean)
  66.     mSelected = Value
  67. End Property
复制代码

     有些属性我在前面没有提到,而在代码里又有,比如Width、Height,这个是宽度、高度,这个都是根据其他属性值来计算得到的。当然这里我再给大家提一下类模块的属性建立问题。     前面有很多私有变量声明,我这里把它们叫做类模块的字段,它们都是以m开头的,之后我所有的代码都是以m开头来代表类模块中的字段,与这些字段对应的Get/Let属性方法表示对这些字段的读取/写入操作。类模块中建立字段、属性的标准范式就是如此,应该避免使用公用变量。如果你对类模块的属性建立不是很清楚,还请在论坛或百度查阅相关的内容。




点击这里给我发消息

 楼主| 发表于 2015-3-16 14:18:34 | 显示全部楼层

第二部分 构建Tabs集合

本帖最后由 站到终点站 于 2015-3-16 19:13 编辑

     前面第一部分大家已经看到了clsAccTabBar的代码,内容是不是比较简单?确实比较简单,因为很多东西我都把它放到了TabControl里面实现了。大家对于clsAccTabBar这个类模块牢记2点:其一:这个类模块与之前所分析的模型中Tab对应,它将是某个具体Tab对象的模板代码;
其二:这个类模块所实现的功能就是用于记录每一个Tab的信息,在运行时,这个类模块帮助我们把这些信息存储在内存中;当要进行重画时,我们又可以使用这个类模块读取数据,用GDI把所有Tab画出来,或者画其中某几个Tab;
     下面我们就来看看TabControl跟Tabs的实现吧,关于绘图的内容我将会在后面再单独说,因为后面我们还会将绘图部分的功能单独写入一个类模块中。我们先从最简单的Tabs来分析吧,稍后再看TabControl。Tabs是一个Tab的集合,我们直接使用Collection对象,虽然可能使用这个集合对象对于集合项目数较多时,性能会下降,但是我想谁也不可能在一个程序界面里出来个成百上千的Tab标签页吧!对于一个集合,我们所需要的功能包括添加、删除以及查找,而Collection对象都有现成的,确实方便多了。
      首先我们要在TabControl窗体代码里面声明一个mTabBars的Collection对象:
  1. Private mTabBars As New Collection
复制代码
      这里我直接用New声明了,也就是说这个TabControl“控件”被初始化时,就会在内存里分配空间给mTabBars(当然大家也可以不这么做,而是在添加TabBar方法里面对mTabBars进行检测,如果是nothing,就使用Set mTabBars=New Collection)。然后在窗体的UnLoad事件里面将mTabBars置为Nothing。这里啰嗦一句,实际编程的时候,大家要养成习惯,对需要进行清理的对象变量或者API中的一些资源对象,当存在调用代码时,立即在相应处添加清理代码,这样可以减少很多莫名奇妙的错误,特别是在VBA中使用API进行GDI编程时,这个好习惯可以帮助你减少很多不必要的调试麻烦。例如下面的ReleaseDC,它是GDI操作中的一个API函数,用于清除设备环境(DC)引用,mFormMainHwnd是对应的窗口句柄,mMainDC就是这个设备环境,设备环境是Windows非常珍贵的系统资源,如果用了不记得及时“还回”给系统,会造成程序莫名其妙出错,而且没有任何错误提示,甚至造成系统崩溃!
  1. Private Sub Form_Unload(Cancel As Integer)
  2.     ReleaseDC mFormMainHwnd, mMainDC
  3.     Set mTabBars = Nothing
  4. End Sub
复制代码
     下面我们再来看看如何向这个集合对象添加TabBar进去:
  1. Public Sub AddTabBar(ByVal Key As String, ByVal Text As String, ByVal TargetForm As String)
  2.     Dim mTabBar As New clsAccTabBar
  3.     Dim lngText As Long
  4.     Dim mTextSize As Size
  5.    
  6.     lngText = LenB(StrConv(Text, vbFromUnicode))
  7.     GetTextExtentPoint32 mMainDC, Text, lngText, mTextSize

  8.     If TabCount = 0 Then
  9.         mTabBar.Left = 0
  10.         mTabBar.Top = 0
  11.         mTabBar.Right = mTextSize.cx + 16
  12.         mTabBar.Bottom = 30
  13.     Else
  14.         mTabBar.Left = mTabBars(TabCount).Right + 0.6
  15.         mTabBar.Top = 0
  16.         mTabBar.Right = mTabBar.Left + mTextSize.cx + 16
  17.         mTabBar.Bottom = 30
  18.     End If
  19.     mTabBar.Text = Text
  20.     mTabBars.Add mTabBar
  21.     ReDrawTabBar mTabBars.count
  22. End Sub
复制代码
     方法有3个参数,前2个通过英文名就知道是什么意思,里面的代码我还没有使用到Key,只使用了Text,最后一个参数是个预留参数,暂时也没有用到。下面讲下代码内容,声明了3个变量,第一个mTabBar用于保存需要添加的TabBar的相关数据,第二个lngText保存Text字符串的长度,这个参数传递给API函数GetTextExtentPoint32,用于获取字符串的实际显示像素宽度;第三个mTextSize用于保存GetTextExtentPoint32函数运算后,所获得的字符串实际显示像素宽高值,它是一个Size的数据结构,代码如下:
  1. Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
  2.     ByVal hdc As Long, _
  3.     ByVal lpsz As String, _
  4.     ByVal cbString As Long, _
  5.     lpSize As Size) As Long

  6. Public Type Size
  7.     cx   As Long
  8.     cy   As Long
  9. End Type
复制代码
      需要提醒的是,GetTextExtentPoint32的声明最好放在TabControl的代码窗口中,Size的声明最好放在单独的模块代码中。GetTextExtentPoint32函数所使用mMainDC参数指的是主体窗口的设备环境DC,大家只需要知道这个东西就可以了,因为只有得到这个才能调用GDI进行绘图,关于绘图我再专门讲述,所以这里大家不用纠结这个,记住它是个与主体相关的画图用的设备环境就行了。然后后面的代码意图是当mTabBars没有TabBar时,直接写入首个TabBar的数据,其中的Right值是字符宽度加上16(左右边距合计16个像素),当有TabBar时,根据前一个TabBar的数据设置当前添加TabBar的数据。随后将这个TabBar添加到集合中,并调用ReDrawTabBar方法把这个TabBar画出来。
     下面我们再来说下TabBar的删除操作,删除TabBar不仅仅是将其从mTabBars集合中清除掉,还要将窗体上的图像进行重绘,用背景色填充掉原先TabBar所在的位置,给查看者的感觉就是被删除掉了。代码如下,其中有2行代码(首行与末行)被我注释掉了,因为关于GDI绘图的方法我暂时还是写在了TabControl的代码里面,还没有完成对clsAccGDI类模块的代码,后面在说到GDI绘图时我还是继续讲述TabControl中的代码,大家有兴趣可以自己写写clsAccGDI类模块
  1. Public Sub RemoveTabBar()
  2. On Error GoTo Err_Handle
  3.     'Dim FormDrawer As New clsAccGDI
  4.     Dim mRect As Rect
  5.     Dim mLastIndex As Integer
  6.    
  7.     mLastIndex = mTabBars.count
  8.    
  9.     mRect.Left = mTabBars(mLastIndex).Left
  10.     mRect.Right = mTabBars(mLastIndex).Right
  11.     mRect.Bottom = mTabBars(mLastIndex).Bottom
  12.     mRect.Top = mTabBars(mLastIndex).Top
  13.     FillTargetRect RGB(255, 255, 255), mRect
  14.     mTabBars.Remove mLastIndex
  15.     GoTo Exit_Sub
  16. Err_Handle:
  17.     MsgBox "出错!"
  18. Exit_Sub:
  19.     'Set FormDrawer = Nothing
  20. End Sub
复制代码
     接下来我们再来看看如何在mTabBars中找到制定的TabBar,由于我之前的代码没有使用到Key,所以这里也没有基于Key来定位TabBar,我也没有写一个专门用于定位TabBar的方法,只是使用了最通用的For循环来查找,如果大家觉得不好,可以自己写个定位TabBar的方法。我这里把主体的MouseMove事件代码列出来说明下我搜索的方法。
  1. Private Sub 主体_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  2.     Dim intX As Integer
  3.     Dim pX As Long, pY As Long
  4.     Dim mCurrentOn As Integer
  5.    
  6.     pX = X / TwipsPerPixelX()
  7.     pY = Y / TwipsPerPixelY()
  8.    
  9.     For intX = 1 To mTabBars.count
  10.         If pX >= mTabBars(intX).Left And pX <= mTabBars(intX).Right And _
  11.             pY >= mTabBars(intX).Top And pY <= mTabBars(intX).Bottom Then
  12.             mTabBars(intX).IsMouseOn = True
  13.             ReDrawTabBar intX
  14.             mCurrentOn = intX
  15.             Exit For
  16.         End If
  17.         'Debug.Print "(x,y):(" & pX & "," & py & ")" & vbTab & "(Rx):(" & mTabBars(intX).Left & ")"
  18.     Next
  19.     If mPreTabBarOn <> mCurrentOn Then
  20.         If mPreTabBarOn > 0 Then
  21.             mTabBars(mPreTabBarOn).IsMouseOn = False
  22.             ReDrawTabBar mPreTabBarOn
  23.         End If
  24.         mPreTabBarOn = mCurrentOn
  25.     End If
  26.     'ReDraw
  27.     mMousePoint.X = pX
  28.     mMousePoint.Y = pY
  29. End Sub
复制代码
     说明下以上代码的意思,intX是个循环变量,在For循环中作为Index来遍历mTabBars集合,px,py是鼠标的坐标位置(像素值),VBA中MouseMove事件中返回X,Y是以Twip为单位的值,所以需要使用TwipsPerPixelX、TwipsPerPixelY自定义函数将其转换为像素值。建立一个模块mdlSysInfo,然后复制一下代码到模块中。随后以上的代码通过鼠标坐标值来判断其所在TabBar,找到时,完成一系列的设置操作,包括设置TabBar的IsMouseOn属性,重画TabBar并保存当前所处TabBar在mTabBars中的序号。随后再对之前鼠标所在的TabBar重画,并修改其IsMouseOn属性、保存之前鼠标所在TabBar的序号。最后保存鼠标当前位置数据,这个数据会在Click事件中使用到。
  1. Option Compare Database
  2. Option Explicit

  3. Public Type Size
  4.     cx   As Long
  5.     cy   As Long
  6. End Type

  7. Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long
  8. Private Declare Function ReleaseDC Lib "user32" (ByVal Hwnd As Long, ByVal hdc As Long) As Long
  9. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

  10. Private Const HWND_DESKTOP As Long = 0
  11. Private Const LOGPIXELSX As Long = 88
  12. Private Const LOGPIXELSY As Long = 90
  13.          
  14. 'Returns the width of a pixel, in twips.
  15. Public Function TwipsPerPixelX() As Single
  16.   Dim lngDC As Long
  17.   
  18.   lngDC = GetDC(HWND_DESKTOP)
  19.   TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
  20.   ReleaseDC HWND_DESKTOP, lngDC
  21. End Function

  22. 'Returns the height of a pixel, in twips.
  23. Public Function TwipsPerPixelY() As Single
  24.   Dim lngDC As Long
  25.   
  26.   lngDC = GetDC(HWND_DESKTOP)
  27.   TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
  28.   ReleaseDC HWND_DESKTOP, lngDC
  29. End Function
复制代码







点击这里给我发消息

 楼主| 发表于 2015-3-16 14:18:45 | 显示全部楼层

第三部分 实现TabControl的功能

本帖最后由 站到终点站 于 2015-3-17 11:38 编辑

     上一个部分我们已经讲了Tabs的功能实现,功能和代码部分可能还比较粗糙,有兴趣的可以自行完善下,下面我们来讲整个自定义“控件”的重点之一:TabControl子窗体容器的功能实现。TabControl子窗体是我们所谓的自定义“控件”的容器,同之前我们对Tab一样,我们也首先来分析下TabControl的各种特征。
1、必要的字段:窗体的各种句柄(子窗体句柄、窗体页眉句柄、窗体主体句柄、窗体页脚句柄)、设备环境(窗体主体的设备环境)、各种颜色相关的设置(鼠标在其上背/前景色、被选中背/前景色、默认背/前景色)、前一个鼠标移动到的TabBar序号、前一个被选中的TabBar序号、TabBar的集合以及鼠标当前位置;
      这里的设备环境我只使用了窗体主体的设备环境,因为在实例中我只使用主体,页眉页脚都隐藏了。其他还有部分字段并非是必要的,只是为了扩充完善功能新加入的,这里我就不再说明了,你可以自行根据需要添加修改。
2、与方法相关:添加与删除TabBar(这2个方法在前面讲Tabs集合的时候已经详细说了)、画TabBar方法(包括画所有Tab与画单个Tab)、前面这些方法都是共有的,就是使用这个控件时,我们可以看到这些方法,另外还有一个私有方法FillTargetRect,这个方法是用于画一个实心矩形的,它被画TabBar方法所调用,当使用TabControl这个控件时,这个方法是不可见的。
3、与事件相关:“控件”的初始化事件(就是TabControl窗体的Load事件,完成各种内置字段的初始化以及添加3个默认TabBar)、“控件”的销毁事件(就是TabControl窗体的UnLoad事件,完成各种对象和设备环境的清理工作)、“控件”的单击事件(通过主体的Click事件实现)用于根据鼠标单击位置触发TabBar单击事件、“控件”的鼠标移动事件(通过主体的MouseMove事件实现)、“控件”重绘事件(通过主体的Paint事件实现)用于重绘所有TabBar,以上所有事件都借助于窗体的事件来实现,另外还有一个自定义事件TabClick,该事件在“控件”的单击事件中被触发,同时反馈一个被单击TabBar的序号。      由于帖子内容过长,代码无法放下,我将TabControl的代码分成2段放了。这里面的代码还是有些Bug,大家自己可以参照着修改下,我一时半会儿还没法去调试这些Bug,当然大致的问题都不多,可能会是添加删除,以及鼠标移动时,可能会因为mPreTabBarSelected、mPreTabBarOn找不到而出现错误。
  1. Option Compare Database

  2. '****************************************************************************
  3. '发布日期:2015/03/16
  4. '描    述:在Access中通过子窗体实现自绘TabControl控件
  5. 'E-mail  :alex_ywt@163.com
  6. 'QQ      :21959068
  7. '          如需引用源代码,请注释代码出处
  8. '****************************************************************************

  9. Private Declare Function SetBkMode Lib "gdi32" ( _
  10.     ByVal hdc As Long, _
  11.     ByVal nBkMode As Long) As Long
  12. Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long
  13. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  14. Private Declare Function ReleaseDC Lib "user32" ( _
  15.     ByVal Hwnd As Long, _
  16.     ByVal hdc As Long) As Long
  17. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  18. Private Declare Function GetWindowDC Lib "user32" (ByVal Hwnd As Long) As Long
  19. Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
  20.     ByVal hWnd1 As Long, _
  21.     ByVal hWnd2 As Long, _
  22.     ByVal lpsz1 As String, _
  23.     ByVal lpsz2 As String) As Long
  24.    
  25. Private Declare Function Polygon Lib "gdi32" ( _
  26.     ByVal hdc As Long, _
  27.     lpPoint As POINTAPI, _
  28.     ByVal nCount As Long) As Long
  29. Private Declare Function Rectangle Lib "gdi32" ( _
  30.     ByVal hdc As Long, _
  31.     ByVal X1 As Long, _
  32.     ByVal Y1 As Long, _
  33.     ByVal X2 As Long, _
  34.     ByVal Y2 As Long) As Long
  35. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _
  36.     ByVal hInst As Long, _
  37.     ByVal lpsz As String, _
  38.     ByVal un1 As Long, _
  39.     ByVal n1 As Long, _
  40.     ByVal n2 As Long, _
  41.     ByVal un2 As Long) As Long
  42. Private Declare Function BitBlt Lib "gdi32" ( _
  43.     ByVal hDestDC As Long, _
  44.     ByVal x As Long, _
  45.     ByVal y As Long, _
  46.     ByVal nWidth As Long, _
  47.     ByVal nHeight As Long, _
  48.     ByVal hSrcDC As Long, _
  49.     ByVal xSrc As Long, _
  50.     ByVal ySrc As Long, _
  51.     ByVal dwRop As Long) As Long
  52. Private Declare Function CreateBitmap Lib "gdi32" ( _
  53.     ByVal nWidth As Long, _
  54.     ByVal nHeight As Long, _
  55.     ByVal nPlanes As Long, _
  56.     ByVal nBitCount As Long, _
  57.     lpBits As Any) As Long
  58. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  59. Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitMap As Long) As Long
  60. Private Declare Function SelectObject Lib "gdi32" ( _
  61.     ByVal hdc As Long, _
  62.     ByVal hObject As Long) As Long
  63. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" ( _
  64.     ByVal hObject As Long, _
  65.     ByVal nCount As Long, _
  66.     lpObject As Any) As Long
  67. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  68. Private Declare Function InvalidateRectAsAny Lib "user32" Alias "InvalidateRect" ( _
  69.     ByVal Hwnd As Long, _
  70.     lpRect As Any, _
  71.     ByVal bErase As Long) As Long
  72. Private Declare Function FillRect Lib "user32" ( _
  73.     ByVal hdc As Long, _
  74.     lpRect As Rect, _
  75.     ByVal hBrush As Long) As Long
  76. Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
  77.     ByVal hdc As Long, _
  78.     ByVal lpsz As String, _
  79.     ByVal cbString As Long, _
  80.     lpSize As Size) As Long
  81. Private Declare Function DrawText Lib "user32" Alias "DrawTextA" ( _
  82.     ByVal hdc As Long, _
  83.     ByVal lpStr As String, _
  84.     ByVal nCount As Long, _
  85.     lpRect As Rect, _
  86.     ByVal wFormat As Long) As Long

  87. Private Const IMAGE_BITMAP = 0
  88. Private Const LR_LOADFROMFILE = &H10
  89. Private Const LR_CREATEDIBSECTION = &H2000

  90. Private Const TRANSPARENT = 1

  91. 'wFormat文字输出格式,DT即Draw Text
  92. Private Const DT_BOTTOM = &H8 '靠底输出,必须与DT_SINGLELINE配合(用OR)
  93. Private Const DT_CENTER = &H1  '居中
  94. Private Const DT_CALCRECT = &H400  '自动计算(调整)输出区域的大小
  95. Private Const DT_EXPANDTABS = &H40   '将Tab字符视为定位点
  96. Private Const DT_EXTERNALLEADING = &H200 '包含行间距
  97. Private Const DT_LEFT = &H0           '居左
  98. Private Const DT_NOCLIP = &H100    '文字输出不受限于输出区域
  99. Private Const DT_NOPREFIX = &H800 '不处理前导字符&。若不指定,会把紧跟的字母加下划线(类似定义菜单快捷键)
  100. Private Const DT_RIGHT = &H2       '居右
  101. Private Const DT_SINGLELINE = &H20  '单行输出
  102. Private Const DT_TABSTOP = &H80   '设置定位点,wFormat中高字节8-15位表示定位点的宽度(默认8)
  103. Private Const DT_TOP = &H0       '居上,须与DT_SINGLELINE配合
  104. Private Const DT_VCENTER = &H4   '垂直居中,须与DT_SINGLELINE配合
  105. Private Const DT_WORDBREAK = &H10 '超过右边界时,自动换行

  106. Private mFormHwnd As Long
  107. Private mFormHeaderHwnd As Long
  108. Private mFormMainHwnd As Long
  109. Private mFormFooterHwnd As Long
  110. Private mMainDC As Long
  111. Private mCurrentDrawTarget As ENUM_DrawTarget

  112. Private mMouseLeaveBackColor As OLE_COLOR   '鼠标移开后显示的背景色
  113. Private mMouseOnBackColor As OLE_COLOR      '鼠标在其上显示的背景色
  114. Private mSelectedBackColor As OLE_COLOR     '当前项被选中时的背景色

  115. Private mMouseLeaveFontColor As OLE_COLOR   '鼠标移开后显示的前景色
  116. Private mMouseOnFontColor As OLE_COLOR      '鼠标在其上显示的前景色
  117. Private mSelectedFontColor As OLE_COLOR     '当前项被选中时的前景色

  118. Private mMouseLeaveBorderColor As OLE_COLOR '鼠标移开后显示的边框色
  119. Private mMouseOnBorderColor As OLE_COLOR    '鼠标在其上显示的边框色
  120. Private mSelectedBorderColor As OLE_COLOR   '当前项被选中时的边框色

  121. Private mBorderWidth As Long                '边框的宽度

  122. Private mTabBars As New Collection
  123. Private mPreTabBarOn As Integer
  124. Private mPreTabBarSelected As Integer

  125. Private mMousePoint As POINTAPI

  126. Public Event TabClick(Index As Integer)
复制代码




点击这里给我发消息

 楼主| 发表于 2015-3-16 14:18:59 | 显示全部楼层

第三部分 TabControl的实现代码

本帖最后由 站到终点站 于 2015-3-17 11:40 编辑
  1. Private Sub Form_Load()
  2.     mMouseLeaveBackColor = RGB(155, 155, 155)   '鼠标移开后显示的背景色
  3.     mMouseOnBackColor = RGB(0, 255, 255)      '鼠标在其上显示的背景色
  4.     mSelectedBackColor = RGB(255, 0, 0)    '当前项被选中时的背景色
  5.    
  6.     mMouseLeaveFontColor = RGB(255, 255, 255)   '鼠标移开后显示的前景色
  7.     mMouseOnFontColor = RGB(0, 0, 255)          '鼠标在其上显示的前景色
  8.     mSelectedFontColor = RGB(0, 0, 0)           '当前项被选中时的前景色

  9.     mMouseLeaveBorderColor = RGB(155, 155, 155) '鼠标移开后显示的边框色
  10.     mMouseOnBorderColor = RGB(155, 155, 155)    '鼠标在其上显示的边框色
  11.     mSelectedBorderColor = RGB(155, 155, 155)   '当前项被选中时的边框色
  12.    
  13.     mFormHeaderHwnd = FindWindowEx(Me.Hwnd, 0&, "OFormSub", vbNullString)
  14.     mFormMainHwnd = FindWindowEx(Me.Hwnd, mFormHeaderHwnd, "OFormSub", vbNullString)
  15.     mMainDC = GetWindowDC(mFormMainHwnd)
  16.    
  17.     SetBkMode mMainDC, TRANSPARENT
  18.    
  19.     Me.InsideHeight = 30 * TwipsPerPixelY
  20.     For I = 1 To 3
  21.         AddTabBar "", "Tab" & I, ""
  22.     Next
  23.     'ReDraw
  24. End Sub

  25. Private Sub Form_Unload(Cancel As Integer)
  26.     ReleaseDC mFormMainHwnd, mMainDC
  27.     Set mTabBars = Nothing
  28. End Sub

  29. Private Sub 主体_Click()
  30.     Dim intX As Integer
  31.     Dim mCurrentSelected As Integer
  32.    
  33.     For intX = 1 To mTabBars.count
  34.         If mMousePoint.x >= mTabBars(intX).Left And mMousePoint.x <= mTabBars(intX).Right And _
  35.             mMousePoint.y >= mTabBars(intX).Top And mMousePoint.y <= mTabBars(intX).Bottom Then
  36.             mTabBars(intX).Selected = True
  37.             ReDrawTabBar intX
  38.             mCurrentSelected = intX
  39.             Exit For
  40.         End If
  41.         'Debug.Print "(x,y):(" & pX & "," & py & ")" & vbTab & "(Rx):(" & mTabBars(intX).Left & ")"
  42.     Next
  43.     If mPreTabBarSelected <> mCurrentSelected Then
  44.         If mPreTabBarSelected > 0 And mCurrentSelected > 0 Then
  45.             mTabBars(mPreTabBarSelected).Selected = False
  46.             ReDrawTabBar mPreTabBarSelected
  47.         End If
  48.         mPreTabBarSelected = mCurrentSelected
  49.         RaiseEvent TabClick(mCurrentSelected)
  50.     End If
  51. End Sub

  52. Private Sub 主体_DblClick(Cancel As Integer)
  53.     'Static dblClickCount As Long
  54.     'dblClickCount = dblClickCount + 1
  55.     'AddTabBar "", "双击添加Tab" & dblClickCount, ""
  56.     'ReDraw
  57. End Sub

  58. Private Sub 主体_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  59.     Dim intX As Integer
  60.     Dim pX As Long, pY As Long
  61.     Dim mCurrentOn As Integer
  62.    
  63.     pX = x / TwipsPerPixelX()
  64.     pY = y / TwipsPerPixelY()
  65.    
  66.     For intX = 1 To mTabBars.count
  67.         If pX >= mTabBars(intX).Left And pX <= mTabBars(intX).Right And _
  68.             pY >= mTabBars(intX).Top And pY <= mTabBars(intX).Bottom Then
  69.             mTabBars(intX).IsMouseOn = True
  70.             ReDrawTabBar intX
  71.             mCurrentOn = intX
  72.             Exit For
  73.         End If
  74.         'Debug.Print "(x,y):(" & pX & "," & py & ")" & vbTab & "(Rx):(" & mTabBars(intX).Left & ")"
  75.     Next
  76.     If mPreTabBarOn <> mCurrentOn Then
  77.         If mPreTabBarOn > 0 Then
  78.             mTabBars(mPreTabBarOn).IsMouseOn = False
  79.             ReDrawTabBar mPreTabBarOn
  80.         End If
  81.         If mCurrentOn > 0 Then
  82.             mPreTabBarOn = mCurrentOn
  83.         Else
  84.             mPreTabBarOn = 0
  85.         End If
  86.     End If
  87.     'ReDraw
  88.     mMousePoint.x = pX
  89.     mMousePoint.y = pY
  90. End Sub

  91. Private Sub 主体_Paint()
  92.     ReDraw
  93. End Sub

  94. Public Property Get TabCount() As Long
  95.     TabCount = mTabBars.count
  96. End Property

  97. Public Sub AddTabBar(ByVal Key As String, ByVal Text As String, ByVal TargetForm As String)
  98.     Dim mTabBar As New clsAccTabBar
  99.     Dim lngText As Long
  100.     Dim mTextSize As Size
  101.    
  102.     lngText = LenB(StrConv(Text, vbFromUnicode))
  103.     GetTextExtentPoint32 mMainDC, Text, lngText, mTextSize

  104.     If TabCount = 0 Then
  105.         mTabBar.Left = 0
  106.         mTabBar.Top = 0
  107.         mTabBar.Right = mTextSize.cx + 16
  108.         mTabBar.Bottom = 30
  109.     Else
  110.         mTabBar.Left = mTabBars(TabCount).Right + 0.6
  111.         mTabBar.Top = 0
  112.         mTabBar.Right = mTabBar.Left + mTextSize.cx + 16
  113.         mTabBar.Bottom = 30
  114.     End If
  115.     mTabBar.Text = Text
  116.     mTabBars.Add mTabBar
  117.     ReDrawTabBar mTabBars.count
  118. End Sub

  119. Public Sub RemoveTabBar()
  120. On Error GoTo Err_Handle
  121.     'Dim FormDrawer As New clsAccGDI
  122.     Dim mRect As Rect
  123.     Dim mLastIndex As Integer
  124.    
  125.     mLastIndex = mTabBars.count
  126.    
  127.     mRect.Left = mTabBars(mLastIndex).Left
  128.     mRect.Right = mTabBars(mLastIndex).Right
  129.     mRect.Bottom = mTabBars(mLastIndex).Bottom
  130.     mRect.Top = mTabBars(mLastIndex).Top
  131.     FillTargetRect RGB(255, 255, 255), mRect
  132.     If mTabBars(mLastIndex).Selected Then mPreTabBarSelected = 0
  133.     'rt = DrawText(mMainDC, mTabBars(Index).Text, LenB(StrConv(mTabBars(Index).Text, vbFromUnicode)), mRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
  134.     mTabBars.Remove mLastIndex
  135.     GoTo Exit_Sub
  136. Err_Handle:
  137.     MsgBox "出错!"
  138. Exit_Sub:
  139.     'Set FormDrawer = Nothing
  140. End Sub

  141. Public Sub ReDraw()
  142. On Error GoTo Err_Handle
  143.     'Dim FormDrawer As New clsAccGDI
  144.     Dim mRect As Rect
  145.     Dim mTabCount As Long
  146.    
  147.     mTabCount = TabCount
  148.    
  149.     For I = 1 To mTabCount
  150.         mRect.Left = mTabBars(I).Left
  151.         mRect.Right = mTabBars(I).Right
  152.         mRect.Bottom = mTabBars(I).Bottom
  153.         mRect.Top = mTabBars(I).Top
  154.         If mTabBars(I).Selected Then
  155.             FillTargetRect RGB(255, 0, 0), mRect
  156.         Else
  157.             If mTabBars(I).IsMouseOn Then
  158.                 FillTargetRect RGB(0, 255, 0), mRect
  159.             Else
  160.                 FillTargetRect RGB(255, 255, 0), mRect
  161.             End If
  162.         End If
  163.         rt = DrawText(mMainDC, mTabBars(I).Text, LenB(StrConv(mTabBars(I).Text, vbFromUnicode)), mRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
  164.     Next

  165.     GoTo Exit_Sub
  166. Err_Handle:
  167.     MsgBox "出错!"
  168. Exit_Sub:
  169.     'Set FormDrawer = Nothing
  170. End Sub

  171. Public Sub ReDrawTabBar(Index As Integer)
  172. On Error GoTo Err_Handle
  173.     'Dim FormDrawer As New clsAccGDI
  174.     Dim mRect As Rect
  175.    
  176.     mRect.Left = mTabBars(Index).Left
  177.     mRect.Right = mTabBars(Index).Right
  178.     mRect.Bottom = mTabBars(Index).Bottom
  179.     mRect.Top = mTabBars(Index).Top
  180.     If mTabBars(Index).Selected Then
  181.         FillTargetRect RGB(255, 0, 0), mRect
  182.     Else
  183.         If mTabBars(Index).IsMouseOn Then
  184.             FillTargetRect RGB(0, 255, 0), mRect
  185.         Else
  186.             FillTargetRect RGB(255, 255, 0), mRect
  187.         End If
  188.     End If
  189.     rt = DrawText(mMainDC, mTabBars(Index).Text, LenB(StrConv(mTabBars(Index).Text, vbFromUnicode)), mRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)

  190.     GoTo Exit_Sub
  191. Err_Handle:
  192.     MsgBox "出错!"
  193. Exit_Sub:
  194.     'Set FormDrawer = Nothing
  195. End Sub

  196. Private Sub FillTargetRect(DrawColor As OLE_COLOR, TargetRect As Rect)
  197.     Dim hOldBrush As Long
  198.     Dim hBrush As Long
  199.    
  200.     hBrush = CreateSolidBrush(CLng(DrawColor))
  201.     hOldBrush = SelectObject(mMainDC, hBrush)
  202.     FillRect mMainDC, TargetRect, hBrush
  203.     'Rectangle hdc, TargetRect.Left, TargetRect.Top, TargetRect.Right, TargetRect.Bottom
  204.     SelectObject mMainDC, hOldBrush
  205.     DeleteObject hBrush
  206. End Sub
复制代码


点击这里给我发消息

 楼主| 发表于 2015-3-16 14:19:12 | 显示全部楼层

第四部分 TabControl控件的使用

本帖最后由 站到终点站 于 2015-3-17 13:43 编辑

     到此为止,相关的一些核心代码已经全部贴出来了,TabControl窗体中的代码包含了很多的API函数声明,并在TabControl中通过GDI完成了绘图操作,但是我暂时还不打算去解释这些API函数以及Access中如何通过GDI进行绘图。我先说明下如何来使用这个TabControl控件。因为即使使用的人不知道TabControl是如何具体实现其功能的,也不妨碍使用它。通过我们所提供的属性、方法以及事件就可以操作这个控件,这就是面向对象编程的好处。类模块或者窗体封装后,使用人只需要知道其公用的属性、方法以及事件(也就是我们流行讲的接口),就可以轻松使用这些东西,跟我们Access内置的其他控件一样。
      好吧,那么我们就先来看看frmTest窗体是如何使用TabControl这个子窗体控件的。这个窗体的界面非常简单,包括一个子窗体以及2个按钮(添加喝删除),将之前所建立的TabControl窗体直接拖入frmTest窗体中就可以建立一个子窗体。下面我们来看看它的代码:
  1. Option Compare Database

  2. '****************************************************************************
  3. '发布日期:2015/03/16
  4. '描    述:自绘TabControl控件的测试窗体
  5. 'E-mail  :alex_ywt@163.com
  6. 'QQ      :21959068
  7. '          如需引用源代码,请注释代码出处
  8. '****************************************************************************

  9. Private WithEvents mTabControl As Form_TabControl

  10. Private Sub cmdAdd_Click()
  11.     Static iCount As Integer
  12.     iCount = iCount + 1
  13.     mTabControl.AddTabBar "", "UserTab" & iCount, ""
  14. End Sub

  15. Private Sub cmdDelete_Click()
  16.     mTabControl.RemoveTabBar
  17. End Sub

  18. Private Sub mTabControl_TabClick(Index As Integer)
  19.     MsgBox Index
  20. End Sub

  21. Private Sub 主体_Paint()
  22.     Set mTabControl = Me.TabControl1.Form
  23. End Sub
复制代码
     窗体的代码非常简单,熟悉面向对象编程及事件使用的朋友还会感觉代码非常熟悉,那么下面我就来简单的说下:     我们把TabControl视作控件后,并且要使用它的事件,所以我们需要声明一个WithEvents标识的Form_TabControl对象变量,并且将其声明为私有的,这里不用New,因为我们要将其与窗体上的那个子窗体关联起来。那么关联的时机这里需要注意下,因为在Access中窗体加载的时候不一定子窗体会同是完成加载,所以Set mTabControl = Me.TabControl1.Form这句不能放在窗体的Load事件中,我这里选择了主体的Paint事件,这个时候子窗体必定完成了加载,所以此时的Me.TabControl1.Form必定不会为Nothing。
     2个按钮的单击事件非常简单,直接调用TabControl控件的相应方法即可,而TabClick事件直接通过事件选择栏选择出来就行(如果大家不知道如何弄出这个mTabControl_TabClick事件过程的话,可以百度或者论坛上去看看VBA中类模块的自定义事件的内容)。最后我在补充一句要获取子窗体中的窗体对象,需要使用子窗体的Form属性,Access的子窗体只是一个容器。




点击这里给我发消息

 楼主| 发表于 2015-3-16 14:19:25 | 显示全部楼层

第五部分 Access中GDI绘图(Access窗体结构)

本帖最后由 站到终点站 于 2015-3-20 12:02 编辑

     帖子的一个重点内容我们还没有涉及到,这一部分我们就来研究下Access中如何进行GDI绘图。GDI是Windows中用于完成绘图的API函数的集合总称,大部分的函数都包含在gdi32.dll这个动态链接库文件中。要说明的是在Windows中完成绘图,并不止GDI一种API函数集合,还有其他的,不过这也是最基础的。当然,在Windows中无论是通过GDI还是其他的什么API函数集合,其界面最终都是画出来的。画一次是一个静态的界面,不停的画,不停的对变化区域画就让我们看到了动态的界面。我们通过自绘并结合鼠标移动、双击等事件,不停的对窗体进行重画,就产生了能对用户操作作出反应的Windows界面,也就达成了自绘控件的目的。     使用GDI绘图类似于我们画画,首先我们需要准备好画画所需要的材料跟设备,包括画布、画笔、颜料、贴画等,GDI中所对应的就有设备环境DC(相当于画布)、画笔、画刷、字体、图片等。然后我们需要构思图画的内容,安排下画画的动作次序以及一些画画的技巧,GDI中所对应的就是明确最终图形的外观、使用哪些API函数以及函数的使用先后顺序。
     首先我们来解决第一个问题,就是在Access中画图时,如何做好材料设备的准备工作。首先我们需要一张画布,既然我们需要在窗体中画(我们可以把窗体看做是画板),那就得获取“铺”在窗体画板上的画布。这个画布是依据窗体画板量身定做的,所以我们得根据窗体画板的标识号来定制一个画布,这个标识号就是窗体的句柄。我们将窗体句柄传递给GetWindowDC这个函数就可以获取一个与该窗体对应的画布。
     所以现在的问题就转换为如何获取窗体的标识符即句柄了。Access的窗体比较特殊,它包括了窗体页眉、窗体主体、窗体页脚三个窗体,即使没有显示窗体页眉和页脚,它们也只是被隐藏了而已。通俗点说,就是Access窗体这个画板上还放了三块画板,这三块画板你都撤不掉,它们一定放在那块窗体画板的上面,只是我们可以隐藏其中几块而已。如果我们通过Access窗体本身的hwnd属性获取画布并画内容的话,这些画的内容将被窗体页眉、窗体主体和窗体页脚所遮挡,所以我们在Access中画图的时候通常会在主体上进行绘画。

点击这里给我发消息

 楼主| 发表于 2015-3-16 14:19:38 | 显示全部楼层
占位用7
回复

使用道具 举报

点击这里给我发消息

 楼主| 发表于 2015-3-16 14:19:51 | 显示全部楼层
占位用8
回复

使用道具 举报

点击这里给我发消息

 楼主| 发表于 2015-3-16 14:20:06 | 显示全部楼层
占位用9
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 07:20 , Processed in 0.116173 second(s), 38 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

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