存档

2008年5月 的存档

三维立体图片集合

2008年5月9日 岩岩魂   访问量: 472 没有评论
分类: 未分类 标签:

VB打造超酷个性化菜单(2)

2008年5月8日 岩岩魂   访问量: 477 没有评论
其实,漂亮的界面都是“画”出来的,菜单当然也不例外。既然是“画”出来的,就需要有窗体来接收“画”菜单这个消息,后面我们会看到,实际上不仅仅是“画”这个消息,一切关于这个菜单的消息都要有一个窗体来接收。 如果你对消息不太了解,可以看看网上其它一些关于Windows消息机制的文章。不了解也没有关系,只要会使用就可以了,后面的文章给出了完整的源代码,而且文章的最后还给出了源代码的下载地址。

     下面我们来创建接收消息的窗体:打开上次建好的工程,添加一个窗体,并将其名称设置为frmMenu(注意:这一步是必须的)。还记得上篇文章的最后一幅图吗?菜单左边那个黑底色的附加条,为了方便,将frmMenu的Picture属性设置成那幅图。到此,这个窗体就算OK了!对了,就这样,因为这个窗体仅仅是为了处理消息和存储那个黑底色的风格条,我们将会对它进行子类处理,处理消息的代码全部都放在了将在下一篇中详细介绍的标准模块中。

     接下来添加一个类模块,并将其名称设置为cMenu,代码如下:

'*************************************************************
'* 本类模块是一个菜单类, 提供了各种样式的菜单的制作方案
'*
'* 版权: LPP软件工作室
'* 作者: 卢培培(goodname008)
'* (******* 复制请保留以上信息 *******)
'*************************************************************
Option Explicit
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long,
ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long,
ByVal hwnd As Long, lprc As Any) As Long
Public Enum MenuUserStyle                                    ' 菜单总体风格
     STYLE_WINDOWS
     STYLE_XP
     STYLE_SHADE
     STYLE_3D
     STYLE_COLORFUL
End Enum
Public Enum MenuSeparatorStyle                               ' 菜单分隔条风格
     MSS_SOLID
     MSS_DASH
     MSS_DOT
     MSS_DASDOT
     MSS_DASHDOTDOT
     MSS_NONE
     MSS_DEFAULT
End Enum
Public Enum MenuItemSelectFillStyle                          ' 菜单项背景填充风格
     ISFS_NONE
     ISFS_SOLIDCOLOR
     ISFS_HORIZONTALCOLOR
     ISFS_VERTICALCOLOR
End Enum
Public Enum MenuItemSelectEdgeStyle                          ' 菜单项边框风格
     ISES_SOLID
     ISES_DASH
     ISES_DOT
     ISES_DASDOT
     ISES_DASHDOTDOT
     ISES_NONE
     ISES_SUNKEN
     ISES_RAISED
End Enum
Public Enum MenuItemIconStyle                                ' 菜单项图标风格
     IIS_NONE
     IIS_SUNKEN
     IIS_RAISED
     IIS_SHADOW
End Enum
Public Enum MenuItemSelectScope                              ' 菜单项高亮条的范围
     ISS_TEXT = &H1
     ISS_ICON_TEXT = &H2
     ISS_LEFTBAR_ICON_TEXT = &H4
End Enum
Public Enum MenuLeftBarStyle                                 ' 菜单附加条风格
     LBS_NONE
     LBS_SOLIDCOLOR
     LBS_HORIZONTALCOLOR
     LBS_VERTICALCOLOR
     LBS_IMAGE
End Enum
Public Enum MenuItemType                                     ' 菜单项类型
     MIT_STRING = &H0
     MIT_CHECKBOX = &H200
     MIT_SEPARATOR = &H800
End Enum
Public Enum MenuItemState                                    ' 菜单项状态
     MIS_ENABLED = &H0
     MIS_DISABLED = &H2
     MIS_CHECKED = &H8
     MIS_UNCHECKED = &H0
End Enum
Public Enum PopupAlign                                       ' 菜单弹出对齐方式
     POPUP_LEFTALIGN = &H0&                                   ' 水平左对齐
     POPUP_CENTERALIGN = &H4&                                 ' 水平居中对齐
     POPUP_RIGHTALIGN = &H8&                                  ' 水平右对齐
     POPUP_TOPALIGN = &H0&                                    ' 垂直上对齐
     POPUP_VCENTERALIGN = &H10&                               ' 垂直居中对齐
     POPUP_BOTTOMALIGN = &H20&                                ' 垂直下对齐
End Enum
' 释放类
Private Sub Class_Terminate()
     SetWindowLong frmMenu.hwnd, GWL_WNDPROC, preMenuWndProc
     Erase MyItemInfo
     DestroyMenu hMenu
End Sub
' 创建弹出式菜单
Public Sub CreateMenu()
     preMenuWndProc = SetWindowLong(frmMenu.hwnd, GWL_WNDPROC, AddressOf MenuWndProc)
     hMenu = CreatePopupMenu()
     Me.Style = STYLE_WINDOWS
End Sub
' 插入菜单项并保存自定义菜单项数组, 设置Owner_Draw自绘菜单
Public Sub AddItem(ByVal itemAlias As String, ByVal itemIcon As StdPicture,
ByVal itemText As String, ByVal itemType As MenuItemType,
Optional ByVal itemState As MenuItemState)
     Static ID As Long, i As Long
     Dim ItemInfo As MENUITEMINFO
     ' 插入菜单项
     With ItemInfo
         .cbSize = LenB(ItemInfo)
         .fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_STATE Or
MIIM_SUBMENU Or MIIM_ID Or MIIM_DATA
         .fType = itemType
         .fState = itemState
         .wID = ID
         .dwItemData = True
         .cch = lstrlen(itemText)
         .dwTypeData = itemText
     End With
     InsertMenuItem hMenu, ID, False, ItemInfo
     ' 将菜单项数据存入动态数组
     ReDim Preserve MyItemInfo(ID) As MyMenuItemInfo
     For i = 0 To UBound(MyItemInfo)
         If MyItemInfo(i).itemAlias = itemAlias Then
             Class_Terminate
             Err.Raise vbObjectError + 513, "cMenu", "菜单项别名相同."
         End If
     Next i
     With MyItemInfo(ID)
         Set .itemIcon = itemIcon
         .itemText = itemText
         .itemType = itemType
         .itemState = itemState
         .itemAlias = itemAlias
     End With
     ' 获得菜单项数据
     With ItemInfo
         .cbSize = LenB(ItemInfo)
         .fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE
     End With
     GetMenuItemInfo hMenu, ID, False, ItemInfo
     ' 设置菜单项数据
     With ItemInfo
         .fMask = .fMask Or MIIM_TYPE
         .fType = MFT_OWNERDRAW
     End With
     SetMenuItemInfo hMenu, ID, False, ItemInfo
     ' 菜单项ID累加
     ID = ID + 1
