frmlistset.frm

金算盘软件代码

        Else
            If mclsListSet.FixColumns <= index Then
                lstAll.AddItem .Text
                lstAll.Text = .Text
                .RemoveItem index
            Else
                MsgBox "“" & strText & "”是固定栏目！", vbOKOnly, Me.Caption
            End If
        End If

        If .ListCount > 0 Then
            .ListIndex = IIf(index < .ListCount, index, .ListCount - 1)
        End If
    End With
    RefreshButton
    RefreshUpDown
End Sub

Private Sub cmdRightAll_Click()
    Dim i As Integer
    Dim Count As Integer

    With lstAll
        Count = .ListCount
        For i = 0 To Count - 1
            lstSelected.AddItem .list(0)
            .RemoveItem 0
        Next
        lstSelected.ListIndex = 0
    End With
    RefreshButton
    RefreshUpDown
End Sub

Private Sub cmdRightOne_Click()
    Dim index As Integer

    With lstAll
        index = .ListIndex
        lstSelected.AddItem .Text
        lstSelected.Text = .Text
        .RemoveItem index
        If .ListCount > 0 Then
            .ListIndex = IIf(index < .ListCount, index, .ListCount - 1)
        End If
    End With
    RefreshButton
    RefreshUpDown
End Sub

Private Sub cmdSerial_Click(index As Integer)
    Dim strTemp As String

    With lstSelected
        Select Case index
            Case 0
                strTemp = .list(.ListIndex)
                .list(.ListIndex) = .list(.ListIndex - 1)
                .list(.ListIndex - 1) = strTemp
                .ListIndex = .ListIndex - 1
            Case 1
                strTemp = .list(.ListIndex)
                .list(.ListIndex) = .list(.ListIndex + 1)
                .list(.ListIndex + 1) = strTemp
                .ListIndex = .ListIndex + 1
        End Select
    End With
End Sub

Private Sub Form_Load()
    frmMain.Enabled = False
    SetHelpID 10008
    txtName.Enabled = False
    RefreshButton
    Set Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    frmMain.Enabled = True
    mblnNameChange = False
    mblnNotRespond = False
    mblnLoad = False
    Utility.RemoveFormResPicture 139
    Set Me.Icon = Nothing
End Sub

Private Sub lstAll_DblClick()
    cmdRightOne_Click
    RefreshButton
    RefreshUpDown
End Sub

Private Sub lstAll_GotFocus()
    RefreshButton
    RefreshUpDown
End Sub

Private Sub lstSelected_Click()
    If mblnNotRespond Then
        Exit Sub
    End If
    mblnNotRespond = True
    EditName
    If lstSelected.ListIndex = -1 Then
        Exit Sub
    End If
    cmbOrder.ListIndex = GetNoXString(GetNoXString(lstSelected.Text, 2, Space(100)), 3, "~")
    txtName = GetNoXString(lstSelected.Text, 1, Space(100))
    If Trim(txtName) <> "" And Not txtName.Enabled Then
        txtName.Enabled = True
    End If
    mblnNameChange = False
'********************************************
'ozj make it as following on 1999-12-28
    RefreshButton
'*********************************************
    RefreshUpDown
    mintLastIndex = lstSelected.ListIndex
    mblnNotRespond = False
End Sub

