mdlfunction.bas

朋友给的

Public Function AdjustGridColWidth(msfResult As MSFlexGrid, Col As Long)
    On Error Resume Next
    Screen.MousePointer = 11
    Dim i As Long, j As Long
    Dim strTemp As String, lTemp As Long
    Dim lColWidth As Long
    With msfResult
        For j = Col To Col
            lColWidth = 1
            lTemp = 0
            strTemp = ""
            For i = 0 To .Rows - 1
                strTemp = .TextMatrix(i, j)
                lTemp = RealLength(strTemp)
                If lTemp > lColWidth Then
                    lColWidth = lTemp
                End If
            Next i
            If lColWidth > 0 And .ColWidth(j) > 0 Then
                .ColWidth(j) = lColWidth * .Font.Size * 10 + 90
            Else
                .ColWidth(j) = 0
            End If
        Next j
'        Dim k As Single
'        If .ColPos(.Cols - 1) + .ColWidth(.Cols - 1) < .Width Then
'            k = (.Width - 400) / (.ColPos(.Cols - 1) + .ColWidth(.Cols - 1))
'            If i > 1 Then
'                For i = 0 To .Cols - 1
'                    .ColWidth(i) = .ColWidth(i) * k
'                Next i
'            End If
'        End If
    End With
    Screen.MousePointer = 0
End Function

Public Sub AdjustGridWidth(msfResult As MSFlexGrid, Optional iStartRow As Long = 0)
    '自动调整网格宽度
    Screen.MousePointer = 11
    Dim i As Long, j As Long
    Dim strTemp As String, lTemp As Long
    Dim lColWidth As Long
    With msfResult
        For j = 0 To .Cols - 1
            lColWidth = (.ColWidth(j) - 90) / .Font.Size / 10
            lTemp = 0
            strTemp = ""
            For i = iStartRow To .Rows - 1
                strTemp = .TextMatrix(i, j)
                lTemp = RealLength(strTemp)
                If lTemp > lColWidth Then
                    lColWidth = lTemp
                End If
            Next i
            If lColWidth > 0 And .ColWidth(j) > 0 Then
                .ColWidth(j) = lColWidth * .Font.Size * 10 + 90
            Else
                .ColWidth(j) = 0
            End If
        Next j
        Dim k As Single
        If .ColPos(.Cols - 1) + .ColWidth(.Cols - 1) < .Width Then
            k = (.Width - 400) / (.ColPos(.Cols - 1) + .ColWidth(.Cols - 1))
            If i > 1 Then
                For i = 0 To .Cols - 1
                    .ColWidth(i) = .ColWidth(i) * k
                Next i
            End If
        End If
    End With
    Screen.MousePointer = 0
End Sub

Sub FillCombo(lstX As ComboBox, sql As String, Optional iField As Integer = 0)
    Dim rstx As ADODB.Recordset
    lstX.Clear
    Set rstx = New ADODB.Recordset
    rstx.CursorType = adOpenStatic
    rstx.LockType = adLockOptimistic
    rstx.CursorLocation = adUseClient   '加上这一句
    rstx.Open sql, gCnn, , , adCmdText
    If rstx.RecordCount <> 0 Then
        rstx.MoveFirst
        While Not rstx.EOF
            lstX.AddItem rstx(iField)
            rstx.MoveNext
        Wend
    End If
    rstx.Close
    If lstX.ListCount = 0 Then
        lstX.ListIndex = -1
    Else
        lstX.ListIndex = 0
    End If
End Sub

Sub FillList(lstX As ListBox, sql As String, Optional iField As Integer = 0)
    Dim rstx As ADODB.Recordset
    lstX.Clear
    Set rstx = New ADODB.Recordset
    rstx.CursorType = adOpenStatic
    rstx.LockType = adLockOptimistic
    rstx.CursorLocation = adUseClient   '加上这一句
    rstx.Open sql, gCnn, , , adCmdText
    If rstx.RecordCount <> 0 Then
        rstx.MoveFirst
        While Not rstx.EOF
            lstX.AddItem rstx(iField)
            rstx.MoveNext
        Wend
    End If
    rstx.Close
End Sub

Public Function ExistForm(fname As String) As Boolean
    Dim f As Form
    For Each f In Forms
        If f.name = fname Then
            ExistForm = True
            Exit Function
        End If
    Next f
    ExistForm = False
End Function

Public Sub MiddleForm(Form As Form, Optional HPos As Single = 2, Optional VPos As Single = 2.5)
    With Form
        If Form.WindowState = vbNormal Then
            .Left = (frmMain.ScaleWidth - .Width) / VPos
            .Top = (frmMain.ScaleHeight - .Height) / HPos
        End If
    End With
End Sub

Public Function IntegerKeyPress(keyascii As Integer) As Integer
    If keyascii >= Asc("0") And keyascii <= Asc("9") Or keyascii = 8 Or keyascii = 13 Then
        IntegerKeyPress = keyascii
    Else
        keyascii = 0
    End If
End Function

Public Function TeleKeyPress(keyascii As Integer) As Integer
    If keyascii >= Asc("0") And keyascii <= Asc("9") Or keyascii = 8 Or keyascii = 13 _
        Or keyascii = Asc("(") Or keyascii = Asc(")") Or keyascii = Asc("*") Then
        TeleKeyPress = keyascii
    Else
        TeleKeyPress = 0
    End If
End Function

