mdlfunction.bas

朋友给的

    On Error GoTo Err_Handle
    With frm
        For i = 0 To .Controls.count - 1
'            .Controls(i).Enabled = True
            If .Controls(i).DataField <> "" Then
                Select Case TypeName(.Controls(i))
                Case "TextBox", "ComboBox"
                    .Controls(i).MaxLength = rstMain(.Controls(i).DataField).DefinedSize
                End Select
            End If
Next_Control:
        Next i
    End With
    
    If rstMain.State = adStateOpen Then rstMain.Close
    Set rstMain = Nothing
    
    Exit Sub
Err_Handle:
    Resume Next_Control
End Sub

Public Function FillText(frm As Form, cn As ADODB.Connection, strsql As String)
'================================================
'函数说明:并初始化各变量
'返回值:没有返回值
'================================================
    Dim rstMain As New ADODB.Recordset
    
    rstMain.Open strsql, cn, adOpenStatic, adLockReadOnly
    If rstMain.EOF Then Exit Function
    
    Dim i, j As Long
    Dim b() As Byte
    
    On Error GoTo Err_Handle
    With frm
        For i = 0 To .Controls.count - 1
'            .Controls(i).Enabled = True
            If .Controls(i).DataField <> "" Then
                Select Case TypeName(.Controls(i))
                Case "TextBox", "ComboBox"
                    .Controls(i).Text = rstMain(.Controls(i).DataField).Value & ""
'                    .Controls(i).MaxLength = rstMain(.Controls(i).DataField).DefinedSize
                Case "ImageCombo"
                    If .Controls(i).Tag <> TAG_SELECT Then
                        If rstMain(.Controls(i).DataField).Value & "" <> "" Then
                            .Controls(i).ComboItems(KEY_FIRSTCHAR & rstMain(.Controls(i).DataField).Value & "").Selected = True
                        Else
                            .Controls(i).Text = ""
                        End If
                    End If
                Case "DTPicker"
                    .Controls(i).Value = rstMain(.Controls(i).DataField).Value & ""
                Case "OptionButton"
                    .Controls(i).Value = rstMain(.Controls(i).DataField).Value & ""
                Case "Image"
                    b = rstMain(.Controls(i).DataField).GetChunk(rstMain(.Controls(i).DataField).ActualSize)
                    j = FreeFile
                    Open "pictemp" For Binary Access Write As #j
                    Put #j, , b
                    Close #j
                     .Controls(i).Picture = LoadPicture("pictemp")
                    Kill "pictemp"
                End Select
            End If
Next_Control:
        Next i
    End With
    
    If rstMain.State = adStateOpen Then rstMain.Close
    Set rstMain = Nothing
    
    Exit Function
Err_Handle:
'    If Err.Number = 438 Then '438错误为无效属性,当控件不存在datafield属性时则从下一个控件开始.
        Resume Next_Control
'    Else
'        ErrMessage
'    End If
End Function

Public Function ClearText(frm As Form)
'================================================
'函数说明:将编辑状态设定为添加状态,并初始化各变量(清空各项)。
'返回值:没有返回值
'================================================
    Dim i As Long
    With frm
        For i = 0 To .Controls.count - 1
            Select Case TypeName(.Controls(i))
            Case "TextBox", "ComboBox"
                .Controls(i).Text = ""
            Case "ImageCombo"
                If .Controls(i).Tag <> TAG_SELECT Then
                    .Controls(i).Text = ""
                End If
            Case "DTPicker"
                .Controls(i).Value = Date
            End Select
        Next i
    End With
End Function

