frmtakestockwizard.frm

金算盘软件代码

Dim UserDefine(5) As String     '自定义项目名称
Dim UserDefineIsUsed(5) As Boolean   '自定义项目在用标志
Dim MyList As ListSet
Private blnMakeTempLate As Boolean '是否需要新建模板标志
Private lngOldTempLateID As Long '上次新建模板ID
Dim strName(1 To 18) As String

Private Sub cmdButton1_Click(Index As Integer)
    Dim strTemp As String
    Dim ListIndex As Long
    
    Select Case Index
    Case 0
        ListIndex = ListSelect(0).ListIndex
        If ListIndex < 0 Then Exit Sub
        ListSelect(1).AddItem ListSelect(0).list(ListIndex)
        ListSelect(0).RemoveItem (ListIndex)
'        cmdButton1(0).Enabled = False
'        cmdButton1(3).Enabled = True
        If ListIndex < ListSelect(0).ListCount Then
            ListSelect(0).ListIndex = ListIndex
        ElseIf ListSelect(0).ListCount <> 0 Then
            ListSelect(0).ListIndex = ListIndex - 1
        End If
    Case 1
        While ListSelect(0).ListCount > 0
            ListSelect(1).AddItem ListSelect(0).list(0)
            ListSelect(0).RemoveItem 0
        Wend
'        cmdButton1(1).Enabled = False
'        cmdButton1(0).Enabled = False
'        cmdButton1(3).Enabled = True
    Case 2
        ListIndex = ListSelect(1).ListIndex
        If ListIndex < 2 Then Exit Sub
        ListSelect(0).AddItem ListSelect(1).list(ListIndex)
        ListSelect(1).RemoveItem (ListIndex)
'        cmdButton1(2).Enabled = False
'        cmdButton1(1).Enabled = True
        If ListIndex < ListSelect(1).ListCount Then
            ListSelect(1).ListIndex = ListIndex
        ElseIf ListSelect(1).ListCount > 2 Then
            ListSelect(1).ListIndex = ListIndex - 1
        End If
    Case 3
        While ListSelect(1).ListCount > 2
            ListSelect(0).AddItem ListSelect(1).list(2)
            ListSelect(1).RemoveItem 2
        Wend
'        cmdButton1(3).Enabled = False
'        cmdButton1(2).Enabled = False
'        cmdButton1(1).Enabled = True
    Case 4
        If ListSelect(1).ListIndex <= 2 Then Exit Sub
        strTemp = ListSelect(1).list(ListSelect(1).ListIndex)
        ListSelect(1).list(ListSelect(1).ListIndex) = ListSelect(1).list(ListSelect(1).ListIndex - 1)
        ListSelect(1).ListIndex = ListSelect(1).ListIndex - 1
        ListSelect(1).list(ListSelect(1).ListIndex) = strTemp
    Case 5
        If ListSelect(1).ListIndex < 2 Or ListSelect(1).ListIndex = ListSelect(1).ListCount - 1 Then Exit Sub
        strTemp = ListSelect(1).list(ListSelect(1).ListIndex)
        ListSelect(1).list(ListSelect(1).ListIndex) = ListSelect(1).list(ListSelect(1).ListIndex + 1)
        ListSelect(1).ListIndex = ListSelect(1).ListIndex + 1
        ListSelect(1).list(ListSelect(1).ListIndex) = strTemp
    End Select
    setcmdButton Index
    blnMakeTempLate = True
'    If cmdButton1(Index).Enabled Then
'        cmdButton1(Index).SetFocus
'    End If
End Sub

Private Sub cmdButton2_Click(Index As Integer)
    Dim ListIndex As Long
    Dim strTemp As String
    Select Case Index
    Case 0
        ListIndex = ListSelect(2).ListIndex
        If ListIndex = -1 Then Exit Sub
        ListSelect(3).AddItem ListSelect(2).list(ListIndex)
        ListSelect(2).RemoveItem (ListIndex)