End Sub
' 删除菜单项
Public Sub DeleteItem(ByVal itemAlias As String)
     Dim i As Long
     For i = 0 To UBound(MyItemInfo)
         If MyItemInfo(i).itemAlias = itemAlias Then
             DeleteMenu hMenu, i, 0
             Exit For
         End If
     Next i
End Sub
' 弹出菜单
Public Sub PopupMenu(ByVal x As Long, ByVal y As Long, ByVal Align As PopupAlign)
     TrackPopupMenu hMenu, Align, x, y, 0, frmMenu.hwnd, ByVal 0
End Sub
' 设置菜单项图标
Public Sub SetItemIcon(ByVal itemAlias As String, ByVal itemIcon As StdPicture)
     Dim i As Long
     For i = 0 To UBound(MyItemInfo)
         If MyItemInfo(i).itemAlias = itemAlias Then
             Set MyItemInfo(i).itemIcon = itemIcon
             Exit For
         End If
     Next i
End Sub
' 获得菜单项图标
Public Function GetItemIcon(ByVal itemAlias As String) As StdPicture
     Dim i As Long
     For i = 0 To UBound(MyItemInfo)
         If MyItemInfo(i).itemAlias = itemAlias Then
             Set GetItemIcon = MyItemInfo(i).itemIcon
             Exit For
         End If
     Next i
End Function
' 设置菜单项文字
Public Sub SetItemText(ByVal itemAlias As String, ByVal itemText As String)
     Dim i As Long
     For i = 0 To UBound(MyItemInfo)
         If MyItemInfo(i).itemAlias = itemAlias Then
             MyItemInfo(i).itemText = itemText
             Exit For
         End If
     Next i
End Sub
' 获得菜单项文字
Public Function GetItemText(ByVal itemAlias As String) As String
     Dim i As Long
     For i = 0 To UBound(MyItemInfo)
         If MyItemInfo(i).itemAlias = itemAlias Then
             GetItemText = MyItemInfo(i).itemText
             Exit For
         End If
     Next i
End Function

分类: 未分类 标签:

VB打造超酷个性化菜单1

2008年5月8日 岩岩魂   访问量: 470 没有评论
  众所周知,MS Office 2003推出已经有一段时间了,但我们依然不会忘记Office XP刚刚推出时其令人耳目一新的菜单给我们留下的深刻印象。突起的悬浮式图标,不同寻常的菜单项填充方式,不仅让办公一族们赞不绝口,更让广大的程序员和编程爱好者对这种风格的菜单的制作产生了浓厚的兴趣。所以,在这篇文章里,我们就来好好地研究研究用VB怎么制作这种风格的菜单,在文章的最后,我将给出源代码的下载地址。事实上,在了解其原理以后,不论是用VB、VC还是Delphi,都能够制作出XP风格的菜单。不仅如此,我们还可以制作出更加充满个性的另类风格的菜单,比如3D立体风格、渐变风格、多彩风格等等。只有想不到的,没有做不到的。Follow me!

  现在,我想有必要说一说我们现在要做的事情。事实上,我们只要做一个菜单类就行了。但谁都会明白,只做一个菜单类是不够的,我们需要一个程序,或者更详细的说,是一个窗体,来测试我们的菜单类。在我个人的开发过程中,我是先写的菜单类,后写的测试窗体,但为了让大家先领略一下写好的菜单类在应用时是多么的方便,所以让我们先来看看测试窗体:

  (1)打开VB,新建“标准EXE”工程。

  (2)­­下面是窗体的控件:

组件名称

属性

Form

Name

Caption

frmMain

菜单例子

Frame

Name

Caption

fraStyle

菜单风格

Label

Name

Caption

lblHelp

在窗体空白处单击鼠标右键

OptionButton

Name

Caption

Index

opnStyle

Window 标准

0

OptionButton

Name

Caption

Index

opnStyle

XP 风格

1

OptionButton

Name

Caption

Index

opnStyle

3D 立体风格

2

OptionButton

Name

Caption

Index

opnStyle

渐变风格

3

OptionButton

Name

Caption

Index

opnStyle

多彩风格

4

  其实就是在窗体上添加了一个Frame,然后在Frame里添加OptionButton控件数组,用来设置菜单风格,还有一个Label,上面只显示一行提示文字,非常简单。

 (3)窗体代码:

Option Explicit

Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Dim menu As cMenu

Private Sub Form_Load()
    ' 初始化菜单并添加菜单项
    Set menu = New cMenu
    menu.CreateMenu
    menu.AddItem "open", LoadPicture("images\open.ico"), "打开", MIT_STRING
    menu.AddItem "save", LoadPicture("images\save.ico"), "保存", MIT_STRING
    menu.AddItem "print", LoadPicture("images\print.ico"), "打印", MIT_STRING
    menu.AddItem "find", LoadPicture("images\find.ico"), "查找", MIT_STRING
    menu.AddItem "sep1", LoadPicture(), "", MIT_SEPARATOR
    menu.AddItem "undo", LoadPicture("images\undo.ico"), "撤消", MIT_STRING
    menu.AddItem "redo", LoadPicture("images\redo.ico"), "重复", MIT_STRING
    menu.AddItem "sep2", LoadPicture(), "", MIT_SEPARATOR
    menu.AddItem "cut", LoadPicture("images\cut.ico"), "剪切", MIT_STRING
    menu.AddItem "copy", LoadPicture("images\copy.ico"), "复制", MIT_STRING
    menu.AddItem "paste", LoadPicture("images\paste.ico"), "粘贴", MIT_STRING
    menu.AddItem "sep3", LoadPicture(), "", MIT_SEPARATOR
    menu.AddItem "check", LoadPicture("images\check.ico"), "一个 CheckBox", MIT_CHECKBOX
    menu.AddItem "exit", LoadPicture("images\exit.ico"), "退出", MIT_STRING
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' 单击鼠标右建弹出菜单
    If Button = vbRightButton Then
        Dim pos As POINTAPI
        GetCursorPos pos
        menu.PopupMenu pos.X, pos.Y, POPUP_LEFTALIGN Or POPUP_TOPALIGN
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' 释放资源, 卸载窗体
    Set menu = Nothing
    Dim frm As Form
    For Each frm In Forms
        Unload frm
    Next
End Sub

Private Sub opnStyle_Click(Index As Integer)
    ' 设置菜单风格
    Select Case Index
        Case 0                                  ' Windows 标准
            menu.Style = STYLE_WINDOWS
        Case 1                                  ' XP 风格
            menu.Style = STYLE_XP
        Case 2                                  ' 3D 立体风格
            menu.Style = STYLE_3D
        Case 3                                  ' 渐变风格
            menu.Style = STYLE_SHADE
        Case 4                                  ' 多彩风格
            menu.Style = STYLE_COLORFUL
    End Select