Sub FillListView(lvS As ListView, sql As String, useFirstRecord As Boolean, Optional Icon As Integer, Optional SmallIcon As Integer, Optional ShowKeyField As Long = 0)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
'用一个记录集填入ListView
'UseFirstRecord    true  只填第一条记录，竖向排列
'                  false 所有记录
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    
    Dim rstx As New ADODB.Recordset
    Dim i As Integer, lRec As Long
    Screen.MousePointer = vbHourglass
    lvS.ListItems.Clear
    lvS.Sorted = False
    
    rstx.CursorType = adOpenStatic
    rstx.LockType = adLockReadOnly
    rstx.CursorLocation = adUseClient   '加上这一句
    rstx.Open sql, gCnn, , , adCmdText
    
    If useFirstRecord = True Then
        '修改列头
        For i = 3 To lvS.ColumnHeaders.count
            lvS.ColumnHeaders.Remove 3
        Next i
        For i = lvS.ColumnHeaders.count + 1 To 2
            lvS.ColumnHeaders.Add
        Next i
        lvS.ColumnHeaders(0).Text = "信息"
        lvS.ColumnHeaders(0).Width = lvS.Width * 0.3
        lvS.ColumnHeaders(1).Text = "值"
        lvS.ColumnHeaders(1).Width = lvS.Width * 0.7
    
        If rstx.RecordCount <> 0 Then
            rstx.MoveFirst
            For i = 0 To rstx.Fields.count - 1
                lvS.ListItems.Add , , rstx.Fields(i).name, Icon, SmallIcon
                lvS.ListItems(i + 1).ListSubItems.Add , , IIf(IsNull(rstx.Fields(i).Value), "", rstx.Fields(i).Value)
            Next i
        End If
    Else
        '修改列头
        Dim lC As Long
        If ShowKeyField = 2 Then
            lC = -1
        Else
            lC = 0
        End If
        For i = rstx.Fields.count + 1 + lC To lvS.ColumnHeaders.count
            lvS.ColumnHeaders.Remove rstx.Fields.count + 1 + lC
        Next i
        For i = lvS.ColumnHeaders.count + 1 To rstx.Fields.count + lC
            lvS.ColumnHeaders.Add
        Next i
        For i = 1 - lC To rstx.Fields.count
            lvS.ColumnHeaders(i + lC).Text = rstx.Fields(i - 1).name
            If i - 1 > 1 Then
                Select Case rstx.Fields(i - 1).Type
                    Case adDate, adDBDate, adDBTime, adDBTimeStamp
                        '居中对齐
                        lvS.ColumnHeaders(i - 1).Alignment = lvwColumnCenter
                    Case adCurrency, adDecimal, adDouble, adInteger, adNumeric, adSingle, adSmallInt, adTinyInt, adUnsignedBigInt, adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt
                        '左对齐
                        lvS.ColumnHeaders(i - 1).Alignment = lvwColumnRight
                    Case Else
                        lvS.ColumnHeaders(i - 1).Alignment = lvwColumnLeft
                End Select
            End If
        Next i
        If rstx.RecordCount <> 0 Then
            rstx.MoveFirst
            While Not rstx.EOF
                If ShowKeyField = 1 Then
                    lvS.ListItems.Add , "a" & rstx(0), IIf(IsNull(rstx.Fields(0).Value), "", rstx.Fields(0).Value), Icon, SmallIcon
                    For i = 1 To rstx.Fields.count - 1
                        lvS.ListItems("a" & rstx(0)).ListSubItems.Add , , IIf(IsNull(rstx.Fields(i)), "", rstx.Fields(i))
                    Next i
                ElseIf ShowKeyField = 2 Then
                    lvS.ListItems.Add , "a" & rstx(0), IIf(IsNull(rstx.Fields(1).Value), "", rstx.Fields(1).Value), Icon, SmallIcon
                    
                    For i = 2 To rstx.Fields.count - 1
                        lvS.ListItems("a" & rstx(0)).ListSubItems.Add , , IIf(IsNull(rstx.Fields(i)), "", rstx.Fields(i))
                    Next i
                Else
                    lvS.ListItems.Add , , IIf(IsNull(rstx.Fields(0).Value), "", rstx.Fields(0).Value), Icon, SmallIcon
                    For i = 1 To rstx.Fields.count - 1
                        lvS.ListItems(lvS.ListItems.count).ListSubItems.Add , , IIf(IsNull(rstx.Fields(i)), "", rstx.Fields(i))
'                        Debug.Print rstx.Fields(i)
                    Next i
                End If
                rstx.MoveNext
            Wend
        End If
        If lvS.Sorted = True Then
'            lvS.ColumnHeaders(1).Icon = 1
            lvS.SortOrder = lvwAscending
        End If
    End If
    rstx.Close
    lvS.Refresh
    lvS.Sorted = True
    AdjustListViewWidth lvS
    Screen.MousePointer = vbDefault
End Sub

