mdlfunction.bas

朋友给的

        Case 129, 200, 201, 202
            Dim lSize As Integer
            lSize = rstCheck(strFieldName).DefinedSize
            If RealLength(strValue) > lSize Then
                If ChineseName = "" Then
                    MsgBox strCaption & "不能超过" & lSize & "个字节！(汉字算两个字节)", vbInformation + vbOKOnly
                Else
                    MsgBox ChineseName & "不能超过" & lSize & "个字节！(汉字算两个字节)", vbInformation + vbOKOnly
                End If
                FieldCheck = False
                ControlName.SetFocus
                SendKeys "{HOME}+{END}"
                Exit Function
            End If
        'datetime类型
        Case 135, 7
        If Not IsDate(strValue) And strValue <> "" Then
            If ChineseName = "" Then
                MsgBox strCaption & "的值日期格式不正确！", vbInformation + vbOKOnly
            Else
                MsgBox ChineseName & "的值日期格式不正确！", vbInformation + vbOKOnly
            End If
            FieldCheck = False
            ControlName.SetFocus
            SendKeys "{HOME}+{END}"
            Exit Function
        End If
        '数值型
        Case 2, 3, 4, 5, 6, 17, adNumeric, adDecimal
            If strValue = "" Then
                FieldCheck = True
                Exit Function
            End If
            
            If Not IsNumeric(strValue) Then
                If ChineseName = "" Then
                    MsgBox strCaption & "不是一个数值！", vbInformation + vbOKOnly
                Else
                    MsgBox ChineseName & "不是一个数值！", vbInformation + vbOKOnly
                End If
                FieldCheck = False
                ControlName.SetFocus
                SendKeys "{HOME}+{END}"
                Exit Function
            End If
            
            Select Case rstCheck(strFieldName).Type
            'tinyint类型
            Case 17
                If strValue > 255 Or strValue < 0 Then
                    If ChineseName = "" Then
                        MsgBox strCaption & "的值只能在0和255之间！", vbInformation + vbOKOnly
                    Else
                        MsgBox ChineseName & "的值只能在0和255之间！", vbInformation + vbOKOnly
                    End If
                    FieldCheck = False
                    ControlName.SetFocus
                SendKeys "{HOME}+{END}"
                    Exit Function
                End If
            'smallint类型
            Case 2
                If strValue > 32767 Or strValue < -32768 Then
                    If ChineseName = "" Then
                        MsgBox strCaption & "的值只能在-32768和32767之间！", vbInformation + vbOKOnly
                    Else
                        MsgBox ChineseName & "的值只能在-32768和32767之间！", vbInformation + vbOKOnly
                    End If
                    FieldCheck = False
                    ControlName.SetFocus
                    SendKeys "{HOME}+{END}"
                    Exit Function
                End If
            'int类型
            Case 3
                If strValue > 2147483647 Or strValue < -2147483647 Then
                    If ChineseName = "" Then
                        MsgBox strCaption & "的值只能在-2,147,483,648和2,147,483,647之间！", vbInformation + vbOKOnly
                    Else
                        MsgBox ChineseName & "的值只能在-2,147,483,648和2,147,483,647之间！", vbInformation + vbOKOnly
                    End If
                    FieldCheck = False
                    ControlName.SetFocus
                    SendKeys "{HOME}+{END}"
                    Exit Function
                End If
            'real类型
            Case 4
                If strValue > 3.402823E+38 Or strValue < -3.402823E+38 Then
                    If ChineseName = "" Then
                        MsgBox strCaption & "的值只能在-3.402823*10^38和3.402823*10^38之间！", vbInformation + vbOKOnly
                    Else
                        MsgBox ChineseName & "的值只能在-3.402823*10^38和3.402823*10^38之间！", vbInformation + vbOKOnly
                    End If
                    FieldCheck = False
                    ControlName.SetFocus
                    SendKeys "{HOME}+{END}"
                    Exit Function
                End If
            'float类型
            Case 5
                If strValue > 1.79769313486231E+308 Or strValue < -1.79769313486231E+308 Then
                    If ChineseName = "" Then
                        MsgBox strCaption & "的值只能在-1.79769313486232*10^308和1.79769313486231*10^308 之间！", vbInformation + vbOKOnly
                    Else
                        MsgBox ChineseName & "的值只能在-1.79769313486232*10^308和1.79769313486231*10^308 之间！", vbInformation + vbOKOnly
                    End If
                    FieldCheck = False
                    ControlName.SetFocus
                    SendKeys "{HOME}+{END}"
                    Exit Function
                End If
            'money类型
            Case 6
                If Len(Int(strValue)) > 15 Then
                    If ChineseName = "" Then
                        MsgBox strCaption & "的值整数位数不能超过15位！", vbInformation + vbOKOnly
                    Else
                        MsgBox ChineseName & "的值整数位数不能超过15位！", vbInformation + vbOKOnly
                    End If
                    FieldCheck = False
                    ControlName.SetFocus
                    SendKeys "{HOME}+{END}"
                    Exit Function
                End If
            End Select
    End Select
    FieldCheck = True
    Exit Function
    
