VB6有关导出分页与自动计算字段问题

Question

不好意思，我刚申请，所以没有分，各位见谅！
为了解决导出数据到EXCEL分页问题，我在VB6中如下代码，但碰到计算字段赋值出错问题，请问怎样解决（谢谢）？

Answer 1

    If Rs_Data.State = 1 Then Rs_Data.Close
    Rs_Data.CursorLocation = adUseClient
    Rs_Data.Open m_SQL, obConn, adOpenKeyset, adLockReadOnly
    Set Rs_Data.ActiveConnection = Nothing
    
    strStruct = Replace(m_SQL, "Select", "Select Top 0", 1, 1, vbTextCompare)
    
    
    On Error GoTo ErrHandle:
    
    With Rs_Data
        '记录总数
        Irowcount = .RecordCount
        '栏位总数
        Icolcount = .Fields.Count
    End With
    
    '设置每页最大行数
    lngPageSize = 65000
    intPageCount = Round(Irowcount / lngPageSize, 0)
    If intPageCount * lngPageSize < Irowcount Then
        intPageCount = intPageCount + 1
    End If
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    xlApp.Visible = True
    
    '添加Sheet数量
    mIndex = intPageCount - xlBook.Sheets.Count
    If mIndex > 0 Then
        Set xlSheet = xlBook.Worksheets("sheet3")
        xlBook.Sheets.Add , xlSheet, mIndex
    End If
    
    If intPageCount > 1 Then
        If Rs_Temp.State = 1 Then Rs_Temp.Close
        Rs_Temp.CursorLocation = adUseClient
        Rs_Temp.Open strStruct, obConn, adOpenKeyset, adLockBatchOptimistic
        Set Rs_Temp.ActiveConnection = Nothing
    End If
    For mIndex = 1 To intPageCount
        Set xlSheet = xlBook.Worksheets("sheet" + CStr(mIndex))
        xlSheet.Select
        xlSheet.Range("A1").Value = "正在处理第 " + CStr(mIndex) + " 页数据，请稍等......"
        
        If intPageCount > 1 Then
            If Rs_Temp.RecordCount > 0 Then
                Rs_Temp.CancelBatch
            End If
            Rs_Data.MoveFirst
            Rs_Data.Move lngPageSize * (mIndex - 1), 1
            mRow = 1
            Do Until (mRow > lngPageSize Or Rs_Data.EOF)
                Rs_Temp.AddNew
                For mCol = 0 To Rs_Data.Fields.Count - 1
                    '有一个字段为计算字段                    Rs_Temp(mCol).Value = Rs_Data(mCol).Value
                Next
                Rs_Data.MoveNext
                mRow = mRow + 1
            Loop
        Else
            Set Rs_Temp = Rs_Data.Clone
        End If
        
        Irowcount = Rs_Temp.RecordCount
        
        '添加查询语句，导入EXCEL资料
        Set xlQuery = xlSheet.QueryTables.Add(Rs_Temp, xlSheet.Range("a1"))        xlQuery.Refresh
        
        '写列标题
        If m_Title <> "" Then
            ArrTitle = Split(m_Title, ",")
            For mCol = LBound(ArrTitle) To UBound(ArrTitle)
                xlSheet.Cells(1, mCol + 1) = ArrTitle(mCol)
            Next
        End If
        
        '设表格边框样式
        xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
    Next
    
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlSheet.Select
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
    
    If Rs_Temp.State = 1 Then Rs_Temp.Close
    Set Rs_Temp = Nothing
    
    If Rs_Data.State = 1 Then Rs_Data.Close
    Set Rs_Data = Nothing

