clslistcustom.cls

金算盘软件代码

            If .Tab = 3 Then gclsSys.SendMessage CStr(mfrmCustom.hWnd), Message.msgCustom4
            If .Tab = 4 Then gclsSys.SendMessage CStr(mfrmCustom.hWnd), Message.msgCustom5
            If .Tab = 5 Then gclsSys.SendMessage CStr(mfrmCustom.hWnd), Message.msgCustom6
        End If
    End With
End Sub

Private Sub mfrmCustom_ListNew()
    mfrmCustom.MousePointer = vbHourglass
    frmDefineCard.AddCard Left(mfrmCustom.sstPages.Caption, Len(mfrmCustom.sstPages.Caption) - 4), vbModal
    Set frmDefineCard = Nothing
    mfrmCustom.MousePointer = vbDefault
End Sub

Private Sub mfrmCustom_ListShowAll()
    With mfrmCustom
        If .chkShowall = 0 Then
            Select Case .sstPages.Tab
                Case 0
                     .ShowAll(.sstPages.Tab) = " Custom0.blnIsInActive=0"
                Case 1
                    .ShowAll(.sstPages.Tab) = "Custom1.blnIsInActive=0 "
                Case 2
                    .ShowAll(.sstPages.Tab) = "Custom2.blnIsInActive=0 "
                Case 3
                    .ShowAll(.sstPages.Tab) = " Custom3.blnIsInActive=0 "
                Case 4
                    .ShowAll(.sstPages.Tab) = "Custom4.blnIsInActive=0 "
                Case 5
                    .ShowAll(.sstPages.Tab) = " Custom5.blnIsInActive=0 "
            End Select
        Else
'            Select Case .sstPages.Tab
'                Case 0
                     .ShowAll(.sstPages.Tab) = ""
'                Case 1
'                    .ShowAll(.sstPages.Tab) = ""
'                Case 2
'                    .ShowAll(.sstPages.Tab) = ""
'                Case 3
'                    .ShowAll(.sstPages.Tab) = ""
'                Case 4
'                    .ShowAll(.sstPages.Tab) = ""
'                Case 5
'                    .ShowAll(.sstPages.Tab) = ""
'            End Select
        End If
        .ToolRefresh
    End With
End Sub

Private Sub mfrmCustom_ListUsed()
    Dim lngID As Long
    
    lngID = mfrmCustom.ListID
    Select Case mfrmCustom.sstPages.Tab
        Case 0
            UseCode Message.msgCustom1, lngID
        Case 1
            UseCode Message.msgCustom2, lngID
        Case 2
            UseCode Message.msgCustom3, lngID
        Case 3
            UseCode Message.msgCustom4, lngID
        Case 4
            UseCode Message.msgCustom5, lngID
        Case 5
            UseCode Message.msgCustom6, lngID
    End Select
    mfrmCustom.ZOrder 1
End Sub

Private Sub mfrmCustom_ListUserMenu(ByVal Index As Integer)
    If Index = 7 Then
    frmDefineSetCard.EditCard
    Unload frmDefineSetCard
    Set frmDefineSetCard = Nothing
    End If
End Sub
Private Function UpdateIsActive(ByVal intTab As Integer, ByVal strCode As String, ByVal blnIsInActive As Boolean, ByVal blnYes As Boolean) As Boolean
    Dim strSql As String
    Dim strSuSql As String
    
             If blnIsInActive Then
                    strSql = "UPDATE Custom" & intTab & " SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE strCustomCode = '" & strCode & "' Or strCustomCode like '" & strCode & "-%'"
             Else
                If blnYes Then
                    strSuSql = "UPDATE Custom" & intTab & " SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE strCustomCode='" & strCode & "' Or strCustomCode like '" & strCode & "-%'"
                End If
                strSql = "UPDATE Custom" & intTab & " SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE strCustomCode  in  ('" & strCode
                Do Until CodePrefix(strCode) = ""
                    strCode = CodePrefix(strCode)
                    strSql = strSql & "','" & strCode
                Loop
                strSql = strSql & "')"
                
            End If
        
    If blnYes Then
        If Not gclsBase.ExecSQL(strSuSql) Then
            UpdateIsActive = False
            Exit Function
        End If
    End If
    UpdateIsActive = gclsBase.ExecSQL(strSql)