Err_Handle:
    ErrMessage
End Function

''************************
''得到当前时间
''************************
'Public Function GetCurrentTime() As Date
'    Dim intHour As Integer
'    Dim intMin  As Integer
'    Dim intSec  As Integer
'    Dim lngTick As Long
'
'    lngTick = (GetTickCount() - glngBeginTick) / 1000
'    intHour = lngTick \ 3600
'    intMin = (lngTick - intHour * 3600) \ 60
'    intSec = lngTick - intHour * 3600 - intMin * 60
'    GetCurrentTime = Format(gdtmBeginTime + TimeSerial(intHour, intMin, intSec), "yyyy-mm-dd hh:nn:ss")
'End Function
'
Public Function ChangToXLS(MsFGridName As MSFlexGrid, strFileName As String, intFileType As Integer) As String
    Dim i As Integer
    Dim j As Integer
    Dim fso As New FileSystemObject
    Dim File1 As File
    Dim ts As TextStream
    Dim strOneLine As String
    Dim ExlApp As Excel.Application
    Dim ExlBook As Excel.Workbook
    Dim ExlSheet As Excel.Worksheet
    
    On Error GoTo ErrLab
    
    If 1 > MsFGridName.Rows Then
        ChangToXLS = "没有可以生成报表的记录！"
        Exit Function
    End If
    
    If strFileName = "" Then
        ChangToXLS = "没有可以生成报表的文件！"
        Exit Function
    End If
    
    Select Case intFileType
    Case 1  'TXT文件
'*************************************************************************************
        strFileName = strFileName & ".TXT"
            
        If fso.FileExists(strFileName) Then fso.DeleteFile strFileName, True
            Set ts = fso.CreateTextFile(strFileName, True)
        
        For i = 1 To MsFGridName.Rows
            strOneLine = ""
            For j = 0 To MsFGridName.Cols - 1
                strOneLine = strOneLine & Trim(MsFGridName.TextMatrix(i - 1, j)) & ","
            Next
            ts.WriteLine (strOneLine)
        Next
        
        ts.Close
        Set ts = Nothing
        Set File1 = Nothing
        Set fso = Nothing
        MsgBox "资料输出完毕" & vbCrLf & vbCrLf & "文件名为：" & strFileName, , "资料输出"
    
'*************************************************************************************
    Case 2
'*************************************************************************************
        strFileName = strFileName
        If fso.FileExists(strFileName) Then fso.DeleteFile strFileName, True
        
        Set ExlApp = CreateObject("Excel.Application")
        Set ExlBook = ExlApp.Workbooks.Add
        Set ExlSheet = ExlBook.Worksheets(1)
        
        For j = 0 To MsFGridName.Cols - 1
            
            If j \ 26 = 0 Then
                 strOneLine = Chr(65 + j Mod 26)
            Else
'                strOneLine = Chr(65 + j / 26) & Chr(65 + j Mod 26)
                strOneLine = Chr(65) & Chr(65 + (j - 26) Mod 26)
            End If
