xpmccombo.ctl

进销存管理系统,我是个新手,请大家多多帮助哈1

Public Property Let Text_Enabled(ByVal Text_New_Enabled As Boolean)
    Text1.Enabled() = Text_New_Enabled
    PropertyChanged "Text_Enabled"
End Property

Public Property Get Text_Locked() As Boolean
    Text_Locked = Text1.Locked
End Property
Public Property Let Text_Locked(ByVal Text_New_Locked As Boolean)
    Text1.Locked() = Text_New_Locked
    PropertyChanged "Text_Locked"
End Property
Public Property Get NrColVisible() As Long
    NrColVisible = m_NrColVisible
End Property

Public Property Let NrColVisible(New_NrColVisible As Long)
    m_NrColVisible = New_NrColVisible
    PropertyChanged "NrColVisible"
End Property
Public Property Get ListHeight() As Long
    ListHeight = m_ListHeight
End Property
Public Property Let ListHeight(New_ListHeight As Long)
    m_ListHeight = New_ListHeight
    PropertyChanged "ListHeight"
End Property
Public Property Get ListWidth() As String
    ListWidth = m_ListWidth
End Property
Public Property Let ListWidth(New_ListWidth As String)
    m_ListWidth = New_ListWidth
    PropertyChanged "ListWidth"
End Property
Public Property Get BoundColumns() As String
    BoundColumns = m_BoundColumns
End Property
Public Property Let BoundColumns(New_BoundColumns As String)
    m_BoundColumns = New_BoundColumns
    PropertyChanged "BoundColumns"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,DropListEnabled
Public Property Get DropListEnabled() As Boolean
    DropListEnabled = m_DropListEnabled
End Property

Public Property Let DropListEnabled(ByVal New_DropListEnabled As Boolean)
    m_DropListEnabled = New_DropListEnabled
    
    PropertyChanged "DropListEnabled"
End Property


Public Property Get bgBottomColor() As OLE_COLOR

    bgBottomColor = m_oStartColor

End Property

Public Property Let bgBottomColor(ByVal oColor As OLE_COLOR)

  Dim lcolor As Long

    If (m_oStartColor <> oColor) Then
        m_oStartColor = oColor
        DrawControl
    End If
    
End Property

Public Property Get bgTopColor() As OLE_COLOR

    bgTopColor = m_oEndColor

End Property

Public Property Let bgTopColor(ByVal oColor As OLE_COLOR)

  Dim lcolor As Long

    If (m_oEndColor <> oColor) Then
        m_oEndColor = oColor
        DrawControl
    End If

End Property

Public Property Get Style() As pbcStyle

    Style = m_Style

End Property

Public Property Let Style(ByVal New_Style As pbcStyle)

    m_Style = New_Style
    PropertyChanged "Style"
    DrawControl

End Property

Public Property Get FocusColor() As OLE_COLOR

    FocusColor = m_FocusColor

End Property

Public Property Let FocusColor(ByVal New_FocusColor As OLE_COLOR)

    m_FocusColor = New_FocusColor
    PropertyChanged "FocusColor"
    DrawControl

End Property

Public Property Get ButtonFadeColor() As OLE_COLOR

    ButtonFadeColor = m_ButtonFadeColor

End Property

Public Property Let ButtonFadeColor(ByVal New_ButtonFadeColor As OLE_COLOR)

    m_ButtonFadeColor = New_ButtonFadeColor
    PropertyChanged "ButtonFadeColor"

End Property

