frmimport.frm

金算盘软件代码

ReRead:
        strSql = "SELECT ListField.strListFieldDesc, ListField.lngListFieldNO, ViewField.lngViewFieldNO," & _
            " ListField.blnIsChoosed, ListField.lngDisplayWidth,ListField.lngListFieldID " & _
            " FROM List,ListField,ViewField " & _
            " WHERE List.lngListID = ListField.lngListID " & _
            " AND ListField.lngViewFieldID = ViewField.lngViewFieldID " & _
            " AND ListField.blnIsChoosed<>0 AND List.lngViewID=" & mlngViewID & " AND List.lngOperatorID=" & gclsBase.OperatorID & _
            " ORDER BY ListField.lngListFieldNO Desc"
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recTmp.BOF And recTmp.EOF Then
            GoTo EndProc
        End If
        '错误处理
        If recTmp!lngListFieldNO < 2 Then
            strSql = "DELETE FROM ListField WHERE lngListID=" & mclsList.ListID
            gclsBase.ExecSQL strSql
            CopyListField (mclsList.ListID)
            GoTo ReRead
        End If
        GrdCol.Cols = recTmp!lngListFieldNO + 1
        Do While Not recTmp.EOF
            .TextMatrix(0, recTmp!lngListFieldNO) = recTmp!strListFieldDesc
            .ColWidth(recTmp!lngListFieldNO) = recTmp!lngDisplayWidth
            ColPropertys(recTmp!lngListFieldNO).blnChoose = True
            ColPropertys(recTmp!lngListFieldNO).lngFirstNO = recTmp!lngViewFieldNO
            ColPropertys(recTmp!lngListFieldNO).lngListFieldID = recTmp!lngListFieldID
            GrdCol.ColData(recTmp!lngListFieldNO) = recTmp!lngListFieldNO
            recTmp.MoveNext
        Loop
        SetGridFromArr
    End With
    
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    i = GrdCol.Row
    mclsGrid.ColOfs = 2
    mclsGrid.SetupStyle
    GrdCol.Row = i
    GrdCol.Redraw = blnRedrawBak
End Sub
Private Sub SetGridFromArr()
    Dim i As Long
    Dim j As Long

    With GrdCol
        .Redraw = False
        For i = 1 To .Rows - 1
            For j = 0 To .Cols - 1
                .TextMatrix(i, j) = RowPropertys(.RowData(i)).strData(ColPropertys(GrdCol.ColData(j)).lngFirstNO)
            Next
        Next
        .Redraw = True
    End With
End Sub
Private Sub SaveGrdColWidth()
    If mclsList.ListID <> 0 Then
        EditUpdate
    End If
End Sub

'按用户ID重新保存一份列表
Private Sub AddList()
  Dim intCount As Integer
  Dim rstList As rdoResultset
  Dim rstListField As rdoResultset
  Dim strSql As String
  Dim lngListID As Long

    'Add List
    strSql = "Select * from List"
    Set rstList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With rstList
       .AddNew
          !lngViewId = mclsList.ViewId
          !strListName = IIf(mclsList.ViewName = "", " ", mclsList.ViewName)
          !lngOperatorID = gclsBase.OperatorID
          lngListID = GetNewID("List")
          !lngListID = lngListID
       .Update
    End With
    
    CopyListField (lngListID)
    mclsList.ViewId = mlngViewID
    rstList.Close
End Sub

