VBS命令

[weixin_43417345]

Private Sub docout_Click()       '导出WORD按钮
  If rs1.RecordCount < 1 Then
  MsgBox "导出失败，当前列表中没有记录!"
  outstate1.Visible = False
    Exit Sub
  End If
On Error GoTo not_installword '当没装word软件时的出错处理
If MsgBox(Chr(13) + "是否将当前列表中的数据导出为WORD数据？  ", vbQuestion + vbYesNo) = vbNo Then Exit Sub

Dim wdApp As Word.Application  '定义word变量
Dim wdDoc '定义word文档变量
Dim wdTable '定义WORD表格变量
Dim FieldLen()  '存放字段长度值
Dim FieldLen1 As Integer  '存放每列的最大宽度
Dim FieldValue As String
Dim iRow, iCol As Integer
Dim iRowCount, iColCount As Integer '存放行数、列数值
main.Enabled = False
outstate1.Visible = True '显示导出状态
outstate1.Caption = "正在导出，请稍后..."
With rs1

  .MoveLast
  iRowCount = .RecordCount + 2 '记录总数
  iColCount = .Fields.Count  '字段总数
  .MoveFirst
End With

'重新定义列数
ReDim FieldLen(iColCount)
'添加一个word文档及表
Set wdApp = New Word.Application
wdApp.Documents.Add '新建Word 文档
Set wdTable = wdApp.Selection.Tables.Add(wdApp.Selection.Range, iRowCount + 1, iColCount, wdWord9TableBehavior, wdAutoFitFixed)
With rs1
  '读取标题宽度作为列宽初始值
  For iCol = 1 To iColCount
    FieldLen(iCol) = LenB(StrConv(.Fields(iCol - 1).Name, vbFromUnicode))
  Next iCol
  For iRow = 1 To iRowCount
    For iCol = 1 To iColCount
      '读取字段值，返回为文本型
      If .Fields(iCol - 1).Value <> "" Then
        If .Fields(iCol - 1).Type = 10 Then
          FieldValue = Trim(.Fields(iCol - 1).Value)
        Else
          FieldValue = CStr(.Fields(iCol - 1).Value)
        End If
      Else
        FieldValue = " "
      End If
      Select Case iRow
      Case 1
         '第一行为标题行，在后面设置
      Case 2 '在第二行插入字段名
        wdTable.Cell(iRow, iCol).Range.InsertAfter (.Fields(iCol - 1).Name)
        '设置字段名居中
        wdTable.Cell(iRow, iCol).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        '设置字体为粗体
        wdTable.Cell(iRow, iCol).Range.Font.Bold = wdToggle
      Case Else '从第三行开始插入记录
        '计算字段值长度，返回值的单位是字节长度
        FieldLen1 = LenB(StrConv(FieldValue, vbFromUnicode))
        '自动设置表格列宽
        If FieldLen(iCol) < FieldLen1 Then
          '表格列宽等于较长字段长
          wdTable.Columns(iCol).PreferredWidth = 8 * FieldLen1 'Word表
          '数组Fieldlen(iCol)中存放最大字段长度值
          FieldLen(iCol) = FieldLen1
        Else
          '表格列宽等于当前字段宽度
          wdTable.Columns(iCol).PreferredWidth = 8 * FieldLen(iCol)
        End If
        '向表单元格中写入字段值
        wdTable.Cell(iRow, iCol).Range.InsertAfter (FieldValue)
        '设置单元格中的字居中
        wdTable.Cell(iRow, iCol).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
      End Select
      
      DoEvents
    Next iCol
    If iRow > 2 Then
      If Not .EOF Then .MoveNext
    End If
    DoEvents
    outstate1.Caption = "正在导出，完成: " + CStr(Int(100 * iRow / iRowCount)) + "%" '显示导出进度
  Next iRow
  '添加年月日
  wdTable.Cell(iRowCount + 1, 1).Range.InsertAfter (Format$(Now, "yyyy年mm月dd日"))  '在最后一行后加是年月日
  wdTable.Rows(iRowCount + 1).Cells.Merge '合并最后一行
  wdTable.Cell(iRowCount + 1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
 
  wdTable.Rows(1).Cells.Merge '合并第一行表格
  If usetype = "系统管理员" Then
     wdTable.Cell(1, 1).Range.InsertAfter ("标题名") '合并以后插入标题
  Else
     wdTable.Cell(1, 1).Range.InsertAfter (usepart & "标题名") '合并以后插入标题
  End If
  wdTable.Cell(1, 1).Range.Font.Bold = wdToggle '设置标题为粗体
  wdTable.Cell(1, 1).Range.Font.Size = 14 '设置标题为14号字体
  wdTable.Cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter  '设置标题居中
  wdApp.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter  '设置表格居中


  .MoveFirst
  wdApp.Visible = True  '显示Word表格
  Set wdApp = Nothing  '交还控制给Word
End With
  outstate1.Visible = False
  main.Enabled = True
Exit Sub

not_installword:   '当电脑没装word时的处理
   MsgBox "导出错误！请检查电脑是否装有不低于Word2000版本的Word软件！" & Chr(13) & Chr(10) & "然后检查一下出错处的记录是否有问题！"
   outstate1.Visible = False
   main.Enabled = True
End Sub
---------------------
作者：limshirley
来源：CSDN
原文：https://blog.csdn.net/limshirley/article/details/70210425
版权声明：本文为博主原创文章，转载请附上博文链接！