Private Function EditName() As Boolean
  Dim strNew As String, strErr As String, strList As String
  Dim intCount As Integer
  
   If Me.ActiveControl Is cmdCancel Or txtName.Enabled = False Or Not mblnNameChange Then
      EditName = True
      Exit Function
   End If
   EditName = False
   mblnNotRespond = True
   If Report.NameIsErr(txtName.Text, strErr) Then
       Utility.ShowMsg Me.hWnd, "栏目名称中包含非法字符“" & strErr & "”!", vbOKOnly, App.title
       txtName.SetFocus
       lstSelected.ListIndex = mintLastIndex
       Exit Function
   End If
   
   If Trim(txtName.Text) = "" Then
       ShowMsg Me.hWnd, "栏目名称不能为空!", vbOKOnly, App.title
       txtName.SetFocus
       lstSelected.ListIndex = mintLastIndex
       Exit Function
   End If
   
   For intCount = 0 To lstSelected.ListCount - 1
       If intCount <> mintLastIndex Then
            strList = GetNoXString(lstSelected.list(intCount), 1, Space(100))
            If UCase(Trim(txtName.Text)) = UCase(Trim(strList)) Then
                ShowMsg Me.hWnd, "栏目名称重复，请重新录入!", vbOKOnly, App.title
                txtName.SetFocus
                lstSelected.ListIndex = mintLastIndex
                Exit Function
            End If
       End If
   Next intCount
   
   For intCount = 0 To lstAll.ListCount - 1
        strList = GetNoXString(lstAll.list(intCount), 1, Space(100))
        If UCase(Trim(txtName.Text)) = UCase(Trim(strList)) Then
            ShowMsg Me.hWnd, "栏目名称重复，请重新录入!", vbOKOnly, App.title
            txtName.SetFocus
            lstSelected.ListIndex = mintLastIndex
            Exit Function
        End If
   Next intCount
   
   If mblnNameChange Then
      strNew = ChangeTag(lstSelected.list(mintLastIndex), txtName.Text, 1, Space(100), "~")
      lstSelected.list(mintLastIndex) = strNew
      mblnNameChange = False
   End If
   EditName = True
   mblnNotRespond = False

End Function

Private Sub lstSelected_DblClick()
    cmdLeftOne_Click
    RefreshButton
    RefreshUpDown
End Sub

Private Sub RefreshUpDown()
   With lstSelected
      If .ListIndex + 1 = mclsListSet.FixColumns Then
          If .ListIndex > 0 Then
              cmdSerial(0).Enabled = True
          Else
              cmdSerial(0).Enabled = False
          End If
          cmdSerial(1).Enabled = False
      End If
      If .ListIndex + 1 < mclsListSet.FixColumns Then
          If .ListIndex > 0 Then
              cmdSerial(0).Enabled = True
          Else
              cmdSerial(0).Enabled = False
          End If
          cmdSerial(1).Enabled = True
      End If
      If .ListIndex + 1 > mclsListSet.FixColumns Then
          If .ListIndex > mclsListSet.FixColumns Then
             cmdSerial(0).Enabled = True
          Else
             cmdSerial(0).Enabled = False
          End If
          If .ListIndex < .ListCount - 1 Then
              cmdSerial(1).Enabled = True
          Else
              cmdSerial(1).Enabled = False
          End If
      End If
      If .ListIndex = -1 Then
          cmdSerial(0).Enabled = False
          cmdSerial(1).Enabled = False
      End If
   End With
End Sub

Private Sub RefreshButton()
   If lstAll.ListCount = 0 Then
      cmdRightAll.Enabled = False
   Else
      cmdRightAll.Enabled = True
   End If
   If lstAll.ListIndex = -1 Then
      cmdRightOne.Enabled = False
   Else
      cmdRightOne.Enabled = True
   End If

   If lstSelected.ListCount = 0 Then
      cmdLeftAll.Enabled = False
   Else
      cmdLeftAll.Enabled = True
   End If
   If lstSelected.ListIndex = -1 Then
      cmdLeftOne.Enabled = False
   Else
      cmdLeftOne.Enabled = True
   End If
   On Error Resume Next
   If lstSelected.ListCount = mclsListSet.FixColumns Then
      cmdLeftOne.Enabled = False
      cmdLeftAll.Enabled = False
   End If
'**************************************
'ozj make it as following on  1999-12-28
    If lstSelected.ListIndex + 1 <= mclsListSet.FixColumns Then
      cmdLeftOne.Enabled = False
   End If
End Sub

'初始化列表设置
Public Function SetList(clsListSet As ListSet, Optional ChangeName As Boolean = True) As Boolean
 Dim intCount As Integer
   If mblnLoad Then
      Exit Function
   End If
   mblnLoad = True
   lstAll.Clear
   lstSelected.Clear
   Set mclsListSet = clsListSet
   
   ReGetChoosed
   GetMayChoose
   mblnNameChange = False
   RefreshButton
   RefreshUpDown
   txtName.Visible = ChangeName
   LblName.Visible = ChangeName
   Me.Show vbModal
   If mblnOk Then
       SetList = True
   End If