'Copy All ListField
Private Sub CopyListField(lngListID As Long)
  Dim strSql As String
  Dim rstSource As rdoResultset, rstDesc As rdoResultset
  Dim lngCount As Long
     
     strSql = "Select * from ViewField Where " & _
              " lngViewId = " & mlngViewID & " ORDER BY lngViewFieldNo"
     
     Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
     
     strSql = "Select * from Listfield Where ROWNUM<1"
     Set rstDesc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
     
     With rstSource
         Do While Not .EOF
            rstDesc.AddNew
                rstDesc!lngListFieldID = GetNewID("ListField")
                rstDesc!lngListID = lngListID
                rstDesc!strListFieldDesc = rstSource!strViewFieldDesc
                rstDesc!bytsort = 0
                rstDesc!lngViewFieldID = rstSource!lngViewFieldID
                rstDesc!lngDisplayWidth = rstSource!bytFieldSize * Me.TextWidth("A")
                If rstSource!blnIsPrep <> 0 Then
                    lngCount = lngCount + 1
                    rstDesc!blnIsChoosed = 1
                    rstDesc!lngListFieldNO = lngCount
                Else
                    rstDesc!blnIsChoosed = 0
                    rstDesc!lngListFieldNO = 0
                End If
            rstDesc.Update
            .MoveNext
         Loop
     End With
     rstSource.Close
     rstDesc.Close
End Sub
'更新用户自定义列表的修改
Private Sub EditUpdate()
  Dim strSql As String
'  Dim rstListField As Recordset
  Dim intCount As Integer
  
  'Set All Choosed Flag to False
  strSql = "UPDATE ListField Set blnIsChoosed=0 WHERE lngListID =" & mclsList.ListID
    
  gclsBase.ExecSQL strSql
  
  'Save Now Choosed Field
  For intCount = 1 To GrdCol.Cols - 1
      strSql = GrdCol.TextMatrix(0, intCount)
      If Right(strSql, 1) = "↑" Or Right(strSql, 1) = "↓" Then
        strSql = Left(strSql, Len(strSql) - 1)
      End If
    strSql = "Update ListField" & " Set lngListFieldNO=" & intCount & ",strListFieldDesc='" & strSql & _
                  "',lngDisplayWidth=" & GrdCol.ColWidth(intCount) & _
                  ",blnIsChoosed=1 Where lngListId=" & mclsList.ListID & " And lngListFieldId=" & ColPropertys(GrdCol.ColData(intCount)).lngListFieldID
    gclsBase.ExecSQL strSql
      
  Next intCount
End Sub

Private Sub GetRowData()
    Dim strPath As String
    Dim strTmp As String
    Dim i As Long
    
    GrdCol.Rows = 1
    ReDim RowPropertys(0)
    strPath = mstrInPath
    If Dir(strPath, vbDirectory) = "" Then
        GoTo EndProc
    End If
        
    Do
        strTmp = Dir(, vbDirectory)
        If strTmp = "" Then
            GoTo EndProc
        End If
        If strTmp <> ".." And strTmp <> "." Then
            strTmp = strPath & strTmp
            If GetAttr(strTmp) = vbDirectory Then
                GetRowDataWithPath strTmp
            End If
        End If
    Loop
EndProc:
    GrdCol.Rows = UBound(RowPropertys) + 1
    For i = 1 To GrdCol.Rows - 1
        GrdCol.RowData(i) = i
    Next
    ShowAll
End Sub

Private Function GetRowDataWithPath(ByVal strPath As String) As Boolean
    Dim strINIFile As String
    
    strINIFile = strPath & "\format.ini"
    On Error GoTo ErrHandle
    If FileLen(strINIFile) = 0 Then Exit Function
    
    GetARowData strPath, "货币"
    GetARowData strPath, "科目"
    GetARowData strPath, "部门"
    GetARowData strPath, "职员类别"
    GetARowData strPath, "职员"
    GetARowData strPath, "单位类别"
    GetARowData strPath, "单位"
    #If conQSH = 1 Then
        GetARowData strPath, "拜访客户资料"
    #End If
    GetARowData strPath, "地区"    
    GetARowData strPath, "统计核算"
    GetARowData strPath, "项目核算"
    GetARowData strPath, "凭证类别"
    GetARowData strPath, "单据模板"
    GetARowData strPath, "固资方式"
    GetARowData strPath, "固资类别"
    GetARowData strPath, "凭证"
'    GetARowData strPath, "余额"
    GetARowData strPath, "科目期初"