Private Sub FadeColor(oColor As Long, rct As RECT, obcolor As Long)

  Dim plWidth As Long
  Dim lFlags As Long
  Dim dR(1 To 3) As Double
  Dim lHeight As Long, lWidth As Long
  Dim lYStep As Long
  Dim lY As Long
  Dim bRGB(1 To 3) As Integer
  Dim hBr As Long
  Dim m_RGBStartCol1(1 To 3) As Long
  Dim m_RGBEndCol1(1 To 3) As Long
  Dim lcolor As Long

    OleTranslateColor oColor, 0, lcolor
    m_RGBStartCol1(1) = lcolor And &HFF&
    m_RGBStartCol1(2) = ((lcolor And &HFF00&) \ &H100)
    m_RGBStartCol1(3) = ((lcolor And &HFF0000) \ &H10000)
    
    OleTranslateColor obcolor, 0, lcolor
    m_RGBEndCol1(1) = lcolor And &HFF&
    m_RGBEndCol1(2) = ((lcolor And &HFF00&) \ &H100)
    m_RGBEndCol1(3) = ((lcolor And &HFF0000) \ &H10000)
    lHeight = ScaleHeight
      
    lYStep = lHeight \ 255
    If (lYStep = 0) Then
        lYStep = 1
    End If
    bRGB(1) = m_RGBStartCol1(1)
    bRGB(2) = m_RGBStartCol1(2)
    bRGB(3) = m_RGBStartCol1(3)
    dR(1) = m_RGBEndCol1(1) - m_RGBStartCol1(1)
    dR(2) = m_RGBEndCol1(2) - m_RGBStartCol1(2)
    dR(3) = m_RGBEndCol1(3) - m_RGBStartCol1(3)

    For lY = lHeight To 0 Step -lYStep
        rct.Top = rct.Bottom - lYStep
        hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
        FillRect hdc, rct, hBr
        DeleteObject hBr
        rct.Bottom = rct.Top
        bRGB(1) = m_RGBStartCol1(1) + dR(1) * (lHeight - lY) / lHeight
        bRGB(2) = m_RGBStartCol1(2) + dR(2) * (lHeight - lY) / lHeight
        bRGB(3) = m_RGBStartCol1(3) + dR(3) * (lHeight - lY) / lHeight
    Next lY

End Sub


Public Sub load_rs_to_lsw(ByVal lswcbo_rs As Recordset)
    Dim vbook
    Dim chk_book As Boolean
    Dim rs_opened As Boolean
    Dim col_length As Integer
    Dim itemx
    Dim i As Integer
    Dim col_turn As Integer
    Dim intCount As Integer
    
     If lswcbo_rs.state = 0 Then
            rs_opened = True
            lswcbo_rs.Open
     Else
            rs_opened = False
            
     End If
     
    '-------------------------------------------------
    '# Deal Users input worng numbers of Bounding Columns
        
        'Clear 0,numbers of Bounding Columns
        NumBounds = 0
        'Calculate how many Fields in Recordset
        intCount = lswcbo_rs.Fields.Count
        
  
        Dim lWid() As Long
        Dim substr() As String
        Dim SubStrCount As Integer
        SubStrCount = 0
        ReDim substr(0 To 10) As String
        SubStrCount = DespartireSTR(substr(), m_ListWidth, ";")
        
        Dim strsplit() As String
        Dim StrBoundColumns As Integer
        StrBoundColumns = 0
        ReDim strsplit(0 To 10) As String
        StrBoundColumns = DespartireSTR(strsplit(), m_BoundColumns, ";")
      
        Dim m As Integer
        Dim intsplit() As Integer
        ReDim intsplit(0 To 10) As Integer
                 
   '# Check whether user set visible bounding columns are
   '  over total fields (XPMCCombo1.NrColVisible = 4 but intCount is
   '  only 3)
    If m_NrColVisible > 0 Then
     If m_NrColVisible >= intCount Then
     NumBounds = intCount
     Else
     NumBounds = m_NrColVisible
     End If
    Else
     NumBounds = 1
    End If
    
   '# Check whether user set visible bounding columns are
   '  over total fields (XPMCCombo1.ListWidth = "200;1800;1000;1000",StrBoundColumns=4
   '  but intCount has only 3,intCount=3)
    If StrBoundColumns > 0 Then
        If StrBoundColumns >= intCount Then
           StrBoundColumns = intCount
        End If
    Else
        StrBoundColumns = 1
    End If
    
   '# converter string to interger
    For m = 1 To StrBoundColumns
        intsplit(m) = CInt(Val(strsplit(m)))
       '# Override the fault when user input illegal setting
       '  such as XPMCCombo1.BoundColumns = "2;0;4;" but total fields only
       '  have 3(that is:intcount=3)
        If intsplit(m) > intCount Then intsplit(m) = intCount
    Next m
        
    
    If NumBounds >= StrBoundColumns Then
        NumBounds = StrBoundColumns
    End If
             
        Dim iCt As Integer
        iCt = NumBounds - 1
        
        ReDim lWid(0 To iCt)
        lTotalWid = 0
        For i = 1 To iCt
                
                lWid(i) = Val(substr(i + 1))
                lTotalWid = lTotalWid + lWid(i)
               
        Next
                lTotalWid = lTotalWid + IniLung - 290
  '-------------------------------------------------
    With lswcbo_rs
        
        If check_bookmarkable(lswcbo_rs) = True Then
            chk_book = True
            vbook = .Bookmark
        Else
            chk_book = False
        End If
        
        
                
        frmpopup.lsw.ColumnHeaders.Clear
        
        '# no Records ?
        If NoOfRecs(lswcbo_rs) = 0 Then
          For i = 0 To iCt
            If i <> 0 Then
             frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(i + 1)).Name, lWid(i)
                
            Else
            '# First Column
             frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(1)).Name, IniLung - 290
            
            End If
        Next
       
         '# Compensate Listview width
        lTotalWid = lTotalWid - NumBounds * 80
        If rs_opened = True Then .Close
        
            Exit Sub
            
        End If
        
        If NoOfRecs(lswcbo_rs) <= 13 And NoOfRecs(lswcbo_rs) > 0 Then
          '# Based on Default m_ListHeight=3070 and 800x600 pixes,about 13 Rows.
          '# Compensate and adjust Listview width
           lTotalWid = lTotalWid - NumBounds * 80
        ElseIf NoOfRecs(lswcbo_rs) > 13 Then lTotalWid = lTotalWid
        
        End If
         
         
        For i = 0 To iCt
            If i <> 0 Then
             frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(i + 1)).Name, lWid(i)
                
            Else
            '# First Column
             frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(1)).Name, IniLung - 290
            
            End If
        Next
        
        frmpopup.lsw.ListItems.Clear
        
        .MoveFirst
        Do Until .EOF
            
              Set itemx = frmpopup.lsw.ListItems.Add(, , .Fields(intsplit(1)))
                If iCt > 0 Then
                   Dim h As Integer

                    For h = 1 To iCt
                    itemx.SubItems(h) = .Fields(intsplit(h + 1))
                    Next
                    
                End If
                
            .MoveNext
        Loop
       
        '---------------------------------------------------
        If chk_book = True Then .Bookmark = vbook
        If rs_opened = True Then .Close
        '---------------------------------------------------
        End With
    
