xpcombo.ctl

智能排课系统:支持双数据库,以最简单的操作完成智能的排课,支持EXECL和报表输出与打印功能,关于排课的管理还有一些也许还没有实现,需要大家给出意见和建议,作品将在以后开发基于各种学校的都可以使用的

   End If
   JCombo.RemoveItem CInt(i) 'maybe adjust code to future VB version
   RaiseEvent Change
End Sub

'before removeing a combo item
Private Sub RemoveTagCode(Index As Long)
  Dim j As Long
  If TLim > 0 Then
     For Tix = Index To TLim
         j = Tix + 1
         TCods(Tix) = TCods(j)
     Next Tix
  End If
End Sub

'returns True/False and TCod/TTex vars
Private Function IsTagCode(Item As String) As Boolean
  Dim s As String
  Dim len_s As Long
  Dim C As Long ' resultant column
  s = Trim(Item) ' cut blanks
  len_s = Len(s)
  If len_s <> 0 Then 'sure significant value
     C = InStr(1, s, "=", vbTextCompare)
     If C = 1 Then ' "equal" sign at 1st column?
        s = Mid(s, 2, len_s - 1) ' cut it
        C = 0 ' as not found
     End If
     If C = len_s Then '"equal" sign is last character
        s = Mid(s, 1, len_s - 1) 'cut it
        C = 0 ' as not found
     End If
  Else
     C = 0 'as not found
  End If
  Item = s ' returns item as interpreted
  If C = 0 Then ' "equal" sign not found
     TCod = Item
     TTex = Item
     IsTagCode = False
  Else
     TCod = Trim(Mid(s, 1, C - 1))
     TTex = Trim(Mid(s, C + 1, len_s - C))
     IsTagCode = True
  End If
End Function

Private Sub PutItem(Item As String, Optional ByVal Index As Variant)
  Dim Col As Long
  Dim j As Long
    If m_TagCode = False Then
       If Len(Item) = 0 Then ' no null itens
          Exit Sub
       Else
          JCombo.AddItem Item, Index  ' normal additem
       End If
    Else
       Call IsTagCode(Item)
       If Len(Item) = 0 Then ' resulted in null itens
          Exit Sub
       Else
          If IsMissing(Index) Then
             JCombo.AddItem TTex 'appending
             Tix = JCombo.ListCount - 1
             If Not Tix > MaxTCods Then ' limited to 100 TagCode entries
                TCods(Tix) = TCod
                TLim = Tix
             End If
          Else
             JCombo.AddItem TTex, Index
             Tix = CLng(Index)
             If Tix < 0 Then
                Tix = 0
             End If
             If Tix > TLim Then
                Tix = TLim
             End If
             Col = Tix
             Tix = TLim
             Do While Tix > Col - 1
                j = Tix + 1
'if inserting TagCode above TagCode array limits then
'last TagCode will be lost to prevent overflow
                If Not j > MaxTCods Then
                   TCods(j) = TCods(Tix)
                End If
                Tix = Tix - 1
             Loop
             TCods(Col) = TCod
             TLim = TLim + 1
          End If
       End If
       If TLim > MaxTCods Then
          TLim = MaxTCods
       End If
    End If
    If IsMissing(Index) Then
       Tix = JCombo.ListCount - 1
    Else
       Tix = Val(Index)
    End If
End Sub

'Saves Combo contents to a Txt File as App.Path & "\" & .Name & ".TxT"
Public Sub SaveToFile()
  Dim FN As Integer
  Dim fNam As String
  Dim i As Long
  Dim s As String
  Dim t As String
  Dim u As String

' The filename would be initialized
  fNam = Trim(m_FileName)
  If Len(fNam) = 0 Then ' assumes anything
     fNam = App.Path & "\" & UserControl.Name & ".Txt"
  End If
  On Error GoTo Clo
  FN = FreeFile
  Open fNam For Output As #FN
  For i = 0 To JCombo.ListCount - 1
      If m_TagCode = False Then
         s = JCombo.List(i)
      Else
         If i > MaxTCods Then ' maximum TagCode array
            s = JCombo.List(i)
         Else
            t = TCods(i)
            u = JCombo.List(i)
            s = t & "=" & u
         End If
      End If
      Print #FN, s
  Next i
Clo:
  Close FN
