module1.bas

会员管理系统 功能自己扩展把！ 如果有改进给我发一份[e-mail] 这个比较适合初学者``` Q：151693707 msn:[e-mail]

Attribute VB_Name = "Module1"
Option Explicit
'全局对象，控制可访问
Public conConnection As ADODB.Connection
Public rctrecordset As ADODB.Recordset
'声音播放声明
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwnewlong As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByRef lColorRef As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, lpRect As Long, ByVal bErase As Long) As Long
Private Const GCL_HBRBACKGROUND As Long = -10
'声间播放常量
Global Const SND_SYNC = &H0
Global Const SND_ASYNC = &H1
Global Const SND_NODEFAULT = &H2
Global Const SND_LOOP = &H8
Global Const SND_NOSTOP = &H10
Public mypath As String
Public Function ConnectToServer(ByVal strDBName As String) As Boolean
On Error GoTo ON_Error
'call closeConnect
Set conConnection = New Connection
'Set rctrecordset = New Recordset
conConnection.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBName
conConnection.ConnectionTimeout = 30 '30秒等待时间
conConnection.Open
ConnectToServer = True
Exit Function
ON_Error:
MsgBox "错误描述" & Err.Description & vbCrLf & ":错误代码" & Err.Number, vbCritical + vbOKOnly, "打开数据库错误"
ConnectToServer = False
End Function
'连接关闭
Public Function CloseConnect() As Boolean
On Error Resume Next
 If (Not conConnection Is Nothing) Then conConnection.Close
 Set conConnection = Nothing
End Function
'执行查询
Public Function RunSQL(ByVal strSQL As String) As Boolean
On Error GoTo ON_Error
    Set rctrecordset = Nothing
    Set rctrecordset = conConnection.Execute(strSQL)
    RunSQL = True
    Exit Function
ON_Error:
MsgBox "错误描述" & Err.Description & vbCrLf & ";错误代码：" & Err.Number, vbCritical + vbOKOnly, "打开数据库错误"
RunSQL = False
End Function
'声音播放函数

Public Sub PlayWav(SoundName As String)
Dim wFlags As Long, X As Long
wFlags = SND_ASYNC Or SND_NODEFAULT
X = sndPlaySound(SoundName, wFlags)
End Sub

Private Function GDI_TranslateColor(OleClr As OLE_COLOR, Optional hPal As Integer = 0) As Long
    ' used to return the correct color value of OleClr as a long
    If OleTranslateColor(OleClr, hPal, GDI_TranslateColor) Then
        GDI_TranslateColor = &HFFFF&
    End If
End Function

Function GDI_CreateSoildBrush(bColor As OLE_COLOR) As Long
    'Create a Brush form a picture handle
    GDI_CreateSoildBrush = CreateSolidBrush(GDI_TranslateColor(bColor))
End Function

Public Sub SetToolbarBG(hWnd As Long, hBmp As Long)
    'Set the toolbars background image
    DeleteObject SetClassLong(hWnd, GCL_HBRBACKGROUND, CreatePatternBrush(hBmp))
    InvalidateRect 0&, 0&, False
End Sub

Public Sub SetToolbarBK(hWnd As Long, hColor As OLE_COLOR)
    ' Set a toolbars Backcolor
    DeleteObject SetClassLong(hWnd, GCL_HBRBACKGROUND, GDI_CreateSoildBrush(hColor))
    InvalidateRect 0&, 0&, False
End Sub