Public Sub AdjustListViewWidth(msfResult As ListView, Optional iStartRow As Long = 1)
    '自动调整网格宽度
    Screen.MousePointer = 11
    Dim i As Long, j As Long
    Dim strTemp As String, lTemp As Long
    Dim lColWidth As Long
    With msfResult
        lColWidth = (.ColumnHeaders(1).Width - 500) / .Font.Size / 10
        lTemp = 0
        strTemp = ""
        For i = iStartRow To .ListItems.count
            strTemp = .ListItems(i).Text
            lTemp = RealLength(strTemp)
            If lTemp > lColWidth Then
                lColWidth = lTemp
            End If
        Next i
        If lColWidth > 0 And .ColumnHeaders(1).Width > 0 Then
            .ColumnHeaders(1).Width = lColWidth * .Font.Size * 10 + 500
        Else
            .ColumnHeaders(1).Width = 0
        End If
        
        For j = 2 To .ColumnHeaders.count
            lColWidth = (.ColumnHeaders(j).Width - 90) / .Font.Size / 10
            lTemp = 0
            strTemp = ""
            For i = iStartRow To .ListItems.count
                strTemp = .ListItems(i).SubItems(j - 1)
                lTemp = RealLength(strTemp)
                If lTemp > lColWidth Then
                    lColWidth = lTemp
                End If
            Next i
            If lColWidth > 0 And .ColumnHeaders(j).Width > 0 Then
                .ColumnHeaders(j).Width = lColWidth * .Font.Size * 10 + 90
            Else
                .ColumnHeaders(j).Width = 0
            End If
        Next j
    End With
    Screen.MousePointer = 0
End Sub

Sub FillChildNode(TVS As MSComctlLib.TreeView, Node As MSComctlLib.Node, sql As String, Optional KeyFieldColumn As Integer = 0, Optional TextFieldColumn As Integer = 1, Optional Image As Integer, Optional SelectedImage As Integer)
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
'Node   父结点
'sql    SQL语句
'KeyFieldColumn   SQL语句中KEY的列
'TextFieldColumn  SQL语句中TEXT的列
'Image,SelectedImage  Nodes.Add中的参数
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/

    Dim rstx As ADODB.Recordset
    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
            TVS.Nodes.Add Node.Key, tvwChild, Chr(Asc(Left(Node.Key, 1)) + 1) & Right(Node.Key, Len(Node.Key) - 1) & Chr(6) & rstx.Fields(KeyFieldColumn), rstx.Fields(TextFieldColumn), Image, SelectedImage
            rstx.MoveNext
        Wend
    End If
    rstx.Close

End Sub

Sub DelNodes(tv As TreeView, tvNode As MSComctlLib.Node, Optional lDeepth As Long = 3)
    'tvNode 当前结点
    '把第 lDeepth 层的没有子接点的接点都删除
    Dim nF As MSComctlLib.Node, nN As MSComctlLib.Node
    Dim i As Long
    If lDeepth = 0 Then Exit Sub
    If tvNode.Children > 0 Then
        
        Set nF = tvNode.Child
        For i = 1 To tvNode.Children
            Set nN = nF.Next
            DelNodes tv, nF, lDeepth - 1
            Set nF = nN
        Next i
    End If
    If tvNode.Children = 0 And tvNode.Key <> tv.Nodes(1).Key Then
        tv.Nodes.Remove tvNode.Index
    End If
End Sub

Function GetKey(Node As MSComctlLib.Node) As String
    If Node.Root.Key = Node.Key Then
        GetKey = Right(Node.Key, Len(Node.Key) - 1)
    Else
        GetKey = Right(Node.Key, Len(Node.Key) - Len(Node.Parent.Key) - 1)
    End If
End Function

Public Function NulltoZero(m_string As Variant) As String
   If IsNull(m_string) Then
      NulltoZero = "0"
   Else
      NulltoZero = str(m_string)
   End If
End Function

Public Function NulltoStr(m_string As Variant) As String
   If IsNull(m_string) Then
      NulltoStr = ""
   Else
      NulltoStr = m_string
   End If
End Function

Public Function BooleanToString(Bool As Boolean) As String
  BooleanToString = "否"
  If Bool = True Then
   BooleanToString = "是"
  ElseIf Bool = False Then
   BooleanToString = "否"
  End If
End Function