Answer 2

    If Rs_Data.State = 1 Then Rs_Data.Close
    Rs_Data.CursorLocation = adUseClient
    Rs_Data.Open m_SQL, obConn, adOpenKeyset, adLockReadOnly
    Set Rs_Data.ActiveConnection = Nothing
    
    strStruct = Replace(m_SQL, "Select", "Select Top 0", 1, 1, vbTextCompare)
    
    
    On Error GoTo ErrHandle:
    
    With Rs_Data
        '记录总数
        Irowcount = .RecordCount
        '栏位总数
        Icolcount = .Fields.Count
    End With
    
    '设置每页最大行数
    lngPageSize = 65000
    intPageCount = Round(Irowcount / lngPageSize, 0)
    If intPageCount * lngPageSize < Irowcount Then
        intPageCount = intPageCount + 1
    End If
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    xlApp.Visible = True
    
    '添加Sheet数量
    mIndex = intPageCount - xlBook.Sheets.Count
    If mIndex > 0 Then
        Set xlSheet = xlBook.Worksheets("sheet3")
        xlBook.Sheets.Add , xlSheet, mIndex
    End If
    
    If intPageCount > 1 Then
        If Rs_Temp.State = 1 Then Rs_Temp.Close
        Rs_Temp.CursorLocation = adUseClient
        Rs_Temp.Open strStruct, obConn, adOpenKeyset, adLockBatchOptimistic
        Set Rs_Temp.ActiveConnection = Nothing
    End If
    For mIndex = 1 To intPageCount
        Set xlSheet = xlBook.Worksheets("sheet" + CStr(mIndex))
        xlSheet.Select
        xlSheet.Range("A1").Value = "正在处理第 " + CStr(mIndex) + " 页数据，请稍等......"
        
        If intPageCount > 1 Then
            If Rs_Temp.RecordCount > 0 Then
                Rs_Temp.CancelBatch
            End If
            Rs_Data.MoveFirst
            Rs_Data.Move lngPageSize * (mIndex - 1), 1
            mRow = 1
            Do Until (mRow > lngPageSize Or Rs_Data.EOF)
                Rs_Temp.AddNew
                For mCol = 0 To Rs_Data.Fields.Count - 1
                    '有一个字段为计算字段(出错在此)
                    Rs_Temp(mCol).Value = Rs_Data(mCol).Value
                Next
                Rs_Data.MoveNext
                mRow = mRow + 1
            Loop
        Else
            Set Rs_Temp = Rs_Data.Clone
        End If
        
        Irowcount = Rs_Temp.RecordCount
        
        '添加查询语句，导入EXCEL资料
        Set xlQuery = xlSheet.QueryTables.Add(Rs_Temp, xlSheet.Range("a1"))        xlQuery.Refresh
    Next

Answer 3

没有人帮你呀,将工程发给我看看吧
[email protected]

Answer 4

Rs_Temp(mCol).Value = Rs_Data(mCol).Value & vbnullstring

Answer 5

這位大哥，您這種方法沒有解決問題，主要是傳入的m_SQL語句的表中有字段是計算字段的原因。謝謝各位了。

Answer 6

什么計算字段,不就是数值型吗?
是哪个字段不行,处理一下.鼠标放上面看它的值
if Rs_Data(mCol).name="XXX" then
    Rs_Temp(mCol).Value = val(Rs_Data(mCol).Value)
end if

Answer 7

--在表中OweQty設計為計算字段，它等於FetchQty-PressQty
Select PlanDT, JIFAN, PlanQty, BomNo, PINFAN, MPCS, FetchQty, PressQty, OweQty, Re From TA_ForeCastAnalyze

Answer 8

CREATE TABLE [dbo].[TA_ForeCastAnalyze]
(
[PlanDT] [varchar](25) NULL,
[JIFAN] [varchar](25) NULL,
[BomNo] [varchar](50) NULL,
[PINFAN] [varchar](25) NULL,
[FetchQty] [decimal](18, 0) NULL,
[PressQty] [decimal](18, 0) NULL,
[OweQty]  AS (isnull([FetchQty],0) - isnull([PressQty],0)),
[Remart] [nvarchar](50) NULL
) 

Answer 9

这个表社的不好，都是null able。
感觉[OweQty]是浪费资源。

Answer 10

