mmain.bas

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

        MsgBox "读取系统路径出错！！！", vbInformation + vbOKOnly, ""
        mGetWindowsPath = ""
        Screen.MousePointer = vbDefault
        Exit Function
    Else
        WinFilePath = Mid(tmpWin, 1, sLen)
    End If
    
    mGetWindowsPath = WinFilePath
    
    Exit Function
ErrGetWindowsPath:
    Screen.MousePointer = vbDefault
    mGetWindowsPath = ""
    gShowMsg "读取Windows系统路径出错 "

End Function

Public Function bExistDataBase(sDBName As String) As Boolean
'**********************************************
'
'Purpose:
'       是否已经存在数据库
'Argument:
'       sDBName ---------- 数据库名称
'
'**********************************************

    Dim sSql        As String
    Dim Rs          As New ADODB.Recordset
    
    
    Dim lResult     As Integer
    
    On Error GoTo errSQLExistDatabase
    
    
    sSql = "select CntDB = count(*)"
    sSql = sSql & " From master.dbo.sysdatabases"
    sSql = sSql & " Where name = '" & sDBName & "'"
    
    Screen.MousePointer = vbHourglass
    Rs.Open sSql, CN
    Screen.MousePointer = vbDefault
    
    If Rs!CntDB = 0 Then
        bExistDataBase = False
    Else
        bExistDataBase = True
    End If
    Rs.Close
    
    Exit Function
errSQLExistDatabase:
    Screen.MousePointer = vbDefault
    bExistDataBase = False
    Exit Function
End Function

Public Function gNumericKey(KeyAscii As Integer, Optional bPot As Boolean) As Integer
'**************************************************
'
'Purpose:
'       filter key to get Numeric key
'
'**************************************************
    
    gNumericKey = KeyAscii
    
        Select Case KeyAscii
        Case 8
            ' Backspace OK
        Case 3, 22, 24
            'Ctrl-C,Ctrl-V,Ctrl_X.
        Case 48 To 57
             ' 0 to 9 ok
        Case 45
            KeyAscii = 45
        Case 46
            If IsMissing(bPot) Or bPot = False Then
                gNumericKey = 0
            Else
                gNumericKey = 46
            End If
            '.'
        Case vbKeyDecimal
        Case vbKeyReturn
        Case vbKeyEscape
        Case Else
            ' Everything else a no-no
            gNumericKey = 0
    End Select

End Function

Public Function gGetMaxDate(Year As String, Mon As Integer) As Date
'***********************************************
'
'返回当月最大日期
'
'***********************************************
    Dim sDate       As Date
    Dim i           As Integer
    
    sDate = Format(Year & "-" & Mon & "-28", "yyyy-mm-dd")
    For i = 1 To 4
        sDate = sDate + 1
        If Month(sDate) <> Mon Then Exit For
    Next i
    
    gGetMaxDate = sDate - 1
    
End Function


Public Function gMakeSeriesNum(ByVal sSourceText As String) As String
'***********************************
'
'生成连续的编号
'
'***********************************

    Dim i       As Integer
    Dim lTmp     As Long
    Dim iStrLen As Integer
    Dim sTmpStr  As String
    
    sSourceText = Trim(sSourceText)

    If sSourceText <> "" Then
        iStrLen = Len(sSourceText)
        
        For i = 1 To iStrLen
            sTmpStr = Mid(sSourceText, iStrLen - i + 1, 1)
            If IsNumeric(sTmpStr) = False Then
                lTmp = Val(Right(sSourceText, i - 1)) + 1
                Exit For
            End If
        Next
        
        If lTmp = 1 Then
            gMakeSeriesNum = sSourceText & "1"
        Else
            sTmpStr = CStr(CLng("1" & Right(sSourceText, i - 1)) + 1)
            gMakeSeriesNum = Mid(sSourceText, 1, Len(sSourceText) - i + 1) & Mid(sTmpStr, 2, Len(sTmpStr) - 1)
        End If
    Else
        gMakeSeriesNum = ""
    End If

End Function

Public Function mbExportData(comdlg As Object, vsflex As Object, sTitle As String) As Boolean
'***************************************************
'
'导出vsflex表中的数据
'
'***************************************************
    
    On Error GoTo ErrCancel
    
    comdlg.DialogTitle = "数据导出"
    comdlg.Filter = "Excel文件(*.xls)|*.xls|文本文件(*.txt)|*.txt"
    comdlg.ShowSave
    comdlg.CancelError = True
    If comdlg.FileName = "" Then
        mbExportData = False
        Exit Function
    End If
    
    If Right(comdlg.FileName, 3) = "txt" Then
        mbExportData = mbExportTxt(comdlg.FileName, vsflex, sTitle)
    Else
        mbExportData = mbExportExcel(comdlg.FileName, vsflex, sTitle)
    End If
    
    If mbExportData Then MsgBox "数据导出成功！！！", vbInformation + vbOKOnly, ""
    Exit Function