End Sub

'Load Combo Itens from a Txt File as App.Path & "\" & .Name & ".TxT"
'Initializes the Combo and Sets/Resets TagCode flag by looking for a "=" anywere on text
'First line char = ";" this is a remark line
'
Public Function LoadedFromFile() As Boolean
  Dim FN As Integer
  Dim fNam As String
  Dim Cnt As Long
  Dim Col As Long
  Dim s As String
  
  m_Buf = ""
' The filename would be initialized
  fNam = Trim(m_FileName)
  If Len(fNam) = 0 Then ' assumes anything
     fNam = App.Path & "\" & UserControl.Name & ".Txt"
  End If
  On Error GoTo R_Error
  FN = FreeFile
  Open fNam For Input As #FN
  m_Buf = Input(LOF(FN), #FN)
  Close FN
  If Len(m_Buf) = 0 Then ' not empty file
     LoadedFromFile = False
     Exit Function
  End If
  
  Cnt = 0 'first line
  s = ""
  Do While Len(s) < 2 ' Ignores non-significant first lines
     s = A_line_of_Buf(Cnt)
     If Cnt = 0 Then
        LoadedFromFile = False
        Exit Function
     End If
  Loop
'Ok, we have at least 1 line : we empty the combo and prepare to load
  JCombo.Clear
  If IsTagCode(s) Then ' if at least a "=" character in 1st line
     m_TagCode = True
  Else
     m_TagCode = False
  End If
  PutItem s
' continue loading
  s = ""
  Do While Cnt > 0
     s = A_line_of_Buf(Cnt)
     If Cnt = 0 Then
        LoadedFromFile = True
        Exit Function
     End If
     If s <> ";" Then
        If Len(Trim(s)) <> 0 Then
           PutItem s
        End If
     End If
  Loop
  LoadedFromFile = True 'only for bug security
  Exit Function
R_Error:
  LoadedFromFile = False
End Function

'its a preference against use Split function (maybe a very strong one)
'initializes with LineNumber = 0
'no more lines returns LineNumber = 0
'maximum line lenght = 80 characteres
'first char ";" returns only the character ";"
Private Function A_line_of_Buf(LineNumber As Long) As String
  Dim j As Long
  Dim Cnt As Long
  Dim lia As String
  Cnt = LineNumber
  If Cnt = 0 Then 'eliminates char(10) 0AH
     lia = Replace(m_Buf, vbLf, "")
     m_Buf = lia
     If Not Mid(m_Buf, Len(m_Buf), 1) = vbCr Then
        m_Buf = m_Buf & vbCr 'asseveres last caracter
     End If
  End If
  lia = "" 'empty
  j = InStr(m_Buf, vbCr)
  If j = 0 Then
     If Len(m_Buf) = 0 Then
        Cnt = 0
     End If
  Else
     Cnt = Cnt + 1
     lia = Mid(m_Buf, 1, j - 1)
     m_Buf = Mid(m_Buf, 2, Len(m_Buf) - 1) 'eliminates first char
     If Len(m_Buf) = Len(lia) Then
        m_Buf = "" 'all empty
     Else
        m_Buf = Mid(m_Buf, Len(lia) + 1, Len(m_Buf) - Len(lia))
     End If
     If Len(lia) > 0 Then
        If Mid(lia, 1, 1) = ";" Then
           lia = ";"
        End If
     End If
  End If
  If Len(lia) > 80 Then 'security line limit
     lia = Mid(lia, 1, 80)
  End If
  LineNumber = j
  A_line_of_Buf = lia
End Function

'Returns actual index TagCode
Public Function GetTagCode() As String
    TCod = ""
    If JCombo.ListIndex > -1 Then
       If m_TagCode = True Then
          If Not JCombo.ListIndex > MaxTCods Then
             TCod = TCods(JCombo.ListIndex)
          End If
       End If
    End If
    GetTagCode = TCod
End Function

'Shows item corresponding TagCode received and returns True
'or Shows blanc item and returns False
Public Function SetTagCode(TgCode As String, StartingFromIndex As Long) As Boolean
  Dim b As Boolean
  Dim i As Long
  Dim lim As Long
  Dim Col As Long
  i = StartingFromIndex
  
  If JCombo.ListCount - 1 > MaxTCods Then ' if exceeds arrays limit
     lim = MaxTCods
  Else
     lim = JCombo.ListCount - 1
  End If
  
  If i > lim Then 'accidental overflow prevent
     i = 0
  End If
    
  TCod = UCase(Trim(TgCode))
  b = False
  If Not Len(TCod) = 0 Then
     For Col = i To lim
         If UCase(TCods(Col)) = TCod Then
            b = True
            Exit For
         End If
     Next Col
  End If
  If b = True Then
     JCombo.ListIndex() = Col
     JTexto.Text = JCombo.Text
     Col = Col + 1
     If Col > lim Then
        Col = 0
     End If
     StartingFromIndex = Col ' returns sucess index
  Else
     JCombo.ListIndex() = -1
     JTexto.Text = ""
  End If
  SetTagCode = b
  RaiseEvent Change
End Function

Public Property Get BackColor() As OLE_COLOR
    BackColor = JTexto.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    JTexto.BackColor() = New_BackColor
    BackMain.BackColor = New_BackColor
    PropertyChanged "BackColor"
End Property

Public Sub Clear()
    JCombo.Clear
    TLim = 0 ' TagCode array will be empty
End Sub

Public Property Get Font() As Font
    Set Font = JTexto.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set JTexto.Font = New_Font
    RePos
    PropertyChanged "Font"
End Property

Public Property Get ForeColor() As OLE_COLOR
    ForeColor = JTexto.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    JTexto.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

Public Property Get hWnd() As Long
    hWnd = UserControl.hWnd
End Property

Public Property Get ListIndex() As Integer
    ListIndex = JCombo.ListIndex
End Property

Public Property Let ListIndex(ByVal New_ListIndex As Integer)
    JCombo.ListIndex() = New_ListIndex
    If JCombo.ListIndex > -1 Then
       JTexto.Text = JCombo.Text
       If m_TagCode = True Then
          If Not JCombo.ListIndex > MaxTCods Then
             TCod = TCods(JCombo.ListIndex)
          End If
       Else
          TCod = ""
       End If
    End If
    PropertyChanged "ListIndex"
End Property

Public Property Get ListCount() As Integer
    ListCount = JCombo.ListCount
End Property

Public Property Get Locked() As Boolean
    Locked = JTexto.Locked
End Property

Public Property Let Locked(ByVal New_Locked As Boolean)
    JTexto.Locked() = New_Locked
    PropertyChanged "Locked"
End Property

Public Property Get MaxLength() As Long
    MaxLength = JTexto.MaxLength
End Property

Public Property Let MaxLength(ByVal New_MaxLength As Long)
    JTexto.MaxLength() = New_MaxLength
    PropertyChanged "MaxLength"
End Property

Private Sub JTexto_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Public Property Get ToolTipText() As String
    ToolTipText = JTexto.ToolTipText
End Property

Public Property Let ToolTipText(ByVal New_ToolTipText As String)
    JTexto.ToolTipText() = New_ToolTipText
    PropertyChanged "ToolTipText"
End Property

Public Property Get FieldName() As String
    FieldName = JTexto.DataField
End Property

Public Property Let FieldName(ByVal New_FieldName As String)
    JTexto.DataField() = New_FieldName
    PropertyChanged "FieldName"
End Property

Public Property Get SelStart() As Long
    SelStart = JTexto.SelStart
End Property

Public Property Get SelLength() As Long
    SelLength = JTexto.SelLength
End Property

Public Property Get SelText() As Long
    SelText = JTexto.SelText
End Property

Public Property Get TagCode() As Boolean
    TagCode = m_TagCode
End Property

Public Property Let TagCode(ByVal New_TagCode As Boolean)
    m_TagCode = New_TagCode
    PropertyChanged "TagCode"
End Property

Public Property Get Enabled() As Boolean
    Enabled = m_Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    PropertyChanged "Enabled"
    JTexto.Enabled = New_Enabled
    If New_Enabled = False Then
        JImgCbo.Picture = Img(3).Picture
        ShapeBorder.BorderColor = &HC0C0C0
    Else
        ResetPic
        ShapeBorder.BorderColor = &HB99D7F
    End If
    
End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_Enabled = m_def_Enabled
    m_TagCode = False
    m_FileName = ""
End Sub