mmain.bas

这个是我以前做的一个客户管理系统.包内已经含有源码和所用到的控件.代码是用VB写的,数据库采用MSSQL的.

Attribute VB_Name = "MMain"
Option Explicit

Public CN As ADODB.Connection               '全局数据库连接变量
Public gUserID As Integer                   '用户ID号
Public gUserName As String                  '用户名称
Public iFather(1 To 4) As Integer           '存储父节点的ID号

Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd 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 Const GWL_EXSTYLE = (-20)
Public Const WS_EX_DLGMODALFRAME = &H1&

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long, _
    ByVal lpFileName As String) As Long

Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpString As Any, _
    ByVal lpFileName As String) As Long

'读取Windows系统路径
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long


Private 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 WM_KEY = 119               '消息类型
    Public Const WM_KEYDOWN = &H100
    Public Const WM_KEYUP = &H101
    Public Const VK_LEFT = &H25
    Public Const VK_DOWN = &H28
    Public Const VK_UP = &H26
    Public Const VK_RIGHT = &H27
    Public Const WM_ACTIVATE = &H6
    Public Const VK_F5 = &H74
    Public Const VK_F8 = &H77
    Public iirow  As Integer
    Public Const GW_CHILD = 5
    
'*******************************业务类型****************************
Public Enum YeWuType
    ywArchives = 1
    ywTalkRecord = 2
    ywTradeRecord = 3
    ywPlanManage = 4
    ywBackPicture = 5
    ywCustomerInfo = 6
End Enum

Public InYeWu As YeWuType



Public Function SendMessageToCtl(Ctl As Variant, wMsg%, wParam%, lParam&)
'*************************************************************************
'
'Purpose
'       将消息发送给控件
'
'*************************************************************************
    Dim CtlHwnd         As Long
    Dim i               As Integer
    
'    Ctl.SetFocus
    CtlHwnd = Ctl.hwnd
'    CtlHwnd = GetFocus()
    i = SendMessage(CtlHwnd, wMsg%, wParam%, lParam&)
    
End Function


Sub Main()

   

End Sub



Public Sub Center(frm As Variant, Optional bFont As Boolean, Optional vParent)
'************************************************
'
'Purpose:
'   使窗体居中
'   格式:   SDI-form (gCenter Me)
'           MDIChild form (gCenter Me,MDIForm).
'
'************************************************
    On Error Resume Next
    If IsMissing(vParent) Then Set vParent = Screen
    With frm
        .Top = (vParent.Height - .Height) / 2
        .Left = (vParent.Width - .Width) / 2
    End With
    
    If IsMissing(bFont) Or bFont Then SetFormFont frm

    Err.Clear
    
End Sub

Public Sub SetFormFont(frm As Variant, Optional strFontName, Optional sngFontSize)
'************************************************
'
'Purpose:
'       设置窗体字体
'
'************************************************

  Dim strName As String
  Dim sngSize As Single
  
  If IsMissing(strFontName) Then
    strName = "宋体"
  Else
    strName = strFontName
  End If
  If IsMissing(sngFontSize) Then
    sngSize = 9
  Else
    sngSize = sngFontSize
  End If
  
  On Error Resume Next
  
  Dim Ctl As Control
  
  For Each Ctl In frm.Controls
    With Ctl
        .Font.Name = strName
        .Font.Size = sngSize
        .HelpContextID = frm.HelpContextID
    End With
    If TypeOf Ctl Is CommandButton Then
        With Ctl
            If .Caption = "..." Then
                .Font.Name = "MS Sans Serif"
                .Font.Size = 8
                .Font.Bold = False
            End If
        End With
    End If
  Next

End Sub

Public Sub gShowMsg(msg As String, Optional iFlag As Byte)
'************************************************
'
'Purpose:
'       简化弹出Message box
'
'************************************************
    If IsMissing(iFlag) Or iFlag = 0 Then
        msg = msg & vbCrLf & "错误代码: " & Err.Number & vbCrLf & "错误来源: " & Err.Source & vbCrLf
        MsgBox msg & Err.Description, vbInformation, "警告"
    Else
        msg = msg & vbCrLf & "错误代码: " & Err.Number & vbCrLf & "错误来源: " & Err.Source & vbCrLf
        MsgBox msg & Err.Description, vbInformation, "提示"
    End If
    
End Sub

Public Sub WriteLog(ByVal vNewValue As ADODB.Connection, ByVal Operid As String, ByVal Operdate As Date, ByVal logEvent As String)
'************************************************
'Purpose:
'       记录操作日志
'************************************************
    vNewValue.Execute "Insert into gxLog (operid,operdate,LogEvent) values('" & Operid & "','" & Operdate & "','" & logEvent & "')"