End Function

Private Function ListIsInActive(ByVal intTab As Integer, ByVal lngID As Long, strCode As String) As Boolean
    Dim recTmp As rdoResultset
    Dim strSql As String
    strSql = "Select blnIsInActive,strCustomCode as Code  from Custom" & intTab & " Where lngCustomID=" & lngID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTmp.EOF Then
        ListIsInActive = IIf(recTmp!blnIsInActive = 1, True, False)
        strCode = recTmp!Code
    End If
    recTmp.Close
    Set recTmp = Nothing
End Function
Private Function IsLowerCode(ByVal intTab As Integer, ByVal strCode As String) As Boolean
    Dim strSql As String
    Dim tmp As rdoResultset
    strSql = "select blnIsInActive from Custom" & intTab & " where blnIsInActive=1 and strCustomCode like '" & strCode & "-%'"
    Set tmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If tmp.RowCount <> 0 Then
        IsLowerCode = True
    Else
        IsLowerCode = False
    End If
    tmp.Close
    Set tmp = Nothing
End Function

Private Function InitsstPages() As Boolean
    Dim k As Integer
    Dim strTitle(5) As String
    Dim blnUser(5) As Boolean
    InitsstPages = True
    If Not ListModule.InitTitle(strTitle, blnUser) Then
        InitsstPages = False
        Exit Function
    End If
    With mfrmCustom.sstPages
        For k = 0 To 5
            If strTitle(k) <> "" Then
                .TabCaption(k) = strTitle(k)
            Else
                .TabCaption(k) = Mid(.TabCaption(k), 1, Len(.TabCaption(k)) - 4)
            End If
            mblnRefresh(k) = True
            Select Case k
                Case 0
                    .TabCaption(k) = .TabCaption(k) & "(&M)"
                Case 1
                    .TabCaption(k) = .TabCaption(k) & "(&K)"
                Case 2
                    .TabCaption(k) = .TabCaption(k) & "(&D)"
                Case 3
                    .TabCaption(k) = .TabCaption(k) & "(&N)"
                Case 4
                    .TabCaption(k) = .TabCaption(k) & "(&P)"
                Case 5
                    .TabCaption(k) = .TabCaption(k) & "(&X)"
            End Select
        Next k
    End With
    UpdateTitle strTitle
End Function

Private Sub UpdateTitle(title() As String)
    Dim recTemplete As rdoResultset
    Dim strSql As String
    Dim i As Integer
    
    For i = 0 To 5
'        strSql = "Select strViewFieldDesc from ViewField where lngViewID=" & i + 24 & " order by lngViewFieldID"
'        Set recTemplete = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
'        With recTemplete
'            Do Until .EOF
'                .Edit
'                   If !strViewFieldDesc Like "*编码" Then !strViewFieldDesc = title(i) & "编码"
'                   If !strViewFieldDesc Like "*名称" Then !strViewFieldDesc = title(i) & "名称"
'                   If !strViewFieldDesc Like "*全称" Then !strViewFieldDesc = title(i) & "全称"
'                .Update
'                .MoveNext
'            Loop
'            .Close
'        End With
        strSql = "Update Viewfield Set strViewFieldDesc='" & title(i) & "编码" & "' Where lngViewID=" & i + 24 & " And strViewFieldDesc Like '%编码'"
        gclsBase.ExecSQL (strSql)
        strSql = "Update Viewfield Set strViewFieldDesc='" & title(i) & "名称" & "' Where lngViewID=" & i + 24 & " And strViewFieldDesc Like '%名称'"
        gclsBase.ExecSQL (strSql)
        strSql = "Update Viewfield Set strViewFieldDesc='" & title(i) & "全称" & "' Where lngViewID=" & i + 24 & " And strViewFieldDesc Like '%全称'"
        gclsBase.ExecSQL (strSql)
        
        strSql = "select lngListID from list where lngViewID=" & i + 24 & "and lngOperatorID=" & gclsBase.OperatorID
        Set recTemplete = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic)
        If Not recTemplete.EOF Then CopyListField recTemplete!lngListID, i + 24
    Next
    recTemplete.Close
    Set recTemplete = Nothing