'        cmdButton2(0).Enabled = False
'        cmdButton2(3).Enabled = True
        If ListIndex < ListSelect(2).ListCount Then
            ListSelect(2).ListIndex = ListIndex
        ElseIf ListSelect(2).ListCount <> 0 Then
            ListSelect(2).ListIndex = ListIndex - 1
        End If
    Case 1
        While ListSelect(2).ListCount <> 0
            ListSelect(3).AddItem ListSelect(2).list(0)
            ListSelect(2).RemoveItem 0
        Wend
'        cmdButton2(1).Enabled = False
'        cmdButton2(0).Enabled = False
'        cmdButton2(3).Enabled = True
    Case 2
        ListIndex = ListSelect(3).ListIndex
        If ListIndex = -1 Then Exit Sub
        ListSelect(2).AddItem ListSelect(3).list(ListIndex)
        ListSelect(3).RemoveItem (ListIndex)
'        cmdButton2(2).Enabled = False
'        cmdButton2(1).Enabled = True
        If ListIndex < ListSelect(3).ListCount Then
            ListSelect(3).ListIndex = ListIndex
        ElseIf ListSelect(3).ListCount <> 0 Then
            ListSelect(3).ListIndex = ListIndex - 1
        End If
    Case 3
        While ListSelect(3).ListCount <> 0
            ListSelect(2).AddItem ListSelect(3).list(0)
            ListSelect(3).RemoveItem 0
        Wend
'        cmdButton2(3).Enabled = False
'        cmdButton2(2).Enabled = False
'        cmdButton2(1).Enabled = True
    Case 4
        If ListSelect(3).ListIndex <= 0 Then Exit Sub
        strTemp = ListSelect(3).list(ListSelect(3).ListIndex)
        ListSelect(3).list(ListSelect(3).ListIndex) = ListSelect(3).list(ListSelect(3).ListIndex - 1)
        ListSelect(3).ListIndex = ListSelect(3).ListIndex - 1
        ListSelect(3).list(ListSelect(3).ListIndex) = strTemp
    Case 5
        
        If ListSelect(3).ListIndex = ListSelect(3).ListCount - 1 Then Exit Sub
        strTemp = ListSelect(3).list(ListSelect(3).ListIndex)
        ListSelect(3).list(ListSelect(3).ListIndex) = ListSelect(3).list(ListSelect(3).ListIndex + 1)
        ListSelect(3).ListIndex = ListSelect(3).ListIndex + 1
        ListSelect(3).list(ListSelect(3).ListIndex) = strTemp
    End Select
    setcmdButton 10 + Index
'    If cmdButton2(Index).Enabled Then
'        cmdButton2(Index).SetFocus
'    End If
End Sub

Private Sub cmdPNFC_Click(Index As Integer)
    On Error Resume Next
    Select Case Index
    Case 3  '取消