End Sub
Private Function DespartireSTR(SubStrs() As String, ByVal SrcStr As String, _
   ByVal Delimiter As String) As Integer
      ReDim SubStrs(0) As String
      Dim CurPos As Long
      Dim NextPos As Long
      Dim DelLen As Integer
      Dim nCount As Integer
      Dim TStr As String
      CurPos = 0
      NextPos = 0
      DelLen = 0
      nCount = 0
      TStr = ""
      SrcStr = Delimiter & SrcStr & Delimiter
      DelLen = Len(Delimiter)
      nCount = 0
      CurPos = 1
      NextPos = InStr(CurPos + DelLen, SrcStr, Delimiter)
      Do Until NextPos = 0
         TStr = Mid$(SrcStr, CurPos + DelLen, NextPos - CurPos - DelLen)
         nCount = nCount + 1
         ReDim Preserve SubStrs(nCount) As String
         SubStrs(nCount) = TStr
         CurPos = NextPos
         NextPos = InStr(CurPos + DelLen, SrcStr, Delimiter)
      Loop

      DespartireSTR = nCount
      
   End Function
Private Function check_bookmarkable(chk_rs As Recordset) As Boolean
    If chk_rs.EOF = True Or chk_rs.BOF = True Then check_bookmarkable = False Else check_bookmarkable = True
End Function
Private Function NoOfRecs(Rs As ADODB.Recordset) As Integer
On Error GoTo NoOfRecs_Err
    If Rs Is Nothing Then
        NoOfRecs = 0
    Else
        NoOfRecs = Rs.RecordCount
    End If
NoOfRecs_Exit:
    Exit Function
NoOfRecs_Err:
    MsgBox Err.Description, vbCritical, "NoOfRecs"
    Resume NoOfRecs_Exit
End Function