End Sub

  代码中创建了一个cMenu类的对象,我们的编程重点将会放在cMenu类上,上面的代码只是简单地调用cMenu。在后面的文章中,我们会看到其实cMenu有多达30个方法和属性供我们调用,它的Style属性只提供了5种内置风格,在实际应用中,我们可以利用cMenu类提供的方法和属性制作出各种各样风格的菜单,为自己的程序锦上添花。



(4)运行结果:

图1

图2

图3

图4

图5

  这篇文章只是抛砖引玉,让大家先睹为快,提前体验一下这个菜单类的魅力。在下一篇中,我们将继续讨论个性化菜单的制作,不一样的是,我们的重点将是那个cMenu类。   :)

  未完待续…

分类: 未分类 标签:

VB 判断鼠标是否离开控件

2008年5月8日 岩岩魂   访问量: 665 没有评论
如何得知Mouse已离开某物件(Mouse Hook)

来源:cww

常见到某些软体,当Mouse进入其区域时,会启动某个行为,Mouse离开时,又有其他的
动作,例如Cool Bar,当Mouse移入时,Button会上升,离开时Button水变平面

第一个想到的是在物件的MouseMove中设定进入的行为,这没有问题,但离开呢?有几
个想法:1.如果该物件在Form上,可以在Form的MouseMove上作离开的动作。2.於该物
件的MouseMove上Check是否Mouse的座标已在物件的边缘,若是则执行离开的动作。
但这两者,都会遇上一个问题,如果Mouse的移动很快,使得MouseMove的Event根本没
有在该物件或Form上面发生,那就不可行了;所以看来简单的问题又变复杂了,那只好
使用Mouse Hook来做。

Mouse Hook是拦截硬体所产生Mouse硬体的讯息,不管Mouse现在於何处,都会将Mouse的
讯息送往Hook Procedure,当然,一般情况下,是於该程式正处於Active的情况下
(Local Hook),讯息才会送往该Hook Procedure,如果别的程式所产生的Mouse讯息也要
进入该Hook Function时,那便得使用Remote Hook,而Remote Hook的方式,是要把Hook
Procedure放在.Dll之中,而Local Hook只要把 Hook Procedure放在.Bas之中便可以了。

因挂上了Mouse Hook(Local),所以该程式执行时所有的Mouse 的讯息便会送往该Hook
Function,而且有包含Mouse所在的座标(相对於Screen),於是我们可以Check Mouse
的座标,进而得知Mouse是否仍在物件范围。

Please Reference : 如何得知Mouse已离开某物件(二)
'以下在.Bas
Option Explicit

Public Const WM_MOUSEMOVE = &H200
Public Const WH_MOUSE = 7