End Sub

Public Function sGetAppPath() As String
    If Right$(App.Path, 1) <> "\" Then
        sGetAppPath = App.Path & "\"
    Else
        sGetAppPath = App.Path
    End If
End Function


Public Sub InitTextBox(txt As Variant)
'************************************************
'
'选中textbox中的全部文字
'
'************************************************
    On Error Resume Next
    With txt
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
    
End Sub

Function DoubleQuote(strAny As String) As String
'************************************************
' 将单引号转换成双引号
'
'************************************************
    Dim i As Long
    Dim l As Long
    Dim T As String
    Dim V As String
    
    V = strAny
    l = Len(V)
    For i = 1 To l
      If Mid(V, i, 1) = "'" Then
        T = T & "''"
      Else
        T = T & Mid(V, i, 1)
      End If
    Next i
    DoubleQuote = T
  
End Function

Public Function ExistFile(ByVal PathName As String) As Boolean
'*Purpose:
'*   Check if a file exists

Dim sDb         As String
Dim Rs          As New ADODB.Recordset
Dim sSql        As String
Dim sTmp        As String
On Error GoTo NoFile
    
    sTmp = Dir(PathName, 32 + 16 + 2 + 0 + 1 + 4)
    If Len(Trim(sTmp)) = 0 Then
        ExistFile = False
    Else
        ExistFile = True
    End If
    
    Exit Function

NoFile:
    ExistFile = False
    Exit Function

End Function

Public Function mbSaveServerInfo(svrName As String, UsrName As String, usrPassword As String, DBName As String) As Boolean

    Dim bRet        As Long
    Dim sFile       As String
    
    sFile = App.Path & "\Lib\" & "login.ini"
    bRet = WritePrivateProfileString("SERVER", "ServerName", svrName, sFile)
    bRet = WritePrivateProfileString("SERVER", "UserName", UsrName, sFile)
    bRet = WritePrivateProfileString("SERVER", "Password", usrPassword, sFile)
    bRet = WritePrivateProfileString("SERVER", "DBName", DBName, sFile)
    mbSaveServerInfo = True
    
End Function

Public Function gGetServerInfo(iType As Integer) As String
'***********************************************************
'
'Purpose:
'       在Customer.ini文件中读取SQLSERVER的Server,User and Password
'
'Argument:
'           iType: ----------- 1 Get Server Name
'                  ----------- 2 Get User Name
'                  ----------- 3 Get Password String
'
'***********************************************************
    Dim sFile       As String
    Dim tmpStr      As String * 20
    Dim sReturn     As String
    Dim nLen        As Long
    
    On Error GoTo ErrInfo
    sFile = App.Path & "\lib\login.ini"

    If iType = 1 Then
    'Server Name
        nLen = GetPrivateProfileString("SERVER", "ServerName", "", tmpStr, 20, sFile)
        If nLen > 0 Then
            sReturn = Mid(tmpStr, 1, nLen)
        Else
            sReturn = ""
        End If
    ElseIf iType = 2 Then
    'User Name
        nLen = GetPrivateProfileString("SERVER", "UserName", "", tmpStr, 20, sFile)
        If nLen > 0 Then
            sReturn = Mid(tmpStr, 1, nLen)
        Else
            sReturn = ""
        End If
    ElseIf iType = 3 Then
    'Password string
        nLen = GetPrivateProfileString("SERVER", "Password", "", tmpStr, 20, sFile)
        If nLen > 0 Then sReturn = Mid(tmpStr, 1, nLen)
    ElseIf iType = 4 Then
    'DBName
        nLen = GetPrivateProfileString("SERVER", "DBName", "", tmpStr, 20, sFile)
        If nLen > 0 Then sReturn = Mid(tmpStr, 1, nLen)
    End If
    gGetServerInfo = sReturn
    Exit Function
ErrInfo:
    gShowMsg "没有初始化系统，请先进行系统初始化"
    gGetServerInfo = ""
        
End Function

Public Function mGetWindowsPath() As String
'*************************************************
'
'读取Windows系统路径
'
'**************************************************
    
    Dim sLen            As Integer
    Dim tmpWin          As String * 260
    Dim WinFilePath     As String
    
    On Error GoTo ErrGetWindowsPath
    
    sLen = GetWindowsDirectory(tmpWin, 260)
    If sLen = 0 Then