Public Function SingleKeyPress(txtBox As TextBox, keyascii As Integer) As Integer
'---------------------
'小数点后只能输入两位
'---------------------
    Dim Loc As Integer
    
    If (keyascii > Asc("9") Or keyascii < Asc("0")) And keyascii <> 8 And keyascii <> Asc(".") And keyascii <> 13 Then
       keyascii = 0
       SingleKeyPress = keyascii
       Screen.MousePointer = 0: Exit Function
    End If
    Loc = InStr(txtBox.Text, ".")
    If Loc <> 0 And InStr(txtBox.SelText, ".") = 0 And keyascii = Asc(".") Then
       keyascii = 0
       SingleKeyPress = keyascii
       Screen.MousePointer = 0
       Exit Function
    End If
    If Loc <> 0 And Len(txtBox) - Loc > 1 And txtBox.SelStart >= Loc And keyascii <> 8 And keyascii <> 13 Then
        keyascii = 0
        SingleKeyPress = keyascii
        Screen.MousePointer = 0
        Exit Function
    End If
    SingleKeyPress = keyascii
End Function

Public Function StringKeyPress(keyascii As Integer) As Integer
   If keyascii = Asc("|") Or keyascii = Asc("'") Then
      keyascii = 0
   End If
   StringKeyPress = keyascii
End Function

Private Function GetAscValue(n As Integer) As Integer
    Dim TempVal As Integer
    
    If n Mod 2 = 0 Then '偶数
        TempVal = n / 2 + 1
    Else                '奇数
        TempVal = n * 2 - 1
    End If
    GetAscValue = TempVal
End Function

Private Function GetReversalSt(ArrayLen As Integer, ArraySt() As String * 1, SwitchType) As String
'*******************************
'Switch=1：形成正常的字串；
'Switch=2：把字串头尾颠倒相置，
'          形成新的字串
'*******************************
    Dim i As Integer
    Dim TempSt As String
    Dim Beg As Integer
    Dim Fin As Integer
    Dim StepLen As Integer
        
    Select Case SwitchType
        Case 1
            Beg = 1
            Fin = ArrayLen
            StepLen = 1
         Case 2
            Beg = ArrayLen
            Fin = 1
            StepLen = -1
    End Select
    
    For i = Beg To Fin Step StepLen
        TempSt = TempSt & ArraySt(i)
    Next
    GetReversalSt = TempSt
End Function

Public Function LimitedLen(ByVal ST As String, MaxLen As Integer, keyascii As Integer, Optional lSel As Long = 0) As Integer
'****************************
'一个中文字的长度为2
'限制输入文字的最大长度
'****************************
    Dim RealLen As Long
    RealLen = LenB(StrConv(ST, vbFromUnicode))
    If (RealLen >= MaxLen Or (RealLen = MaxLen - 1 And keyascii < 0)) _
        And keyascii <> 8 _
         And keyascii <> 13 And lSel = 0 Then
        LimitedLen = 0
    Else
        LimitedLen = keyascii
    End If
End Function

Public Function SelectedItemIndex(ByVal objImageCombo As ImageCombo, ByVal strText As String) As Integer
'===================================
'根据传来的字串,返回在ImageCombo框
'所在位置的Index值,没找到则返回0
'===================================
    Dim i As Integer
    Dim blnTemp As Long
    
    With objImageCombo
        For i = 1 To .ComboItems.count
            If strText = .ComboItems(i).Text Then
                .ComboItems(i).Selected = True
                blnTemp = True
                Exit For
            End If
        Next
    End With
    
    If blnTemp Then
        SelectedItemIndex = i
    Else
        SelectedItemIndex = 0
    End If
End Function

Public Sub InitDateCtrl(objDate As Object)
'===========================
'对DTPicker日期控件初始化
'其值等于当前日期
'===========================
    Dim i As Integer
    
    For i = 0 To objDate.count - 1
        objDate(i).Value = Format(VBA.Date, "yyyy-MM-dd")
    Next
End Sub

Public Function StrToZero(str) As Long
    If str = "" Then
        StrToZero = 0
    Else
        StrToZero = str
    End If
End Function

Public Function HighLightRow(MSFGRD As MSFlexGrid, Optional SelectedRow As Long = 1)
    '=====================
    '高亮度显示网格某一行
    '=====================
    On Error Resume Next
    With MSFGRD
        If SelectedRow = 1 Then
            If .Rows > .FixedRows Then
                .Row = .FixedRows
                .Col = .FixedCols
                .ColSel = .Cols - .FixedCols
            End If
        Else
            .Row = SelectedRow
            .Col = .FixedCols
            .ColSel = .Cols - .FixedCols
        End If
    End With
End Function

Function FieldCheck(ByVal rstCheck As ADODB.Recordset, ByVal strFieldName As String, ByVal strValue, ControlName As Control, Optional ChineseName = "") As Boolean  '记录集/字段名/值
'==============
'检查数据合法性
'==============
On Error GoTo Err_Handle
Dim strCaption As String
    If ChineseName = "" Then
        strCaption = ControlName.Tag
    Else
        strCaption = ChineseName
    End If

'    If VBA.Trim(strValue) = "" Then
'        If Not IfIn(32, rstCheck.Fields(strFieldName).Attributes) Then
'            MsgBox strCaption & "不能为空！", vbInformation + vbOKOnly
'            ControlName.SetFocus
'            Exit Function
'        End If
'    End If
    Select Case rstCheck(strFieldName).Type
        'char,varchar,text类型