ErrCancel:
    mbExportData = False
    
End Function
                                            
Public Function mbExportTxt(FileName As String, vsflex As Object, sTitle As String) As Boolean
'***************************************************************
'
'将VSFLEX表中的数据以文本文件形式导出
'
'****************************************************************
    Dim FileNum         As Integer
    Dim strTmp          As String
    Dim iRow            As Integer
    Dim iCol            As Integer
    
    FileNum = FreeFile
    
    On Error GoTo ErrExportTxt
    
    If ExistFile(FileName) Then
        If MsgBox("该文件已经存在！！！" & vbCrLf & "是否覆盖原文件？", vbCritical + vbYesNo, "") = vbYes Then
            '删除该文件
            Kill FileName
            '重新创建文件
            Open FileName For Output As #FileNum
        Else
            If MsgBox("导出的数据将增加到该文件末尾？", vbQuestion + vbYesNo, "") = vbYes Then
                Open FileName For Append As #FileNum
            Else
                MsgBox "用户取消了数据导出操作！！！", vbInformation + vbOKOnly, ""
                mbExportTxt = False
                Exit Function
            End If
        End If
    Else
        Open FileName For Output As #FileNum
    End If
    
    '打印标题
    Print #1, sTitle
    Print #1, vbTab
    
    For iRow = 0 To vsflex.Rows - 1
        For iCol = 0 To vsflex.Cols - 1
            strTmp = strTmp & vsflex.TextMatrix(iRow, iCol) & vbTab
        Next iCol
        strTmp = Mid(strTmp, 1, Len(strTmp) - 1)
        Print #FileNum, strTmp
        strTmp = ""
    Next iRow
        
    Close #FileNum
    mbExportTxt = True
    Exit Function
ErrExportTxt:
    Screen.MousePointer = vbDefault
    mbExportTxt = False
    gShowMsg "导出文本文件数据出错 mPublicLiao.mbExportTxt"
    
End Function

Public Function mbExportExcel(FileName As String, vsflex As Object, sTitle As String) As Boolean
'***************************************************************
'
'将VSFLEX表中的数据以文本文件形式导出
'
'****************************************************************
    Dim i               As Integer
    Dim J               As Integer
    Dim iRow            As Integer
    Dim iCol            As Integer
    Dim xlApp           As Excel.Application
    Dim xlSheet         As New Excel.Worksheet
    Dim xlBook          As New Excel.Workbook
    Dim strSource       As String
    Dim strDestination  As String
    Dim bCopy           As Boolean

    On Error GoTo ErrExportExcel
    
    Set xlApp = New Excel.Application
    Set xlApp = CreateObject("Excel.Application")

    'model.xls就是一个模版文件
    strSource = App.Path & "\lib\model.xls"
    If ExistFile(strSource) = False Then
        MsgBox "模版文件不存在,不能导出EXCEL格式数据。" & vbCrLf & "请在\lib目录下建立model.xls文件，再进行导出即可", vbInformation, ""
        mbExportExcel = False
        Exit Function
    End If

    If ExistFile(FileName) Then
        If MsgBox("该文件已经存在！！！" & vbCrLf & "是否覆盖原文件？", vbCritical + vbYesNo, "") = vbYes Then
            '删除该文件
            Kill FileName
        Else
            mbExportExcel = False
            MsgBox "用户取消了数据导出操作！！！", vbInformation, ""
            Exit Function
        End If
    End If

    strDestination = FileName

    FileCopy strSource, strDestination

    '打开工作簿，strDestination为一个EXCEL报表文件
    Set xlBook = xlApp.Workbooks.Open(strDestination)

    '设置工作页
    Set xlSheet = xlBook.Worksheets(1)
    '标题
    xlSheet.Cells(1, 1) = sTitle

    '正文
    For iRow = 0 To vsflex.Rows - 1
        For iCol = 0 To vsflex.Cols - 1
            xlSheet.Cells(iRow + 2, iCol + 1) = vsflex.TextMatrix(iRow, iCol)
        Next iCol
    Next iRow
    
    xlBook.Save
    xlApp.Quit

    mbExportExcel = True
    Exit Function
ErrExportExcel:
    Screen.MousePointer = vbDefault
    xlBook.Save
    xlApp.Quit
    mbExportExcel = False
    gShowMsg "导出Excel格式出错 mpublicliao.mbExportExcel"
    
End Function

Public Function gGetCompanyName() As String
'************************************************
'
'取得公司名称用于打印
'
'************************************************
    Dim Rst         As New ADODB.Recordset
    
    Screen.MousePointer = vbHourglass
    Rst.Open "select CName  from Company", CN
    Screen.MousePointer = vbDefault
    
    If Not Rst.EOF Then
        gGetCompanyName = Rst(0)
    Else
        gGetCompanyName = ""
    End If
    Rst.Close
    
End Function