该楼层疑似违规已被系统折叠 隐藏此楼查看此楼

'**************************************** Module1.bas 模块代码

'工程 上面按下右键 工程1属性 设定以 Main 启动

Option Explicit

Public Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long, ByVal wlange As Long, ByVal dwTimeout As Long) As Long

Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long

Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Public Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public CONN As New ADODB.Connection '定义数据连接字符串

Public RS As New ADODB.Recordset '定义记录集

Public Const WS_EX_LAYERED = &H80000

Public Const GWL_EXSTYLE = (-20)

Public Const LWA_ALPHA = &H2

Public Const LWA_COLORKEY = &H1

Public Const vbKeyAlt = vbKeyMenu

Public AppDisk$, DataDisk$, DB$, MsgTitle$, UserName$, PassWord$, UserLevel$

Public LoginYn As Boolean

Public Rtn&, ErrPass&

Sub Main()

MsgTitle = "数据库登录练习" '项目名称赋值给变量 MsgTitle

'禁止两次运行本程序

If App.PrevInstance Then Call MsgBox("对不起本程序已在运行中, 不得重复加载!!", vbCritical, MsgTitle): End

AppDisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\") '本地路径赋值给变量AppDisk

DataDisk = AppDisk & "Data\" '将本地路径下的DATA文件夹赋值给变量DataDisk

If Dir(DataDisk, vbDirectory) = "" Then MkDir DataDisk '如果DataDisk变量指定的文件夹不存在则创建它

MainForm.Show '运行主程序MainForm

Log.Show '运行登录程序Log

End Sub

'以搜索关键字词在数据库某个表,某个字段查找 返回真或假的副程序

Public Function SearchDATA(TMPRS As Object, SchZD As String, SchData As String) As Boolean

On Error Resume Next

SearchDATA = False '初始查找变量 SearchDATA为 假

TMPRS.MoveFirst '查找到之后 记录移到第一笔

TMPRS.Find SchZD & " = " & Chr(39) & SchData & Chr(39)

If Not TMPRS.EOF Then SearchDATA = True '如果查找到 则 SearchDATA函数返回 真

End Function

Public Sub RoundWin(Tform As Object, WW&, HH&) '创建圆角窗体的副程序

Dim W&, H&

On Error Resume Next

W = Tform.Width \ Screen.TwipsPerPixelX '将窗体的宽度除以屏幕每个像素点的值(15) 转换为像素，带入变量W

H = Tform.Height \ Screen.TwipsPerPixelY '将窗体的高度除以屏幕每个像素点的值(15) 转换为像素，带入变量H

SetWindowRgn Tform.hwnd, CreateRoundRectRgn(0, 0, W, H, WW, HH), True '以带进之参数WW与HH创建窗体圆角

Tform.Move (Screen.Width - Tform.Width) \ 2, (Screen.Height - Tform.Height) \ 2 '窗体居于屏幕中心

End Sub

Public Sub CleanAll() '结束程序退出的副程序

On Error Resume Next

'关闭所有打开的窗体并释放对象

Dim TmpFrm As Form

For Each TmpFrm In Forms

Unload TmpFrm

Set TmpFrm = Nothing

Next

End '结束程序退出

End Sub