'        WizardFinish False
        Unload Me
    Case 2  '完成
        If Not IsDate(GACalendar1.Text) Then
            GACalendar1.Text = Format(gclsBase.BaseDate, "yyyy-mm-dd")
            ShowMsg Me.hWnd, "制单日格式错误，请重新输入！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "输入错误"
            stbBuildNewAcnt.Tab = 4
            GACalendar1.SetFocus
            Exit Sub
        End If
        If gclsBase.PeriodClosed(GACalendar1.Text) Then
            GACalendar1.Text = Format(gclsBase.BaseDate, "yyyy-mm-dd")
            ShowMsg Me.hWnd, "制单日不能在已结帐期间内！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "输入错误"
            stbBuildNewAcnt.Tab = 4
            GACalendar1.SetFocus
            Exit Sub
        End If
        If Not WizardFinish(True) Then Exit Sub
        strSql = FrmTakeStock.strSQLSelect
        Dim recTmp As rdoResultset
        Debug.Print "STIME:" & vbTab & Time
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        Debug.Print "ETIME:" & vbTab & Time
        If Err Then
            ShowMsg Me.hWnd, "查询表达式含有以下错误，无法进行筛选！" & Chr(13) & Chr(13) & "----“" & Err.Description & "”", MB_OK + MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "错误信息"
            FrmTakeStock.strSQLSelect = ""
            If Not recTmp Is Nothing Then
                recTmp.Close
                Set recTmp = Nothing
            End If
            Exit Sub
        End If
        If (recTmp.BOF And recTmp.EOF) Then
            If ShowMsg(Me.hWnd, "在数据库中未发现符合条件的库存信息，您确实要按此条件进行筛选吗？", MB_YESNO + MB_SYSTEMMODAL + MB_ICONQUESTION + MB_DEFBUTTON2, "错误信息") = vbNo Then
                FrmTakeStock.strSQLSelect = ""
                If Not recTmp Is Nothing Then
                    recTmp.Close
                    Set recTmp = Nothing
                End If
                Exit Sub
            End If
        End If
        If Not recTmp Is Nothing Then
            recTmp.Close
            Set recTmp = Nothing
        End If
        Unload Me
    Case 0
        If stbBuildNewAcnt.Tab > 0 Then
            stbBuildNewAcnt.Tab = stbBuildNewAcnt.Tab - 1
        End If
        If stbBuildNewAcnt.Tab = 0 Then
            cmdPNFC(0).Enabled = False
        End If
    Case 1
        If stbBuildNewAcnt.Tab < 4 Then
            stbBuildNewAcnt.Tab = stbBuildNewAcnt.Tab + 1
        End If
        If stbBuildNewAcnt.Tab = 4 Then
            cmdPNFC(1).Enabled = False
        End If
    End Select
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'    If KeyCode = vbKeyPageUp Then
'        If Shift And vbCtrlMask Then
'            If cmdPNFC(0).Enabled Then
'                cmdPNFC_Click 0
'            End If
'        End If
'    ElseIf KeyCode = vbKeyPageDown Then
'        If Shift And vbCtrlMask Then
'            If cmdPNFC(1).Enabled Then
'                cmdPNFC_Click 1
'            End If
'        End If
'    ElseIf KeyCode = 13 Then
'        If Shift And vbCtrlMask Then
'            cmdButton_Click 3
'        End If
'    End If
End Sub

Private Sub Form_Load()
    Dim recTmp As rdoResultset
    Dim i As Integer
        
    '版本控制
    #If conVersionType = 4 Then '实达版
    #ElseIf conVersionType = 16 Then '财务版
    #Else
        For i = 1 To 6
            UserDefine(i - 1) = "自定义项目" & CStr(i)
            UserDefineIsUsed(i - 1) = True
        Next
        strSql = "SELECT * FROM Setting WHERE strSection = '自定项目'"
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        Do While Not recTmp.EOF
            If recTmp!strKey Like "自定项目?名称" Then
                UserDefine(C2lng(Mid(recTmp!strKey, 5, 1))) = recTmp!strSetting
            ElseIf recTmp!strKey Like "自定项目?使用" Then
                UserDefineIsUsed(C2lng(Mid(recTmp!strKey, 5, 1))) = CBool(recTmp!strSetting)
            End If
            recTmp.MoveNext
        Loop
        recTmp.Close
        Set recTmp = Nothing
    #End If
    stbBuildNewAcnt.Tab = 0
    SetTabStop
    cmdPNFC(0).Enabled = False
    Me.Icon = Utility.GetFormResPicture(139, vbResIcon) '窗体图标
    cmdPNFC(0).Picture = Utility.GetFormResPicture(1005, vbResBitmap)     '上一步
    cmdPNFC(1).Picture = Utility.GetFormResPicture(1006, vbResBitmap)     '下一步
    cmdPNFC(2).Picture = Utility.GetFormResPicture(1016, vbResBitmap)     '完成
    cmdPNFC(3).Picture = Utility.GetFormResPicture(1002, vbResBitmap)     '取消
    cmdButton1(4).Picture = Utility.GetFormResPicture(1019, vbResBitmap)    '上移
    cmdButton1(5).Picture = Utility.GetFormResPicture(1020, vbResBitmap)    '下移
    cmdButton2(4).Picture = Utility.GetFormResPicture(1019, vbResBitmap)   '上移
    cmdButton2(5).Picture = Utility.GetFormResPicture(1020, vbResBitmap)   '下移
    Picture2(0).Picture = Utility.GetFormResPicture(140, vbResBitmap)
    Picture2(1).Picture = Utility.GetFormResPicture(140, vbResBitmap)
    Picture2(2).Picture = Utility.GetFormResPicture(140, vbResBitmap)
    Picture2(3).Picture = Utility.GetFormResPicture(140, vbResBitmap)
    Picture2(4).Picture = Utility.GetFormResPicture(140, vbResBitmap)
    