End Function

'通过类的属性取已选栏目
Private Sub ReGetChoosed()
  Dim intCount As Integer
  Dim strAdd As String
   With mclsListSet
      For intCount = 1 To .Columns
                strAdd = .ColumnDesc(intCount) & Space(100) & .ColumnFieldName(intCount) & "~" & .ColumnWidth(intCount) & _
                         "~" & .ColumnOrderType(intCount) & "~" & .ColumnIsFix(intCount) & "~" & .ColumnIsFind(intCount) & _
                         "~" & .ColumnFieldID(intCount) & "~" & .ColumnFieldType(intCount) & "~" & .ColumnFieldSize(intCount) & "~" & .ColumnIsMust(intCount) & "~" & .ColumnFormat(intCount) & "~" & .ColumnNotZero(intCount) & "~" & .ColumnGroup(intCount)
                lstSelected.AddItem strAdd
      Next intCount
   End With
End Sub

'取可选栏目
Private Sub GetMayChoose()
   Dim rstMayChoose As rdoResultset
   Dim strSql As String, strOrder As String, strCondVersion As String
   Dim strCond As String
   Dim rstTemp As rdoResultset
   Dim strNotIn As String
   
   strCondVersion = " And (Mod (ViewField.bytVersion, " & gVersionType * 2 & ")>=" & gVersionType & ")"
   If gclsBase.AccountSys = "3" Or gclsBase.AccountSys = "4" Then
      strCondVersion = strCondVersion & " And blnNotHospital=False"
   End If
   
   If mclsListSet.FirstUse Then
      strSql = "Select * from View1,ViewField Where View1.lngViewID=" & mclsListSet.ViewId & _
               " And View1.lngViewId=ViewField.lngViewId And ViewField.blnIsChoose=1 And Not (ViewField.blnIsFixed=1 Or Viewfield.blnIsMust=1" & _
               " Or ViewField.blnIsPrep=1)" & strCondVersion
      strOrder = " Order By lngViewFieldNO"
      Set rstMayChoose = gclsBase.BaseDB.OpenResultset(strSql & strOrder, rdOpenStatic)
   Else
        strSql = "Select * from ViewField,ListField Where ListField.lngListID=" & mclsListSet.ListID & _
                 " And ViewField.lngViewFieldID=ListField.lngViewFieldID And ListField.blnIsChoosed=0" & strCondVersion
   End If
   
   Set rstMayChoose = gclsBase.BaseDB.OpenResultset(strSql)

   With rstMayChoose
       Do While Not .EOF
            If mclsListSet.FirstUse Then
                lstAll.AddItem !strViewFieldDesc & Space(100) & !strFieldName & "~" & _
                                Utility.GetDisplayWidth(!strViewFieldDesc, !bytFieldSize) & "~" & 0 & "~" & !blnIsFixed & "~" & _
                                !blnIsFind & "~" & !lngViewFieldID & "~" & !strFieldType & "~" & !bytFieldSize & "~" & !blnIsMust & "~" & !bytFormat & "~" & !blnNotZero & "~" & !strGroup
            Else
                lstAll.AddItem !strViewFieldDesc & Space(100) & !strFieldName & "~" & _
                                Utility.GetDisplayWidth(!strViewFieldDesc, !bytFieldSize) & "~" & 0 & "~" & !blnIsFixed & "~" & _
                                !blnIsFind & "~" & .rdoColumns("lngviewFieldId") & "~" & !strFieldType & "~" & !bytFieldSize & "~" & !blnIsMust & "~" & !bytFormat & "~" & !blnNotZero & "~" & !strGroup
            End If
            .MoveNext
       Loop
   End With
   Set rstMayChoose = Nothing
End Sub

Private Sub lstSelected_GotFocus()
   RefreshButton
   RefreshUpDown
End Sub

Private Sub txtName_Change()
   mblnNameChange = True
   If LenB(StrConv(txtName.Text, vbFromUnicode)) > 30 Then BKKEY txtName.hWnd
End Sub

Private Sub txtName_LostFocus()
   EditName
End Sub