現在表是沒辦法改點，隻是這個表中有2000多萬條數據，用戶常導出超過10萬條數據到EXCEL中，所以有以上代碼問題，現問題也出在那個公式字段。

Answer 11

计算字段不要赋值
For mCol = 0 To Rs_Data.Fields.Count - 1
'有一个字段为计算字段(出错在此)
If Rs_Data.Fields(mCol).Name <> "OweQty" Then
    Rs_Temp(mCol).Value = Rs_Data(mCol).Value
End If
Next

Answer 12

我現在的做法不復值，但導出EXCEL中也沒有數據，用戶使用不方便，最重要是這個過程是一個通用的，隻需要傳入一個SQL語句即可

Answer 13

Rs_Temp 不要做查询，创建无连接记录集，这样所有的字段都是可写的
dim fld as ADODB.FieldSet Rs_Temp = New ADODB.Recordset
For Each fld in Rs_Data.Fields
Rs_Temp.Fields.Append fld.Name, fld.Type, fld.DefinedSize, _
                      fld.Attributes Or adFldUnknownUpdatable
Next
Rs_Temp.Open

Answer 14

错误应是超出整形数的范围了
把 Dim mCol As Integer 定义为长整形即可
Dim mCol As long

Answer 15

我都發了3封給你了，沒有收到啊，我的是[email protected]

Answer 16

看到了你给我的留言，我来回答你吧。
原表OweQty字段是计算字段，不允许编辑，也就不允许赋值。最简单的方法用以下语句在你的数据库里建一张空表,让你的strStruct从这张表里出。
原程序基本上没什么改变。CREATE TABLE [dbo].[TA_ForeCastAnalyze1]
(
    [PlanDT] [varchar](25) NULL,
    [JIFAN] [varchar](25) NULL,
    [BomNo] [varchar](50) NULL,
    [PINFAN] [varchar](25) NULL,
    [FetchQty] [decimal](18, 0) NULL,
    [PressQty] [decimal](18, 0) NULL,
    [OweQty] [decimal](19, 0) NULL ,
    [Remart] [nvarchar](50) NULL
) 以下程序是我做测试用的，你自己稍做修改即可。Dim obConn As New ADODB.Connection
Dim Rs_Data As New ADODB.Recordset
Dim Rs_Temp As New ADODB.Recordset
Dim m_SQL As String
Dim strStruct As StringPrivate Sub Command2_Click()
    If Rs_Data.State = 1 Then Rs_Data.Close
    Rs_Data.CursorLocation = adUseClient
    Rs_Data.Open m_SQL, obConn, adOpenKeyset, adLockReadOnly
    Set Rs_Data.ActiveConnection = Nothing
    
    'strStruct = Replace(m_SQL, "Select", "Select Top 0", 1, 1, vbTextCompare)
    
