VB实例解二.doc

内容： 做个登陆程序，以VB+Access。功能：1、验证。验证用户名的正确与否、密码与用户名符合与否2、人性化设计。、输入用户名后，无论是鼠标移动到密码框，还是按“Tab”键到密码框，都搜索用户名的存在与否，但不报错、输入密码后，选者状态在“确定”按钮上。、确定后检验，用户名为空时，光标停在用户名框，密码空停密码输入框。控件：TextBox、CommandButton、PictureBox、Timer、ADO程序内容：控件 2 TextBox 2 CommandButton 1 PictureBox 1 Timer：程序 form1程序Private Sub Command1_Click() Unload MeEnd SubPrivate Sub Command2_Click() Dim ConStr As String If text_user.Text = ThenMsgBox 请输入用户名!, vbOKOnly + vbExclamation, 登陆错误text_user.SetFocusExit Sub End If Set cn = New ADODB.Connection Set rs = New ADODB.Recordset ConStr = Provider=Microsoft.Jet.OLEDB.4.0; & Data Source= & App.Path & ttj02.Mdb cn.Open ConStr cn.CursorLocation = adUseServer rs.Open Select * from dbuser, cn, adOpenKeyset, adLockPessimistic If rs.RecordCount 0 ThenIf text_user.Text Then Set rs1 = New ADODB.Recordset Dim TextUserName TextUserName = Left(text_user.Text, 4) rs1.Open Select * From dbuser Where User_nb= & TextUserName & , cn, adOpenKeyset, adLockPessimistic If rs1.RecordCount 0 Thentext_user.Text = Left(text_user.Text, 4) & rs1.Fields(user_zhuwu)Text_password.SetFocusIf Text_password Then If rs1.Fields(User_Nb) = TextUserName And rs1.Fields(User_password) = Text_password.Text ThenForm3.ShowUnload Me ElseMsgBox 密码错误!, vbExclamation + vbOKCancel, 登陆错误text_user.Text = Text_password = text_user.SetFocus End IfElse MsgBox 请输入密码!, vbExclamation + vbOKCancel, 登陆错误End If ElseMsgBox 沒有用戶信息,請確定!, vbExclamation + vbOKCancel, 登陆错误text_user.Text = Text_password = text_user.SetFocusExit Sub End If rs.CloseEnd If End IfEnd SubPrivate Sub Text_password_LostFocus() If text_user.Text = Thentext_user.SetFocus ElseIf Text_password.Text Then Command2.SetFocusEnd If End IfEnd SubPrivate Sub Text_password_Validate(Cancel As Boolean) If text_user.Text = Thentext_user.SetFocus ElseIf Text_password.Text = Then Text_password.SetFocusElse Command2.SetFocusEnd If End IfEnd SubPrivate Sub text_user_LostFocus() If text_user.Text ThenDim ConStr As StringSet cn = New ADODB.ConnectionSet rs2 = New ADODB.RecordsetConStr = Provider=Microsoft.Jet.OLEDB.4.0; & Data Source= & App.Path & ttj02.Mdbcn.Open ConStrcn.CursorLocation = adUseServerrs2.Open Select * From dbuser Where User_nb= & TextUserName & , cn, adOpenKeyset, adLockPessimisticIf rs2.RecordCount 0 Then text_user.Text = text_user & rs2.Fields(user_zhuwu) Text_password.SetFocus rs2.CloseElse text_user.Text = text_user.Text Text_password.SetFocus Exit SubEnd If Elsetext_user.SetFocus End IfEnd SubPrivate Sub text_user_Validate(Cancel As Boolean)Dim ConStr As StringSet cn = New ADODB.Connection ConStr = Provider=Microsoft.Jet.OLEDB.4.0; & Data Source= & App.Path & ttj02.Mdb cn.Open ConStr cn.CursorLocation = adUseServer Dim TextUserName TextUserName = Left(text_user.Text, 4) If text_user.Text ThenSet rs3 = New ADODB.Recordsetrs3.Open Select * From dbuser Where User_nb= & TextUserName & , cn, adOpenKeyset, adLockPessimisticIf rs3.RecordCount 0 Then text_user.Text = Left(text_user.Text, 4) & rs3.Fields(user_zhuwu) Text_password.SetFocus rs3.CloseElse text_user.Text = Left(text_user.Text, 4) Text_password.SetFocus Exit SubEnd If End If End Subform2程序Private Sub Form_Load()Me.ShowMe.Timer1.Interval = 3000Me.Timer1.Enabled = TrueEnd SubPrivate Sub Timer1_Timer() Form1.Show Unload MeEnd Sub面的这段代码将Picture1的图形作为菜单项。首先建立一个模块，并加入下面的语句。Declare Function GetMenu Lib user32 _(ByVal hwnd As Long) As LongDeclare Function GetSubMenu Lib user32 _(ByVal hMenu As Long, ByVal nPos As Long) As LongDeclare Function GetMenuItemID Lib user32 _(ByVal hMenu As Long, ByVal nPos As Long) As LongDeclare Function SetMenuItemBitmaps Lib user32 _(ByVal hMenu As Long, ByVal nPosition As Long, _ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, _ByVal hBitmapChecked As Long) As LongPublic Const MF_BITMAP = &H4&Type MENUITEMINFOcbSize As LongfMask As LongfType As LongfState As LongwID As LonghSubMenu As LonghbmpChecked As LonghbmpUnchecked As LongdwItemData As LongdwTypeData As Stringcch As LongEnd TypeDeclare Function GetMenuItemCount Lib user32 _(ByVal hMenu As Long) As LongDeclare Function GetMenuItemInfo Lib user32 _Alias GetMenuItemInfoA (ByVal hMenu As Long, _ByVal un As Long, ByVal b As Boolean, _lpMenuItemInfo As MENUITEMINFO) As BooleanPublic Const MIIM_ID = &H2Public Const MIIM_TYPE = &H10Public Const MFT_STRING = &H0&form1中 Private Sub Form1_load() 获得你的菜单的句柄hMenu& = GetMenu(Form1.hwnd) 获得第一个子菜单的句柄hSubMenu& = GetSubMenu(hMenu&, 0) 获得第一个菜单项hID& = GetMenuItemID(hSubMenu&, 0)加入位图SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, _Picture1.Picture, _Picture1.PictureEnd Sub上面的代码使菜单项为图片，如果你只希望菜单项的左边有一个小位图，而右边仍为文字。可以先在Picture1绘制图片，在利用Picture1.Print加上文字，然后用Picture1.Picture加入菜单项。Option Explicit【VB声明】Private Declare Function GetMenu Lib user32 (ByVal hwnd As Long) As Long【说明】取得窗口中一个菜单的句柄【返回值】Long，依附于指定窗口的一个菜单的句柄（如果有菜单）；否则返回零【参数表】hwnd -Long，窗口句柄。对于vb，这应该是一个窗体句柄。注意可能不是子窗口的句柄Private Declare Function GetMenu Lib user32 _ (ByVal hwnd As Long) As Long-【VB声明】Private Declare Function GetSubMenu Lib user32 (ByVal hMenu As Long, ByVal nPos As Long) As Long【说明】取得一个弹出式菜单的句柄，它位于菜单中指定的位置【返回值】Long，位于指定位置的弹出式菜单的句柄（如果有的话）；否则返回零【参数表】hMenu -Long，菜单的句柄nPos -Long，条目在菜单中的位置。第一个条目的编号为0Private Declare Function GetSubMenu Lib user32 _ (ByVal hMenu As Long, ByVal nPos As Long) As Long-【VB声明】Private Declare Function SetMenuItemBitmaps Lib user32 (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long【说明】设置一幅特定位图，令其在指定的菜单条目中使用，代替标准的复选符号（）。位图的大小必须与菜单复选符号的正确大小相符，这个正确大小可以由GetMenuCheckMarkDimensions函数获得【返回值】Long，非零表示成功，零表示失败。会设置GetLastError【备注】使用的位图可能由多个条目共享。一旦不再需要，位图必须由应用程序清除，因为windows不能自动对它进行清除【参数表】hMenu -Long，菜单句柄nPosition -Long，欲设置位图的一个菜单条目的标识符。如在wFlags参数中指定了MF_BYCOMMAND，这个参数就代表欲改变的菜单条目的命令ID。如设置的是MF_BYPOSITION，这个参数就代表菜单条目在菜单中的位置（第一个条目的位置为零）wFlags -Long，常数MF_BYCOMMAND或MF_BYPOSITION，取决于nPosition参数hBitmapUnchecked -Long，撤消复选时为菜单条目显示的一幅位图的句柄。如果为零，表示不在未复选状态下显示任何标志hBitmapChecked -Long，复选时为菜单条目显示的一幅位图的句柄。可设为零，表示复选时不显示任何标志。如两个位图句柄的值都是零，则为这个条目恢复使用默认复选位图Private Declare Function SetMenuItemBitmaps Lib user32 _ (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long-Const MF_BYPOSITION = &H400&Private Sub Form_Load()Dim mHandle As Long, lRet As Long, sHandle As Long, sHandle2 As Long取得菜单的句柄并赋值给mHandlemHandle = GetMenu(hwnd)取得mHandle句柄所指菜单的第一个弹出式菜单（文件&F）的句柄并赋值给sHandlesHandle = GetSubMenu(mHandle, 0)将弹出式菜单的第0-4项加上图片，为什么跳过2呢？因为2是分割线lRet = SetMenuItemBitmaps(sHandle, 0, MF_BYPOSITION, imOpen.Picture, imSave.Picture)lRet = SetMenuItemBitmaps(sHandle, 1, MF_BYPOSITION, imSave.Picture, imSave.Picture)lRet = SetMenuItemBitmaps(sHandle, 3, MF_BYPOSITION, imPrint.Picture, imPrint.Picture)lRet = SetMenuItemBitmaps(sHandle, 4, MF_BYPOSITION, imPrintSetup.Picture, imPrintSetup.Picture)取得mHandle句柄所指菜单的第二个弹出式菜单（编辑&E）的句柄并赋值给sHandlesHandle = GetSubMenu(mHandle, 1)取得sHandle句柄所指菜单的第一个次级菜单（次级菜单&S）的句柄并赋值给sHandle2sHandle2 = GetSubMenu(sHandle, 0)将次级菜单中的第1项加上图片lRet = SetMenuItemBitmaps(sHandle2, 0, MF_BYPOSITION, imCopy.Picture, imCopy.Picture)提示：在SetMenuItemBitmaps（）我们把后两项设为相同的图片，如果设为不同的两张图片会有什么效果呢？原来这两张图片分别表示复选和撤消复选时的状态,你只须在菜单项被点击的函数中加入以下语句：Private Sub mnuOpen_Click() If mnuOpen.Checked = True Then mnuOpen.Checked = False Else: mnuOpen.Checked = True End IfEnd Sub然后在SetMenuItemBitmaps（）我们把后两项设为不同的图片即可，有兴趣的话试一试。End Sub注册表操作函数*下面先声明一些常量*Public Const HKEY_CLASSES_ROOT = &H80000000Public Const HKEY_CURRENT_CONFIG = &H80000005Public Const HKEY_CURRENT_USER = &H80000001Public Const HKEY_DYN_DATA = &H80000006Public Const HKEY_LOCAL_MACHINE = &H80000002Public Const HKEY_USERS = &H80000003Public Const REG_OPTION_NON_VOLATILE = 0Public Const KEY_ALL_ACCESS = (&H20000 Or &H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H20) And (Not &H100000)Public Const REG_SZ = 1Public Const REG_DWORD = 4*下面声明注册表操作中用到的API函数*Public Declare Function RegCreateKey Lib advapi32.dll Alias RegCreateKeyA (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As LongPublic Declare Function RegCloseKey Lib advapi32.dll (ByVal hKey As Long) As LongPublic Declare Function RegOpenKeyEx Lib advapi32.dll Alias RegOpenKeyExA (ByVal hKey As Long, ByVal lpSubKey As String, ByVal uloptions As Long, ByVal samDesired As Long, phkResult As Long) As LongPublic Declare Function RegDeleteKey Lib advapi32.dll Alias RegDeleteKeyA (ByVal hKey As Long, ByVal lpSubKey As String) As LongPublic Declare Function RegSetValueEx Lib advapi32.dll Alias RegSetValueExA (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As LongPublic Declare Function RegSetValueExLong Lib advapi32.dll Alias RegSetValueExA (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As LongPublic Declare Function RegSetValueExString Lib advapi32.dll Alias RegSetValueExA (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As LongPublic Declare Function RegDeleteValue Lib advapi32.dll Alias RegDeleteValueA (ByVal hKey As Long, ByVal lpValueName As String) As Long*下面是我自己写的一些注册表操作中常用的一些函数*新键注册表项Public Function createnewkey(ip As Long, snewkeyname As String)Dim hnewkey As LongDim retval As Longretval = RegCreateKey(ip, snewkeyname, hnewkey)If retval = 0 Then RegCloseKey (hnewkey) 关闭上面建立或打开的项End IfEnd Function实例：在HKEY_CURRENT_USER下建立项xiaopeng代码为 createnewkey HKEY_CURRENT_USER ,xiaopeng*删除注册表项*Public Function deletekey(ip As Long, skeyname As String)Dim hKey As LongDim retval As Longretval = RegOpenKeyEx(ip, skeyname, 0, KEY_ALL_ACCESS, hKey)If retval = 0 Then RegDeleteKey ip, skeynameEnd IfEnd Function实例：删除上面建立的HKEY_CURRENT_USER下的项xiaopeng代码为 deletekey HKEY_CURRENT_USER ,xiaopeng*新建,设置数值名称*Public Function setkeyvalue(ByVal ip As Long, ByVal keyname As String, ByVal valuename As String, ByVal valuesetting As Variant, ByVal valuetype As Long)Dim retval As LongDim hKey As LongIf RegOpenKeyEx(ip, keyname, 0, KEY_ALL_ACCESS, hKey) 0 Then Exit FunctionSelect Case valuetypeCase REG_SZ RegSetValueExString hKey, valuename, 0&, REG_SZ, valuesetting, Len(valuesetting)Case REG_DWORD RegSetValueExLong hKey, valuename, 0, valuetype, valuesetting, 4End SelectRegCloseKey (hKey)End Function实例：在HKEY_CURRENT_USER下的项xiaopeng中建立名为redice,键值为is xiaopeng,类型为REG_SZ的新键代码为 setkeyvalue HKEY_CURRENT_USER ,xiaopeng ,redice,is xiaopeng,REG_SZ又如:在HKEY_CURRENT_USER下的项xiaopeng中建立名为ceshi,键值为2,类型为REG_DWORD的新键代码为setkeyvalue HKEY_CURRENT_USER,xiaopeng,ceshi,2,REG_DWORD*删除数值名称*Public Function deletevalue(ByVal ip As Long, ByVal keyname As String, ByVal valuename As String)Dim retval As LongDim