Type POINTAPI
X As Long
Y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Declare Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
(lpvDest As Any, ByVal lpvSource As Long, ByVal cbCopy As Long)
Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public theForm As Form
Public hHook As Long ' handle of Hook Procedure
Public imgRect As RECT
Sub EnableHook(ctl As Control)
If hHook = 0 Then
imgRect.Top = ctl.Top
imgRect.Left = ctl.Left
imgRect.Right = imgRect.Left + ctl.Width
imgRect.Bottom = imgRect.Top + ctl.Height
hHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, App.hInstance, App.ThreadID)
End If
End Sub
Sub FreeHook()
Dim ret As Long
If hHook <> 0 Then
ret = UnhookWindowsHookEx(hHook)
hHook = 0
End If
End Sub
Function MouseHookProc(ByVal code As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim mStru As MOUSEHOOKSTRUCT, i As Long
If wParam = WM_MOUSEMOVE Then
CopyMemory mStru, lParam, LenB(mStru)
'mStru.pt的座标是萤幕座标,所以要经转换成相对於Form的座标
Call ScreenToClient(Screen.ActiveForm.hwnd, mStru.pt)

'不在imgButton之内
If Not (mStru.pt.Y >= imgRect.Top And mStru.pt.Y <= imgRect.Bottom And _
mStru.pt.X >= imgRect.Left And mStru.pt.X <= imgRect.Right) Then
MouseHookProc = 0
Call CallNextHookEx(hHook, code, wParam, lParam)
Call FreeHook
Debug.Print "Out of The Range "
Exit Function
Else
Debug.Print "In The Range"
End If
End If
MouseHookProc = 0 '表示要处理这个讯息
Call CallNextHookEx(hHook, code, wParam, lParam)
End Function

'以下在Form,需一个Command1
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call EnableHook(Command1)
End Sub

Private Sub Form_Load()
Me.ScaleMode = 3
End Sub

如何得知Mouse已离开某物件(二)

来源:cww 叁考 王国荣先生的作法
上一回使用mouse Hook的方式来Check Mouse是否已离开某物件,详见
如何得知Mouse已离开某物件(Mouse Hook)但使用这个方法太麻
烦了,改用SetCapture 来使Mouse的Message转到某个Window之上,如此,不管Mouse移动
於何处,都会将Mouse Input Message传给某个Window,最後使用ReleaseCapture来取消这
个作用。

Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long

Private Sub Command1_Click()
Command1.Tag = ""
End Sub

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Command1.Tag = "In" Then
If X < 0 Or Y < 0 Or X > Command1.Width Or Y > Command1.Height Then
Command1.Tag = ""
ReleaseCapture
Command1.Caption = "离开"
End If
Else
Command1.Tag = "In"
SetCapture Command1.hwnd
Command1.Caption = "进入"
End If

End Sub   
     

分类: 未分类 标签:

VB 如何得知Mouse已离开某物件

2008年5月7日 岩岩魂   访问量: 566 没有评论

VB中对Mouse的事件提供了MouseDown, MouseUp, MouseMove事件, 利用这三个事件, 我们可以方便地操纵大多数的Mouse行为, 但若要精确地控制Mouse事件, 这三个事件就有点无能为力了. 比如, 我们要在程序中实现以下简单的功能: 当鼠标在某个控件(如按钮)上时, 在状态条上显示该按钮的简单帮助, 离开这个控件时, 则隐藏该帮助. 要实现这个功能, 我们自然地想到要在控件的MouseMove事件上写入以下代码:

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
StatusBar1.Panels(1).Text = "This is Command1"
End Sub

然后在Form_MoveMove中添加以下代码:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
StatusBar1.Panels(1).Text = ""
End Sub

按F5运行程序, 我们可以看到当鼠标移动到Command1上时, 在StatusBar的Panels(1)中显示出了帮助信息, 离开Command1时该帮助信息消失, 但你马上会发现该程序中有一个小小的Bug, 当Command1的位置在窗体的边缘时, 而你将鼠标从Command1上迅速移动到窗体外面, 您将发现StatusBar1的Panels(1)上的帮助信息仍然存在. 这显然没有实现我们预期的要求. 为什么会出现这种情况呢? 这是因为鼠标移动的速度太快, Form1中的Mouse_Move事件来不及触发, 当前鼠标的位置又不在Form1上, 这样, 帮助信息自然不会消失了.

要实现这个功能, 我们认识到光用VB提供的Mouse_Move事件是有缺陷的, 我们应该捕捉Command1的Mouse_Leave事件, 在该事件下输入StatusBar1.Panels(1).Text = "", 这样才能完美地实现预期的要求.

而VB中并没有提供Mouse_Leave事件, 怎样才能捕捉到该事件呢? 这就要求助于API函数了.
在众多的WindowAPI函数中, 有两个函数可以帮助我们实现这个功能: SetCapture和ReleaseCapture .

在窗体中添加以下声明:

Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

在窗体中添加一个命令按钮, 命名为Command2
在Command2的MouseMove事件中, 添加以下代码:

Private Sub Command2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim MouseOver As Boolean
'判断当前鼠标位置是否在Command2上
MouseOver = (0 <= X) And (X <= Command2.Width) And (0 <= Y) And (Y <= Command2.Height)

If MouseOver Then
' MouseOver 事件
' 假如鼠标在Command2上, 则利用SetCapture将每一个鼠标事件都传递给Command2
' 并在StatusBar1.Panels(1)上显示帮助信息
StatusBar1.Panels(1).Text = "This is Command2"
SetCapture Command2.hWnd
Else
' MouseLeave 事件
' 假如鼠标不在Command2上, 则利用SetCapture释放鼠标捕捉
' 并清除在StatusBar1.Panels(1)上的帮助信息
StatusBar1.Panels(1).Text = ""
ReleaseCapture
End If
End Sub

按F5运行程序, 试试看, 不管你的鼠标移动速度有多快, 也不管Command2的位置在那里, 程序都能准确地响应你的Mouse事件. 将以上程序作一些小小的变动, 比如, 当MouseOver时, 修改Command2的Font.Bold属性, 将它设为True, MousLeave时设为False, 或修改ForeColor属性, 在MouseOver和MouseLeave中设成不同的颜色, 将大大增强你的VB程序的界面.  

分类: 未分类 标签:

[转]编程之路-界面美化

2008年5月7日 岩岩魂   访问量: 446 没有评论

现在越来越多的软件都有了很Cool的2D造型,什么×××× XP啦,×××× 2002之类的,看来争夺软件霸权的地位,2D界面是必不可少的,有很多人认为Visual Basic语言的先天不足导致它不能够很灵活的改变界面,让俺们来看看究竟吧。
如果大家用过《Windows优化大师》,肯定会被它的界面所倾倒,其实利用ActiveSkin 就可以办到,甚至更爽,但是如果要做的共享软件只是一个文件,在加上几个OCX累赘,似乎很是不爽,看看VB是怎么利用别的东东来实现的吧。
首先新建一个EXE工程,再在窗体上拖几个Label控件,看看Label 的强大功能吧,原理就是利用Label来模拟一个按钮,但是首先要将Label控件的属性要调一下,
Name:      LblBtn,
BorderStyle: 1,
Appearance: 0,
Alignment:    2,
这样一个按钮的雏形就已经出来了,如果工程量很大,可以将多个Label控件的Name属性设为一样的,对于按钮的识别就要靠识别Index属性了,为了方便起见,在进入到代码编辑窗口,输入以下代码:
Private Const LBL_BACK_COLOR = &HE0E0E0   ’正常时Label控件的背景色
Private Const LBL_WHEN_MOUSE_MOVE = &HC0C0C0 ’鼠标移动时Label的背景色
Private Const LBL_WHEN_MOUSE_DOWN = &H808080 ’鼠标按下时Label的背景色
再在Form的Load事件中输入以下内容
Private Sub Form_Load()
Dim Count As Integer
For Count = 0 To 3 ’请将此出的3换成你的LblBtn数量的个数-1
LblBtn(Count).BackColor=LBL_BACK_COLOR ’初始化LblBtn的背景
Next Count
End Sub
然后再在LblBtn的MouseMove和MouseDown事件中来搞定剩余部分:
Private Sub LblBtn_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) ’当鼠标按在LblBtn上时
LblBtn(Index).BackColor = LBL_WHEN_MOUSE_DOWN ’临时改变LblBtn背景颜色
End Sub
Private Sub LblBtn_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)   ’鼠标在LblBtn上面移动时触发该事件
Dim Count As Integer
DoEvents ’暂时将系统控制权教给系统
If Button Then Exit Sub ’如果按钮被按下就退出该过程
For Count = 0 To 3
If Count <> Index Then ’如果按下的不是其它按钮
LblBtn(Index).BackColor = LBL_BACK_COLOR ’将背景设为正常
Else
LblBtn(Index).BackColor = LBL_WHEN_MOUSE_MOVE ’将背景设为鼠标移动的背景
End If
Next Count
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Count As Integer
DoEvents
For Count=0 To 3
LblBtn(Count).BackColor=LBL_BACKCOLOR ’恢复背景
Next Count
End
本来利用Windows的消息系统来完成这一“艰巨”的任务最简单,可问题就来了,Label控件没有窗口句柄怎么办?可是此问题与题无关,写了会有骗稿费之:)

OK,Label控件就讲到这里,在来说说TextBox控件,
各位看关恐怕看惯了白颜色的背景,那么就换换颜色以养养俺们那和绵羊一样的眼睛(为什么说绵羊?俺也不知道),可是VB提供的RGB函数弄出来的颜色不是怎么好看,这里俺来教大家一个小Tip,RGB函数的Red,Green,Blue这三个参数若一样,则产生的颜色是灰度,当然越接近白颜色越好,但也不能让各位看不出来,俺建议TextBox的背景为RGB(235,235,235),各位还是实战一下,将一个TextBox拖到窗体上,属性设置如下
Appearance      0
BorderStyle 1
MutilLine          True
千万不要设置ScrollBars属性,否则会影响效果
在Form的Load事件中初始化TextBox
Dim bkColor As Long
Private Sub Form_Load()
bkColor=RGB(235,235,235)
Text1.BackColor=bkColor
End Sub
在Form和Text1的MouseMove事件中:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Text1.BorderStyle = 0
End Sub
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
DoEvents
Text1.BorderStyle = 1
End Sub
在按下F5试试是不是很Cool?
可能各位看关玩过石器时代,一定会对里面的TextBox的效果感到很爽,VB还不是可以做到,有焦点的控件可以使用SetFocus方法来为其设置焦点,可是一个窗体上如果控件太多了,一个一个的用SetFocus是不是太傻了?这一节的主角就是--------API函数,
首先声明:
Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" Alias "WindowFromPoint" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function SetFocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
但是这里的SetFocus会和控件的SetFocus会搞混淆,改改吧,
Private Declare Function nSetFocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
只要Alias指向的接口是对的前面的函数名称简直就是摆设,
在建立一个过程:
Public Function sSetFocus() As Long
Dim CPos As POINTAPI,Successfull As Boolean,hWnd As Long
DoEvents
Successfull =GetCursorPos(CPos)
If Not Successfull Then Exit Sub ’如果未成功则退出该过程
hWnd=WindowFromPoint(CPos.x,CPos.y)
sSetFocus=nSetFocus(hWnd)
End Sub
在窗体上放一个Timer控件,Interval 属性设为100,就是0.1秒,在Timer1控件的Timer事件中填入sSetFocus,在运行一下看看,效果怎么样?
可是有的先生小姐要问了,TextBox难道就不能用ScrollBar吗?非也非也,选 工程->部件->Microsoft Windows Common Controls-2 6.0 (SP3)就是你的答案,至于卷动TextBox就去研究SendMessage函数吧,否则又有骗稿费之嫌,如果想作绿色软件,不想用控件,可以用俺前面讲到的Label控件,利用字体 Webdings 来模拟ScrollBar,需要注意的是,如果模拟ScrollBar,上下左右箭头分别是5,6,3,4,别忘了把字体设为Webdings