strSqlFromI = " Item,ItemNature,ItemType,Custom0,Custom1,Custom2,Custom4,Custom3,Custom5,Position," _
   & "Area,Customer,CustomerType,Area Area2,Employee Employee1 "

strSqlJoinI = " WHERE Item.lngItemNatureID = ItemNature.lngItemNatureID " _
& " AND Item.lngItemTypeID = ItemType.lngItemTypeID " _
& " AND Item.lngCustomID0 = Custom0.lngCustomID(+) " _
& " AND Item.lngCustomID1 = Custom1.lngCustomID(+) " _
& " AND Item.lngCustomID2 = Custom2.lngCustomID(+) " _
& " AND Item.lngCustomID3 = Custom3.lngCustomID(+) " _
& " AND Item.lngCustomID4 = Custom4.lngCustomID(+) " _
& " AND Item.lngCustomID5 = Custom5.lngCustomID(+) " _
& " AND Item.lngPositionID = Position.lngPositionID(+) " _
& " AND Item.lngAreaID = Area.lngAreaID(+) " _
& " AND Item.lngCustomerID = Customer.lngCustomerID(+) " _
& " AND Customer.lngCustomerTypeID = CustomerType.lngCustomerTypeID(+) " _
& " AND Customer.lngAreaID= Area2.lngAreaID(+) " _
& " AND Customer.lngEmployeeID=Employee1.lngEmployeeID(+) "

'strSqlFromP = "(Position AS STPosition LEFT JOIN Department ON STPosition.lngDepartmentID=Department.lngDepartmentID)"
strSqlFromP = " Position STPosition,Department "
strSqlJoinP = " WHERE STPosition.lngDepartmentID=Department.lngDepartmentID(+) "
    set_Tab 0
    ListText(0).ReferRow = 0
'    ListText(0).Text = ListText(0).TextMatrix(0, 2)
'    strPositionCond = ""
    set_Tab 1
    ListText(1).ReferRow = 0
'    ListText(1).Text = ListText(1).TextMatrix(0, 2)
'    set_Tab 2
    GetTemplate
    set_Tab 3
    set_Tab 4
'    SetHelpID 50101
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Set MyList = Nothing
    Erase UserDefine
    Erase UserDefineIsUsed
    Erase strName
    
    Unload frmTakeStockWizardSelect
    Utility.UnLoadFormResPicture Me
    Utility.RemoveFormResPicture 139
    Utility.RemoveFormResPicture 1005
    Utility.RemoveFormResPicture 1006
    Utility.RemoveFormResPicture 1016
    Utility.RemoveFormResPicture 1002
    Utility.RemoveFormResPicture 1019
    Utility.RemoveFormResPicture 1020
    Utility.RemoveFormResPicture 140
End Sub

Private Sub set_Tab(ByVal TabID As Integer)
    Dim i As Integer
    Dim recTemp As rdoResultset
    
    Select Case TabID
    Case 0          '设置Tab0的内容
        ListText(0).ClearRefer
        ListText(0).Comparts = 3
        
        strSql = "SELECT lngPositionID,strPositionCode,strPositionName FROM Position WHERE " _
            & "intLevel<>1 AND blnIsDetail<>0 AND blnIsInActive=0 ORDER BY strPositionCode"
        ListText(0).SeekCol = "1,2,3"
        Set ListText(0).Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)