'    GetARowData strPath, "应收应付余额"
    GetARowData strPath, "应收应付期初"
'    GetARowData strPath, "现金银行余额"
    GetARowData strPath, "银行对帐单"
    GetARowData strPath, "银行帐期初"
    GetARowData strPath, "财务预算"
    GetARowData strPath, "现金项目"
    GetARowData strPath, "固资期初"
    
    #If conVersionType = 1 Then
        GetARowData strPath, "商品性质"
        GetARowData strPath, "商品类别"
        GetARowData strPath, "商品"
        GetARowData strPath, "商品单位"
        GetARowData strPath, "货位"
        GetARowData strPath, "工程类别"
        GetARowData strPath, "工程"
        GetARowData strPath, "自定义项目0"
        GetARowData strPath, "自定义项目1"
        GetARowData strPath, "自定义项目2"
        GetARowData strPath, "自定义项目3"
        GetARowData strPath, "自定义项目4"
        GetARowData strPath, "自定义项目5"
        GetARowData strPath, "企业收发地址"
        GetARowData strPath, "企业开户银行"
        GetARowData strPath, "单位收发地址"
        GetARowData strPath, "单位开户银行"
        GetARowData strPath, "固资变动"
        GetARowData strPath, "经营预算"
        GetARowData strPath, "采购订单"
        GetARowData strPath, "商品采购"
        GetARowData strPath, "直运采购"
        GetARowData strPath, "受托入库"
        GetARowData strPath, "受托结算"
        GetARowData strPath, "加工入库"
        GetARowData strPath, "加工费用"
        GetARowData strPath, "采购发票"
        GetARowData strPath, "自制入库"
        GetARowData strPath, "盘盈入库"
        GetARowData strPath, "其他入库"
        GetARowData strPath, "销售订单"
        GetARowData strPath, "商品销售"
        GetARowData strPath, "直运销售"
        GetARowData strPath, "委托出库"
        GetARowData strPath, "委托结算"
        GetARowData strPath, "加工出库"
        GetARowData strPath, "分期出库"
        GetARowData strPath, "分期结算"
        GetARowData strPath, "销售发票"
        GetARowData strPath, "领用出库"
        GetARowData strPath, "成本调整"
        GetARowData strPath, "盘亏出库"
        GetARowData strPath, "其他出库"
        GetARowData strPath, "代销调拨"
        GetARowData strPath, "商品调拨"
        GetARowData strPath, "商品调价"
        GetARowData strPath, "商品组装"
        GetARowData strPath, "商品拆卸"
        GetARowData strPath, "商品盘点"
        GetARowData strPath, "应付贷项"
        GetARowData strPath, "应付借项"
        GetARowData strPath, "应收借项"
        GetARowData strPath, "应收贷项"
        GetARowData strPath, "应收计息"
        GetARowData strPath, "付款单"
        GetARowData strPath, "收款单"
        GetARowData strPath, "库存期初"
        GetARowData strPath, "受托期初"
        GetARowData strPath, "委托期初"
        GetARowData strPath, "分期期初"
        GetARowData strPath, "直运期初"
        GetARowData strPath, "加工期初"
        GetARowData strPath, "暂估期初"
    #Else
        If gclsBase.ControlAccount Then
            GetARowData strPath, "商品性质"
            GetARowData strPath, "商品类别"
            GetARowData strPath, "商品"
            GetARowData strPath, "商品单位"
            GetARowData strPath, "商品采购"
            GetARowData strPath, "商品销售"
            GetARowData strPath, "应付贷项"
            GetARowData strPath, "应付借项"
            GetARowData strPath, "应收借项"
            GetARowData strPath, "应收贷项"
            GetARowData strPath, "应收计息"
            GetARowData strPath, "付款单"
            GetARowData strPath, "收款单"
            GetARowData strPath, "记帐凭证"
        End If
    #End If
    
ErrHandle:
End Function