再来讲讲窗体的美化,其实将BorderStyle属性设为0就是很好的2D美化;)可是,这样一来,问题又来了,怎么办?凡事都要请API来帮忙,这里需要两个API,一下是该API的声明:
Public Declare Function ReleaseCapture Lib "user32" Alias "ReleaseCapture" () As Long '这个API是用来解下鼠标的追踪器,关于他的过多用法以及详细介绍可以写信向俺咨询,
还有
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long’这个该不要俺多介绍了吧
Public Const HTCAPTION = 2 ’代表窗体的标题区
Public Const WM_NCLBUTTONDOWN = &HA1 ’表示非工作区左键按下
原理很简单,卸下鼠标追踪器后向Form发送一个移动窗体的消息,其实做到这一点的方法很多,但俺个人认为这一种最简单,添加一个过程:
Public Sub MoveForm(hWnd As Long)
DoEvents
ReleaseCapture
SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub
在Form的MouseMove事件中:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button=vbLeftButton Then MoveForm hWnd’如果按下鼠标左键就移动窗体
End Sub
台下的这位小姐又纳闷了,可是光秃秃的窗体没有了标题栏也不好看,俺要向这为小姐推荐俺的东东-ActiveX控件,ToolSign,需要的人可以写信给俺联系,
该控件需要在代码编辑区域内添加一下代码:
’一下声明是用在ToolSign的 AutoQuit属性的
Public Const EXIT_FORCE = 2   ’注意,在VB中运行的时候如果选用此退出方式,VB也会退出
Public Const EXIT_MESSAGE = 1 ’由操作系统发送关闭消息
Public Const EXIT_CUSTOM = Not (EXIT_FORCE Or EXIT_MESSAGE) ’自定义
将其注册后在部件栏中把e-Dogkid Studio Tools Sign打钩,添加到工具箱中,双击加入到窗体中,
在Form的Load事件中添加一下初始化代码:
Private Sub Form_Load()
With Sign1
.AutoQuit = EXIT_CUSTOM
.ParentsHWND = hWnd   ’填了此属性可以直接用ToolSign来移动窗体而不需要前面的代码
End With
End Sub
Sign1的Click事件
Private Sub Sign1_Click()
End ’关闭程序
End Sub
在Form的Resize事件中添加一下代码:
Private Sub Form_Resize()
Sign1.Width = Width
End Sub
如果想让窗体可以改变大小,可以修改一下属性
Caption   ""
BorderStyle 2或5
ControlBox False
实际情况如图

不知道各位看关见过爆炸试的窗体没有?,没有见过可以从俺要另外一个俺自己的ActiveX DLL,我的那个东东其实是给我的Software作运行库的,各位若不嫌弃,可以用用,注册后在工程->引用->e-Dogkid Runtime Library
然后在窗体Load事件中输入:
Private Sub Form_Load()
Dim System As e_Dogkid_Runtime_Library.System
Set System = New e_Dogkid_Runtime_Library.System
Show
System.BoomIt hDC, 60, Width, Height, Left, Top
Set System = Nothing
End Sub
其实俺的那个DLL文件有几百个俺自己收集和自己编写的函数,很棒的.
另外俺的QQ号码:16184794,俺的email是e-dogkid@21cn.com

分类: 未分类 标签:

在Vb下实现多线程

2008年5月7日 岩岩魂   访问量: 498 没有评论

新建一Module
Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Sub main()
   Load Form1
   Form1.Show
End Sub
Public Sub c1()
    .......
End Sub

Public Sub c2()
   ......
End Sub

新建一窗体

Private hthread1 As Long
Private hthread2 As Long
Private ithread1 As Long
Private ithread2 As Long

Private Sub Command1_Click()

ithread1 = CreateThread(ByVal 0&, ByVal 0&, AddressOf c1, ByVal 0&, ByVal 0&, hthread1) --创建线程一
ithread2 = CreateThread(ByVal 0&, ByVal 0&, AddressOf c1, ByVal 0&, ByVal 0&, hthread1) --创建线程二

CloseHandle ithread1   --关闭线程一
CloseHandle ithread2   --关闭线程二

End Sub

Private Sub Form_Load()

End Sub

分类: 未分类 标签:

VB ZOrder的使用

2008年5月7日 岩岩魂   访问量: 714 没有评论

ZOrder的使用

ZOrder 拆开以后就是 Z 及 Order,其意义说明如下:
Z:这里是指三度空间中的 Z 座标轴 (注一),而不是指英文字母的第 26 个字母。
Order:排列顺序。
所以 ZOrder 就是指在 Z 座标轴上的排列顺序!

ZOrder 语法如下:

object.ZOrder position

---------------------------------------------------------------------------

object 选择性引数。物件运算式,用来指定「适用于」清单中的物件。
如果省略 object,则假设具有驻点的 Form 物件为 object。
Position 选择性引数。整数,用以指示 object 相对于同一 object 其它执行个体的位置。
如果 position 为 0 或省略,则 object 放置在 z- 顺序前面 (上方)。
如果 position 为 1,则 object 放置在 z- 顺序后面 (下方)。

---------------------------------------------------------------------------

在设计阶段选取快显功能表中的「移至顶层」或「移至底层」功能表指令,可以设定物件的 z- 顺序。

ZOrder 用在不同的地方,有二种不同的意义:
1、用于 MDIForm 中的 Child Form 时,指的是每一个 Child Form 的上下位置关系。
2、用于每一个 Form 中的所有控制项时,指的是每一个控制项间的上下位置关系。 (注二)

注一:一般我们的二度平面座标轴是指 X 座标轴 (东西向)及 Y 座标轴 (南北向),
   二个轴构成一个平面,再加上垂直的 Z 座标轴,就构成了三度立体空间了!
   所以 ZOrder 指的就是物件在垂直的 Z 座标轴上的上下位置关系。