'    --在表中OweQty設計為計算字段，它等於FetchQty-PressQty
'Select PlanDT, JIFAN, PlanQty, BomNo, PINFAN, MPCS, FetchQty, PressQty, OweQty, Re From TA_ForeCastAnalyze'CREATE TABLE [dbo].[TA_ForeCastAnalyze]
'(
'    [PlanDT] [varchar](25) NULL,
'    [JIFAN] [varchar](25) NULL,
'    [BomNo] [varchar](50) NULL,
'    [PINFAN] [varchar](25) NULL,
'    [FetchQty] [decimal](18, 0) NULL,
'    [PressQty] [decimal](18, 0) NULL,
'    [OweQty]  AS (isnull([FetchQty],0) - isnull([PressQty],0)),
'    [Remart] [nvarchar](50) NULL
')    'On Error GoTo ErrHandle:
    
    With Rs_Data
        '记录总数
        Irowcount = .RecordCount
        '栏位总数
        Icolcount = .Fields.Count
    End With
    
    '设置每页最大行数
    lngPageSize = 65000
    intPageCount = Round(Irowcount / lngPageSize, 0)
    If intPageCount * lngPageSize < Irowcount Then
        intPageCount = intPageCount + 1
    End If
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    xlApp.Visible = True
    
    '添加Sheet数量
    mIndex = intPageCount - xlBook.Sheets.Count
    If mIndex > 0 Then
        Set xlSheet = xlBook.Worksheets("sheet3")
        xlBook.Sheets.Add , xlSheet, mIndex
    End If
    
    If intPageCount > 1 Then
        If Rs_Temp.State = 1 Then Rs_Temp.Close
        Rs_Temp.CursorLocation = adUseClient
        Rs_Temp.Open strStruct, obConn, adOpenKeyset, adLockBatchOptimistic
        Set Rs_Temp.ActiveConnection = Nothing
    End If
    For mIndex = 1 To intPageCount
        Set xlSheet = xlBook.Worksheets("sheet" + CStr(mIndex))
        xlSheet.Select
        xlSheet.Range("A1").Value = "正在处理第 " + CStr(mIndex) + " 页数据，请稍等......"
        
        If intPageCount > 1 Then
            If Rs_Temp.RecordCount > 0 Then
                Rs_Temp.CancelBatch
            End If
            Rs_Data.MoveFirst
            'Rs_Data.Move lngPageSize * (mIndex - 1), 1
            mRow = 1
            Do Until (mRow > lngPageSize Or Rs_Data.EOF)
                Rs_Temp.AddNew
                For mcol = 0 To Rs_Data.Fields.Count - 1
                    '有一个字段为计算字段(出错在此)
                       Rs_Temp(mcol).Value = Rs_Data(mcol).Value
                Next
                
                Rs_Data.MoveNext
                mRow = mRow + 1
            Loop
            
        Else
            Set Rs_Temp = Rs_Data.Clone
        End If
        
        Irowcount = Rs_Temp.RecordCount
        
        '添加查询语句，导入EXCEL资料
        Set xlQuery = xlSheet.QueryTables.Add(Rs_Temp, xlSheet.Range("a1"))        xlQuery.Refresh
    NextEnd SubPrivate Sub Form_Load()
obConn.ConnectionString = " Provider=SQLOLEDB.1;Password=dg;Persist Security Info=True;User ID=sa;Initial Catalog=pubs;Data Source=."
obConn.CursorLocation = adUseClient
obConn.Open
m_SQL = "select * from TA_ForeCastAnalyze"
strStruct = "select  * from TA_ForeCastAnalyze1"
Rs_Temp.Open strStruct, obConn, adOpenStatic, adLockOptimisticEnd Sub

Answer 17

修改你的程序，使用PageSize 属性，把每一页分别复制（Clone）给Set Rs_Temp，然后导出。

Answer 18

到底是 Append 创建数值型字段时出错还是字段赋值时出错？

Answer 19

可能是创建的类型不匹配.类型是DataTypeEnum值之一

Answer 20

謝謝各位，把17樓Tiger_Zhao的方法改為如下就OK了
        Dim fld As ADODB.Field
        
        For Each fld In Rs_Data.Fields
            Debug.Print fld.Name + vbTab + CStr(fld.Type) + vbTab + CStr(fld.DefinedSize) + vbTab + CStr(fld.Attributes)
            
            Select Case fld.Type
                Case 200
                    Rs_Temp.Fields.Append fld.Name, adVarChar, 500, adFldIsNullable
                Case 131
                    Rs_Temp.Fields.Append fld.Name, adDouble, , adFldIsNullable
                Case Else
                    Rs_Temp.Fields.Append fld.Name, fld.Type, fld.DefinedSize, adFldIsNullable
            End Select
        Next
        Rs_Temp.Open    End If

Answer 21

非常想知道25樓chinaboyzyq所說的分頁復制的方法，請指點

Answer 22

换成 adDouble 也行，其实 adNumeric 的字段只要再指定 Field.NumericScale 就可以了。

Answer 23

如果25樓chinaboyzyq不告訴我，明天就結帳了，謝謝合位