End Sub
Private Sub CopyListField(lngListID As Long, intViewID As Integer)
  Dim strSql As String
  Dim rstSource As rdoResultset, rstDesc As rdoResultset
  Dim fldListField As rdoColumn
     
     strSql = "Select * from ViewField Where " & _
              "(ViewField.blnIsChoose=1 or ViewField.blnIsFixed=1 Or " & _
              "Viewfield.blnIsMust=1 Or ViewField.blnIsPrep=1)" & _
              "And lngViewId = " & intViewID
     Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'     strSql = "Select * from Listfield Where lngListId=" & lngListID
'     Set rstDesc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
     With rstSource
        Do While Not .EOF
                    If rstSource!strViewFieldDesc Like "*编码" Then
'                            rstDesc.MoveFirst
'                            Do While Not rstDesc.EOF
'                                If rstDesc!strListFieldDesc Like "*编码" Then
'                                    rstDesc.Edit
'                                    rstDesc!strListFieldDesc = rstSource!strViewFieldDesc
'                                    rstDesc.Update
'                                End If
'                                rstDesc.MoveNext
'                            Loop
                        strSql = " Update Listfield set strListFieldDesc='" & rstSource!strViewFieldDesc & "' where strListFieldDesc like '%编码' And lngListId=" & lngListID
                        gclsBase.ExecSQL strSql
                    ElseIf rstSource!strViewFieldDesc Like "*名称" Then
'                        rstDesc.MoveFirst
'                        Do While Not rstDesc.EOF
'                            If rstDesc!strListFieldDesc Like "*名称" Then
'                                rstDesc.Edit
'                                rstDesc!strListFieldDesc = rstSource!strViewFieldDesc
'                                rstDesc.Update
'                            End If
'                            rstDesc.MoveNext
'                        Loop
                        strSql = " Update Listfield set strListFieldDesc='" & rstSource!strViewFieldDesc & "' Where strListFieldDesc Like '%名称'  And lngListID = " & lngListID
                        gclsBase.ExecSQL strSql
                    ElseIf rstSource!strViewFieldDesc Like "*全称" Then
'                        rstDesc.MoveFirst
'                        Do While Not rstDesc.EOF
'                            If rstDesc!strListFieldDesc Like "*全称" Then
'                                rstDesc.Edit
'                                rstDesc!strListFieldDesc = rstSource!strViewFieldDesc
'                                rstDesc.Update
'                            End If
'                            rstDesc.MoveNext
'                        Loop
                        strSql = " Update Listfield set strListFieldDesc='" & rstSource!strViewFieldDesc & "' Where strListFieldDesc Like '%全称'  And lngListID = " & lngListID
                        gclsBase.ExecSQL strSql
                    End If
            .MoveNext
         Loop
     End With
     rstSource.Close
     Set rstSource = Nothing
'     rstDesc.Close
'     Set rstDesc = Nothing
End Sub

Public Function ShowEachList(ByVal lngID As Long, Optional intTab As Integer = 0) As Boolean
    strWhere = "Custom" & intTab + 1 & ".lngCustomID=" & lngID
    ShowEachList = mfrmCustom.Showlist(lngID, intTab, strWhere)
End Function