'            ExlSheet.Range(strOneLine & "1").ColumnWidth = MsFGridName.ColWidth(j)
            
            For i = 1 To MsFGridName.Rows
                ExlSheet.Range(strOneLine & CStr(i + 1)) = Trim$(MsFGridName.TextMatrix(i - 1, j))
                ExlSheet.Range(strOneLine & CStr(i + 1)).HorizontalAlignment = xlCenter
                ExlSheet.Range(strOneLine & CStr(i + 1)).VerticalAlignment = xlCenter
                ExlSheet.Range(strOneLine & CStr(i + 1)).Borders.LineStyle = 1
            Next
        Next
        
        ExlBook.SaveAs strFileName
        ExlApp.Visible = True
        
        Set ExlApp = Nothing
'**************************************************************************************
    Case Else
        ChangToXLS = "不可识别文件类型!"
        Exit Function
    End Select
    
    ChangToXLS = "0"
    Exit Function
ErrLab:
    Set File1 = Nothing
    Set ts = Nothing
    Set fso = Nothing
    If Err <> 0 Then ChangToXLS = Err.Description
End Function

Public Sub ListTablesInDB(UserAdoCon As ADODB.Connection, ListCon As Object, Optional strTableHead As String = "F_")    '2个头标志

On Error GoTo ErrProcess
  Dim rsSchema As ADODB.Recordset
  Dim newTableName As String

    ListCon.Clear
    With UserAdoCon
        If .State = adStateOpen Then
        Set rsSchema = .OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, Empty))
            If Not rsSchema Is Nothing Then
                Do While Not rsSchema.EOF
                    If UCase(Left(rsSchema!Table_name, 2)) = strTableHead Then
                        newTableName = Mid$(rsSchema!Table_name, 3)
                        ListCon.AddItem newTableName
                    End If
                    rsSchema.MoveNext
                Loop
            End If
        End If
        rsSchema.Close
    End With
Exit Sub

ErrProcess:
    MsgBox Err.Description
End Sub

Function RealLength(ByVal str As String) As Long
'============
'字串的字节数
'============
On Error GoTo Err_Handle
    RealLength = VBA.LenB(VBA.StrConv(str, vbFromUnicode)) + 1
    Exit Function
Err_Handle:
    Call ErrMessage
End Function

Public Function GetMaxBH(strTable As String, strSerial As String) As Integer
    Dim rcTemp As New ADODB.Recordset
    
    rcTemp.Open "SELECT Max(" & strSerial & ") as aa  FROM " & strTable & " ", gCnn, adOpenStatic, adLockPessimistic
    If rcTemp.EOF Then
        GetMaxBH = 0
    ElseIf IsNull(rcTemp(0)) Then
        GetMaxBH = 0
    Else
        GetMaxBH = rcTemp(0)
        GetMaxBH = GetMaxBH + 1
    End If
End Function

Public Function FillListviewWithSql(objFrm As Form, objLvw As ListView, sql As String, objConn As ADODB.Connection) As Long
    Dim i As Integer
    Dim Item As ListItem
    Dim objrs As New ADODB.Recordset
    
    objrs.Open sql, objConn, adOpenForwardOnly, adLockReadOnly
    
    With objLvw
        objLvw.ColumnHeaders.Clear
        objLvw.ListItems.Clear
        
        For i = 0 To objrs.Fields.count - 1
            .ColumnHeaders.Add , , objrs.Fields(i).name, 1200
        Next i
        
        If Not objrs.EOF Then objrs.MoveFirst
        
        While Not objrs.EOF
            Set Item = objLvw.ListItems.Add(, , objrs(0) & "")
            For i = 1 To objrs.Fields.count - 1
                Item.SubItems(i) = objrs(i) & ""
            Next i
            
            objrs.MoveNext
        Wend
    End With
    
    objrs.Close
    Set objrs = Nothing
    
    FillListviewWithSql = objLvw.ListItems.count
End Function