注二:虽然 ZOrder 指的是物件在垂直的 Z 座标轴上的上下位置关系。
   但是很多人搞不清楚,为什么他已经设定了 ZOrder 了,为什么在某些控制项中是无效的?

   原因是对单一 Form 或 单一 Container 而言,在垂直的 Z 座标轴上又分成三个层次:
   最下一层:显示图形方法结果的绘图空间。
   中间一层:用来显示图形物件(例如 Image) 和 Label 控制项。
   上面一层:显示所有非图形控制项,例如 CommandButton、CheckBox 或 ListBox。
   而 ZOrder 只对单一层次内的控制项有效而已!

   例如:您如果设定 Label 及 Image 的 ZOrder 是有效的,因为它们都在中间一层!
      您如果设定 Label 及 CommandButton 的 ZOrder 是无效的,因为它们在不同层!

   最重要的是:不管 ZOrder 如何设定,
         在上面一层的物件永远会在中间一层的物件的上方!
         在中间一层的物件永远会在最下一层的物件的上方!

分类: 未分类 标签:

自制控件方面的有关知识

2008年5月7日 岩岩魂   访问量: 549 没有评论
1.
在程序中注册和注销 OCX 控件 98-7-20
声明(在本例子里使用的是 ComCtl32.OCX,如果是其他,使用相应的名称):
Declare Function RegComCtl32 Lib "ComCtl32.OCX" _
Alias "DllRegisterServer" () As Long
Declare Function UnRegComCtl32 Lib "ComCtl32.OCX" _
Alias "DllUnregisterServer" () As Long
Const ERROR_SUCCESS = &H0

使用:

If RegComCtl32 = ERROR_SUCCESS Then
MsgBox "Registration Successful"
Else
MsgBox "Registration Unsuccessful"
End If

If UnRegComCtl32 = ERROR_SUCCESS Then
MsgBox "UnRegistration Successful"
Else
MsgBox "UnRegistration Unsuccessful"
End If

2.
建立可下拉选择的属性
例如在 BorderStyle 中有以下的四个选择:
0 - None
1 - Dashed
2 - Single Line
3 - Double Line
4 - 3D
首先在控件中定义以下的集合:
Enum BorderType
None
Dashed
[Single Line]
[Double Line]
[3D]
End Enum
然后就可以把属性的类型设置好:
Public Property Get BorderStyle() As BorderType
Border = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As BorderType)
m_BorderStyle = New_BorderStyle
PropertyChanged "BorderStyle"
End Property

3.
缺省值和可选参数
VB5 加强了函数参数方面,可用以下的代码实现参数缺省:

Property Get Value(Optional index As Long = 1)
...
End Property
也可使用另一个方法(慢):

Property Get Value(Optional index As Long)
If IsMissing(index) Then index = 1
...
End Property

4.
多个参数的属性
在自制的控件中,可能需要对某个属性传递多个值:

Property Let Test (arg1 As String, arg2 As String, arg3 As Integer)
End Property

'用以下的方法传递参数:
Test(arg1,arg2) = arg3

5.
使用数组做属性
定义一个 variant 类型的属性,即可用它来做数组。
下面定义了一个 CArray 类。

Private m_MyArray As Variant

Public Property Get MyArray() As Variant
MyArray = m_MyArray
End Property

Public Property Let MyArray(a As Variant)
m_MyArray = a
End Property

可用以下的方法使用:

Private m_Array As CArray
Private mArr(3) As String

Private Sub Form_Load()
Set m_Array = New CArray
mArr(1) = "One"
mArr(2) = "Two"
mArr(3) = "Three"
m_Array.MyArray = mArr()
'或者
'm_Array.MyArray = Array("One", "Two", "Three")
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim i As Integer
For i = 1 To UBound(m_Array.MyArray)
MsgBox m_Array.MyArray(i)
Next
End Sub

分类: 未分类 标签:

ActiveX控件的创建

2008年5月7日 岩岩魂   访问量: 365 没有评论
1)概述

   ActiveX是一个Microsoft的术语,它指的是一组包括控件,DLL和ActiveX文档的组件,它通常是以动态链接库的形式存在,因此必须在一个叫容器的独立执行软件中运行。这样的容器包括Authorware、Delphi,Visual Basic,Visual C++,Internet Explorer和Access等等。

   ActiveX控件数据输入和函数功能执行都必须通过容器,因此ActiveX控件和容器都必须支持一些特定的接口协议。根据Microsoft 相应的规格标准,ActiveX控件应具备如下的性能机制。

属性和方法:ActiveX控件必须提供属性的名称、方法的名称及参数,通过这项机制容器可以存取和改变ActiveX控件的属性参数。

事件:ActiveX控件由这项机制通知容器在ActiveX控件中发生的事件,比如属性参数的改变,用户按下鼠标左键等。

存储:容器由这项机制通知ActiveX控件存储和提取有关信息数据等。

   ActiveX控件只要在Windows的Registry数据库中注册后,就可以像其他Windows应用程序一样发挥各自的功能。

   ActiveX控件是一个模块化的灵活对象,如果某个应用程序或网页需要增加一项特殊的功能,无须重写整个程序,只要灵活地插入一个具有此项功能的ActiveX控件即可实现。ActiveX的优势还在于它的动态可交互性,用户可以动态地在使用过程中,通过改变它的属性和参数,在应用程序中实现自己的特殊要求。

   也许有的读者会问:目前在市面上可以找到各种各样现成的ActiveX控件,还有没有必要自己创建ActiveX控件呢?关于这个问题很容易解释,现有的控件种类是很多,功能也比较齐全,问题是有许多时候会遇到这种情况:使用现成的控件虽能完成任务,但自己需要的一些特性(属性、事件或方法)该控件却没有提供,还需要自己手工写代码来实现,而这些特
性偏偏在自己的应用系统中又经常会用到,为了避免大量的重复劳动,一劳永逸的办法就是在创建自己的ActiveX控件。

   目前可以使用Visual Basic或其它开发工具创建 ActiveX控件。无论按照哪种标准,Visual Basic都是计算机历史上最为成功的(同时也是最流行的)编程语言,其中最令人兴奋的特性就是可以创建用户自己的控件并可以像其他控件一样应用于支持 ActiveX控件技术的应用程序中。下面通过一个具体实例来阐述如何在Visual Basic 6.0(中文企业版)下进行
ActiveX控件创建。

  2)创建ActiveX控件的步骤

   使用Visual Basic编程语言编写过应用程序的用户,一定非常熟悉诸如TextBox、Label和Data等控件。要利用这些控件,可以将它们绘制在窗体中,通过属性,方法和事件控制它们的行为。当用户创建自己的ActiveX控件时,除了确定属性、方法和事件以外,用户是在创建一个相似的对象。当创建了自己的ActiveX控件以后,就可以在其他Visual Basic 工程中使
用它,就像使用TextBox控件一样。可以在能使用ActiveX控件的任何应用程序或开发工具(包括其他Visual Basic工程、Authorware或者Microsoft Internet Explorer)中使用自己的控件。

   在Visual Basic中创建一个ActiveX控件不同于创建一个Standard EXE
应用程序。因此当创建一个新控件时,一般应遵循的步骤是:

