listview导出记录到WORD一循环就乱了
Dim dl As StringDim i As Integer, j As Integer
Dim ifieldcount As Integer, irecordcount As Integer
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim atable As Word.Table
Call con
dl = "select * from kf"
Rs.Open dl, Cnn, 1, 1
If Rs.RecordCount > 0 Then
irecordcount = Rs.RecordCount
Set wdapp = CreateObject("word.application")
Set wddoc = wdapp.Documents.add
With wdapp
.Visible = True
.Activate
.Caption = "电脑店客户资料详情单"
Set atable = .ActiveDocument.Tables.add(.Selection.Range, irecordcount + 1, 21)
atable.Cell(1, 1).Range.InsertAfter "客户编号"
atable.Cell(1, 2).Range.InsertAfter "客户姓名"
atable.Cell(1, 3).Range.InsertAfter "联系电话"
atable.Cell(1, 4).Range.InsertAfter "家庭住址"
atable.Cell(1, 5).Range.InsertAfter "备用电话"
atable.Cell(1, 6).Range.InsertAfter "机型分类"
atable.Cell(1, 7).Range.InsertAfter "显示屏品牌"
atable.Cell(1, 8).Range.InsertAfter "显示屏型号"
atable.Cell(1, 9).Range.InsertAfter "显示屏SN"
atable.Cell(1, 10).Range.InsertAfter "售屏日期"
atable.Cell(1, 11).Range.InsertAfter "屏保到期"
atable.Cell(1, 12).Range.InsertAfter "保点情况"
atable.Cell(1, 13).Range.InsertAfter "主机品牌"
atable.Cell(1, 14).Range.InsertAfter "主机型号"
atable.Cell(1, 15).Range.InsertAfter "主机SN"
atable.Cell(1, 16).Range.InsertAfter "保修模式"
atable.Cell(1, 17).Range.InsertAfter "售主机日"
atable.Cell(1, 18).Range.InsertAfter "主机到期"
atable.Cell(1, 19).Range.InsertAfter "存档日期"
atable.Cell(1, 20).Range.InsertAfter "录单人员"
atable.Cell(1, 21).Range.InsertAfter "单据审核"
Rs.MoveFirst
Do Until Rs.EOF
atable.Cell(2, 1).Range.InsertAfter Rs.Fields("uid").Value
atable.Cell(2, 2).Range.InsertAfter Rs.Fields("name").Value
atable.Cell(2, 3).Range.InsertAfter Rs.Fields("tel").Value
atable.Cell(2, 4).Range.InsertAfter Rs.Fields("addr").Value
atable.Cell(2, 5).Range.InsertAfter Rs.Fields("phone").Value
atable.Cell(2, 6).Range.InsertAfter Rs.Fields("lei").Value
atable.Cell(2, 7).Range.InsertAfter Rs.Fields("xpai").Value
atable.Cell(2, 8).Range.InsertAfter Rs.Fields("xxing").Value
atable.Cell(2, 9).Range.InsertAfter Rs.Fields("xsn").Value
atable.Cell(2, 10).Range.InsertAfter Rs.Fields("xdate").Value
atable.Cell(2, 11).Range.InsertAfter Rs.Fields("xbx").Value
atable.Cell(2, 12).Range.InsertAfter Rs.Fields("bd").Value
atable.Cell(2, 13).Range.InsertAfter Rs.Fields("zpai").Value
atable.Cell(2, 14).Range.InsertAfter Rs.Fields("xing").Value
atable.Cell(2, 15).Range.InsertAfter Rs.Fields("pcsn").Value
atable.Cell(2, 16).Range.InsertAfter Rs.Fields("fs").Value
atable.Cell(2, 17).Range.InsertAfter Rs.Fields("sdate").Value
atable.Cell(2, 18).Range.InsertAfter Rs.Fields("bdate").Value
atable.Cell(2, 19).Range.InsertAfter Rs.Fields("ldate").Value
atable.Cell(2, 20).Range.InsertAfter Rs.Fields("luser").Value
atable.Cell(2, 21).Range.InsertAfter Rs.Fields("lchk").Value
Rs.MoveNext
Loop
End With
Set wdapp = Nothing
Set wddoc = Nothing
Else
MsgBox "未检测到客户数据!", vbCritical, "警告"
End If
End Sub