Private Function GetARowData(ByVal strPath As String, ByVal strItem As String) As Boolean
    Dim strINIFile As String
    Dim strDataFile As String
    Dim RowPropertyTmp As RowProperty
    Dim lngSucceed As Long
    Dim lngFailure As Long

    strINIFile = strPath & "\format.ini"
    RowPropertyTmp.strPath = strPath
    RowPropertyTmp.strData(1) = ""
    strDataFile = VBGetPrivateProfileString(strItem, "文件名", strINIFile)
    If Trim(strDataFile) = "" Then Exit Function
    strDataFile = strPath & "\" & strDataFile
    On Error Resume Next
    If FileLen(strDataFile) = 0 Then Exit Function
    RowPropertyTmp.strData(3) = VBGetPrivateProfileString(strItem, "导出日期", strINIFile)
    If RowPropertyTmp.strData(3) = "" Then Exit Function
    RowPropertyTmp.strData(2) = strItem
    RowPropertyTmp.strData(4) = VBGetPrivateProfileString("帐套", "数据服务名", strINIFile)
    RowPropertyTmp.strData(7) = VBGetPrivateProfileString("帐套", "发送单位", strINIFile)
    RowPropertyTmp.strData(5) = VBGetPrivateProfileString("帐套", "所属任务", strINIFile)
    RowPropertyTmp.strData(6) = VBGetPrivateProfileString("帐套", "任务定义接收帐套", strINIFile)
    RowPropertyTmp.strData(8) = VBGetPrivateProfileString("帐套", "数据源", strINIFile)
    
    strINIFile = strPath & "\ImPort.ini"
    On Error GoTo ErrHandle
    If FileLen(strINIFile) <> 0 Then
        RowPropertyTmp.strData(9) = VBGetPrivateProfileString(strItem & "导入", "导入帐套", strINIFile)
        If RowPropertyTmp.strData(9) <> "" Then
            RowPropertyTmp.strData(10) = VBGetPrivateProfileString(strItem & "导入", "导入日期", strINIFile)
            RowPropertyTmp.strData(11) = VBGetPrivateProfileString(strItem & "导入", "导入时间", strINIFile)
            lngSucceed = C2lng(VBGetPrivateProfileString(strItem & "导入", "导入成功", strINIFile))
            lngFailure = C2lng(VBGetPrivateProfileString(strItem & "导入", "导入失败", strINIFile))
            If lngSucceed = 0 Then
                If lngFailure = 0 Then
                    RowPropertyTmp.strData(12) = "成功"
                Else
                    RowPropertyTmp.strData(12) = "失败"
                End If
            Else
                If lngFailure = 0 Then
                    RowPropertyTmp.strData(12) = "成功"
                Else
                    RowPropertyTmp.strData(12) = "成功" & lngSucceed & "条，失败" & lngFailure & "条"
                End If
            End If
        End If
    End If
ErrHandle:
    ReDim Preserve RowPropertys(UBound(RowPropertys) + 1)
    RowPropertys(UBound(RowPropertys)) = RowPropertyTmp
End Function

Private Function cmdOK_Click() As Boolean
    Dim i As Long
    Dim j As Long
    Dim blnItem(100) As Boolean
    
    Me.MousePointer = vbHourglass
    
    If PathValid() = False Then
        Me.MousePointer = vbDefault
        Exit Function
    End If
    If gclsBase.DateIsValid(Format(gclsBase.BaseDate, "YYYY-MM-DD")) = False Then
        cmdOK_Click = True
        Me.MousePointer = vbDefault
        Exit Function
    End If
    For i = 1 To GrdCol.Rows - 1
        If GrdCol.TextMatrix(i, 1) <> "" Then
            For j = i - 1 To 1 Step -1
                If GrdCol.TextMatrix(j, 1) <> "" Then
                    If RowPropertys(GrdCol.RowData(i)).strPath = RowPropertys(GrdCol.RowData(j)).strPath Then
                        Exit For
                    End If
                End If
            Next
            If j = 0 Then
                ImportItems i
            End If