(1)确定控件将要提供的功能。因为ActiveX控件类似于一个独立的对象,所以需要明确这个对象的目的,希望它在屏幕上有什么样的外观?使用此控件时,需要什么属性、方法以及事件用于应用程序中?
(2)设计控件的外观。
(3)设计控件的接口,即属性、事件和方法。
(4)创建由控件工程和测试工程组成的工程组。
(5)通过把控件和或代码添加到 UserControl 对象中来实现控件的外观。
(6)实现控件的接口和功能。
(7)编译控件部件(.ocx 文件)。

下面按照上述步骤建立一个可直接显示数据库内容的DataListView控件。

3)具体实现方法

(1)确定DataListView控件的功能

   标准的ListView控件在显示数据库记录时还存在一些不足,如必须编写大量的代码等,DataListView通过在ListView的基础上添加部分功能而弥补了ListView的不足,因此它除了本身固有的属性、方法和事件外,添加了如下成员:

◆ DataServerName属性 -- 确定所操作的数据服务器。
◆ DataBaseName属性 -- 确定所操作的数据库。
◆ AdministratorName属性 -- 确定操作数据库的管理员名称。
◆ PasswordName属性 -- 确定操作数据库的管理员口令。
◆ ShowDataBase方法 -- 显示Select命令所执行的数据库操作结果。
◆ErrorDataBase事件 -- 当遇到错误的数据库操作时引发该事件。

(2)设计控件的外观

   DataListView由于仅包含一个ListView控件,所以其外观没有太多需要考虑的问题。如果要创建的控件是多个控件构成,或新控件不包括任何现存控件即完全从头开始创建一个全新的控件的话,则外观问题是一个很重要的问题。

(3)设计控件的接口,即属性、事件和方法

   对ListView控件所作的改进是为了让ListView控件支持数据库的内容显示,以便在所有能支持ActiveX控件的应用程序中使用。通过添加用户自己的属性DataServername、DataBaseName、AdministratorName、PasseordName和方法ShowDataBase等可以实现这项功能。DataListView的其他属性、事件和方法都和标准ListView一样。

(4)创建由控件工程和测试工程组成的工程组

◆启动一个新的ActiveX控件工程。
◆按下CTRL+T 组合键或者选择【工程】|【部件】菜单选项,显示【部件】对话框,在【控件】选择框中选择Microsoft Windows Common Controls 6.0。
◆ 选择【工程】|【引用】菜单选项,显示【引用】对话框,在【可用的引用】选择框中选择Microsoft ActiveX Data Objects 2.0 Library。
◆在UserControl窗口中添加一ListView控件,ListView控件的左上角位置为0,0。
◆设置ActiveX工程和UserControl控件属性值,如下表所示。

   条目             设置
  工程类型           ActiveX控件
  工程名称           DataLV
  工程描述           通过ADO,使得ListView控件能够直
                 接操作数据
  UserControl 的Name属性    DataListView
  UserControl 的Public属性   True

◆保存这个工程。
◆选择【文件】|【添加工程】菜单选项。然后添加一个标准EXE工程。建  立该工程的目的是为了在创建ActiveX控件时不断地进行测试。

   此时已建立了一个由控件工程和测试工程组成的工程组,下面就可以正式开始创建DataListView控件。

(5)实现控件的外观

   确定控件外观的方式取决于当前控件的创建模型。如果要创建一个用户绘制控件,那么必须自己在UserControl_Paint 事件过程编写代码来完成所有的绘制工作,同时还需要确定何时绘制控件,以便在需要的时候调用UserControl的Refresh方法来产生Paint 事件。如果是改进一个现有控件,那么只需正确地将组成控件放置在UserControl上即可。

   由于DataListView控件仅包含ListView一个组成控件,那么只需简单地在UserControl1上绘出一个标准ListView控件,控件名为缺省的ListView1,即可完成外观绘制工作。

   为了在使用控件时,使ListView控件和自己绘制的空间相匹配,必须建立UserControl的Resize事件过程。Resize事件过程的代码如下:

Private Sub UserControl_Resize()
   ListView1.Left = 0
   ListView1.Top = 0
   ListView1.Width = UserControl.Width
   ListView1.Height = UserControl.Height
End Sub

   仅四行代码的Resize事件过程是简单控件的用户界面的所有必须的代码,其目的是使ListView控件和UserControl对象有相同的尺寸。

(6)实现控件的接口和功能

   这是整个创建过程中最核心、最重要也是最复杂的步骤。对于创建控件的每一属性、事件和方法均需逐一实现。

◆创建DataServerName属性

   要创建DataServerName属性值,首先需要添加一个在内部存贮属性值的局部变量。要做到这一点,在UserControl对象的Genaral Declarations通用声明语句中创建此变量。如下所示:

Dim m_DataServerName As String

   接着需要创建称为DataServerName的新属性,可以通过手工输入Get和Let过程,或者选择【工具】|【添加过程】|【类型】创建这个新属性。DataServerName属性的代码相当容易理解。当置DataServerName属性的值时,Property Get过程仅将局部变量的存贮内容取出来。当设置DataServerName属性值时,Property Let过程将为局部变量赋予一个有效值。以下是两个Property过程的代码:

Public Property Get DataServername() As String
   DataServername = m_DataServerName
End Property

Public Property Let DataServername(ByVal New_DataServerName As String)
   m_DataServerName = New_DataServerName
   PropertyChanged "DataServerName"
End Property

   需要注意的是在Property Let过程中,有一个PropertyChanged方法,它的功能是通知容器(可以理解为存放所有属性的单元)属性值已变更,需产生一个WriteProperties 事件,来保存新属性值。事实上不仅在Property Let过程需要调用PropertyChanged方法,在UserControl的代码模块中无论何时改变了ActiveX控件的某个属性值,均需调用该过程,以保存属性的变化。

   注意Property DataServerName方法的用法,此方法与ReadProperties
和WriteProperties事件在一起使用。

   此时需要使用用户控件的InitProperties事件指定此属性的初始值:

Private Sub UserControl_InitProperties()
   m_DataServerName = m_def_DataServerName
End Sub

   即使用户没有设置初始值,这些代码也会确保设置了一个初始值。

   至于DataBaseName、AdministratorName、PasseordName 属性的创建过程跟DataServername属性的创建过程完全一样,这里就不再重复叙述。

◆使用PropertyBag对象

   用户还需要为WriteProperties和ReadProperties事件创建代码,从而保护DataServername、DataBaseName、AdministratorName、PasseordName属性在设计阶段的属性值。这两个事件都使用PropertyBag 对象保存和检索DataServername、DataBaseName、AdministratorName、PasseordName属性的值。PropertyBag对象能够保持DataServername、DataBaseName、
AdministratorName、PasseordName的设计值。具体实现代码如下:

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   m_DataServerName = PropBag.ReadProperty("DataServerName",
            m_def_DataServerName)
   m_DataBaseName = PropBag.ReadProperty("DataBaseName",
            m_def_DataBaseName)
   m_AdministratorName = PropBag.ReadProperty("AdministratorName", m_def_AdministratorName)
   m_PasswordName = PropBag.ReadProperty("PasswordName",
            m_def_PasswordName)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   Call PropBag.WriteProperty("DataServerName", m_DataServerName,
             m_def_DataServerName)
   Call PropBag.WriteProperty("DataBaseName", m_DataBaseName,
             m_def_DataBaseName)
   Call PropBag.WriteProperty("AdministratorName",
          m_AdministratorName, m_def_AdministratorName)
   Call PropBag.WriteProperty("PasswordName", m_PasswordName,
          m_def_PasswordName)
End Sub

   由于这两个过程是针对"容器"对象的,因此所有属性值的保存和读取都通过这两个过程来实现,而不是每个属性都需要单独的两个过程。其中,PropertyBag就是"容器对象"的名称。

   WriteProperty方法有三个参数:第一个字符串标识需要保存的属性,第二个参数是需要保存的值,最后的参数是属性的缺省值。

   ReadProperty 方法需要两个参数:一个字符串用来保存属性的名称,另一个为缺省值。

   在窗体上绘制ActiveX控件的那一刻,就会开始执行ActiveX控件的代码。在控件设计过程中,将DataServername、DataBaseName、AdministratorName、PasseordName属性的默认值设置为:

Const m_def_DataServerName = "lyc"
Const m_def_DataBaseName = "pubs"
Const m_def_AdministratorName = "sa"
Const m_def_PasswordName = ""

   当然,也可以在程序运行时多次修改它。控件的正常行为是当程序终止时恢复其默认值,这样增加了保持属性的两种独立状态的要求。

   简言之,如果在设计阶段改变了一个属性值,那么控件必须得到这个新值,而不是使用默认值。相反,如果在程序运行时改变属性值,那么当返回设计状态时,控件必须检索此属性值。

   PropertyBag对象允许ActiveX控件存贮有关它自己的属性值,使它能执行这个动作。PropertyChanged 方法会通知用户已经改变了一个属性。通过了解程序的状态以及是否调用了PropertyChanged方法,VB 就可以激发WriteProperties和ReadProperties事件。

◆为ShowDataBase方法编写代码

  ShowDataBase方法实现在ListView控件中显示Select命令所执行的数据库操作结果。在其具体实现过程中采用了 ADO(ActiveX Data Objects)的数据存取方法。ADO的主要特点是使用更加容易,访问速度更快,而对磁盘和存储容量的要求更小,ADO支持建立各种客户/服务器模式与基于Web的应用程序,具有远程数据服务RDS(Remote Data Service)的特性,通过RDS能够在一次往返中将服务器端的数据传送到客户端的应用程序或Web页面中,并在客户端对数据进行处理后,立即更新服务器端的数据。采用ADO所基于的OLE DB技术,可以对电子邮件、文本文件、数据表格等各类数据通过统一的接口API接口进行存取,是远程数据存取的一个主要发展方向。ShowDataBase方法具有一个字符串参数,但无任何返回值,具体代码如下所示:
Public Sub showdatabase(ssql As String)
Dim AdoDatabase As New ADODB.Connection
Dim AdoTable As New ADODB.Recordset
Dim scnn As String
Dim response As String
Dim I As Integer
On Error GoTo errorhandle
scnn = "Provider=SQLOLEDB;Data Source="
& Trim(m_DataServerName) & ";
Initial Catalog=" & Trim(m_DataBaseName) & ";
User Id=" & Trim(m_AdministratorName) & ";
Password=" & Trim(m_PasswordName) & ";"
AdoDatabase.Open scnn
AdoTable.CursorType = adOpenKeyset
AdoTable.LockType = adLockOptimistic
AdoTable.CursorLocation = adUseClient
AdoTable.Open ssql, AdoDatabase, , , adCmdText
If AdoTable.BOF And AdoTable.EOF Then
response = MsgBox("没有符合条件的记录!!",
vbOKOnly + vbInformation, "数据库控件")
AdoTable.Close
Set Adotable=Nothing
AdoDatabase.Close
Set AdoDataBase=Nothing
Exit Sub
End If
ListView1.ColumnHeaders.Clear
ListView1.ListItems.Clear
Dim clmX As ColumnHeader
For I = 0 To AdoTable.Fields.Count - 1
Set clmX = ListView1.ColumnHeaders.Add()
With clmX
.Text = AdoTable.Fields(I).Name
End With
Next
Dim itmX As ListItem
AdoTable.MoveFirst
Do While Not AdoTable.EOF
Set itmX = ListView1.ListItems.Add()
With itmX
If IsNull(AdoTable.Fields(0).Value) Then
.Text = "NULL"
Else
.Text = AdoTable.Fields(0).Value
End If
End With
For I = 1 To AdoTable.Fields.Count - 1
If IsNull(AdoTable.Fields(I).Value) Then
itmX.SubItems(I) = "NULL"
Else
itmX.SubItems(I)
= AdoTable.Fields(I).Value
End If
Next
AdoTable.MoveNext
Loop
ListView1.View = lvwReport
AdoTable.Close
Set Adotable=Nothing
AdoDatabase.Close
Set AdoDataBase=Nothing
Exit Sub
errorhandle:
RaiseEvent Errordatabase
End Sub

当对数据库的操作发生错误后,除了不能正常显示以外,还应通知宿主程序用户。可以通过创建一个叫做Errordatabase的事件实现上述功能。要创建这个事件,把下述代码添加到UserControl对象的GeneralDeclarations段中。

Public Event Errordatabase()

   此事件的工作像其他控件的事件一样。使用控件的用户可以将代码放到这个事件中,用户要做的唯一的事情就是用RaiseEvent方法激发此事件。

(7)编译控件部件(.ocx 文件)。

   现在已经完成了DataListView控件的创建工作,为了在DataLV工程外也可以使用该控件,只需将DataLV工程编译.ocx控件部件即可。

   在【工程组】窗口单击【DataLV】以选择该工程,在【文件】菜单上单击【生成DataLV.ocx】,在【生成工程】对话框中选择控件存放的目录后, 单击【确定】即可创建.ocx 文件。

   一旦生成了.ocx文件的控件,就可以象使用其它控件一样来随心所欲地使用它了。

  4)结束语

   ActiveX技术可以灵活、高效的实现可交互、重入、重用、完全分布式、与语言无关的各种应用。随着ActiveX技术的发展,ActiveX控件在应用程序中的作用将会显得越来越重要,那么创建一个功能完善、具有自己特色的ActiveX控件就非常具有现实意义。只要掌握了创建ActiveX控件的基本方法,就不难创建自定制的可在各种应用领域使用的ActiveX控件。

   但是,ActiveX技术也有一些明显缺点,ActiveX技术依赖于Windows平台,对广泛应用的UNIX平台目前仍不兼容,另外 ActiveX在许多方面的性能还较弱,ActiveX技术仍需要不断完善和发展。

分类: 未分类 标签: