求用EXCEL+VB 设计过套打的源程序，在线等

Question

如题

Answer 1

這是一段完整的代碼--"StuffAnalyse"   物料庫存分析
On Error Resume Next
Dim Re As ADODB.Recordset '¨C­¶¼Æ¾Ú¨Ó·½
Dim RePath As ADODB.Recordset '¸ô®|¡A±q¼Æ¾Ú®w±o¨Ó
Dim Cn As ADODB.Connection
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim strPath As String
Dim lngReNum As Long
Dim strExcelFilePath As String
Dim lngPages As Long '­¶¼Æ
Dim i As Long '¥Î¤_´`Àô
Dim n As Long '¥Î¤_´`Àô
Dim strSql As String
Dim strWhere As String
Set Cn = New ADODB.Connection
Set Re = New ADODB.Recordset
Cn.Open strPubConnect
Cn.CommandTimeout = 20000Set RePath = New ADODB.Recordset
'Excel¤å¥ó¸ô®|
RePath.Open "select isnull(mean,'') from parameter_tab where parameter_name='mode_execl_path' ", Cn, adOpenStatic, adLockReadOnly, adCmdText
If RePath.RecordCount <> 0 Then
    strExcelFilePath = Trim(RePath(0).Value & "")
End If
RePath.Close
Set RePath = NothingstrExcelFilePath = strExcelFilePath & "StuffAnalyse.xls"
dialog_Excel.DefaultExt = "*.xls"
dialog_Excel.Filter = "Excel(*.xls)|*.xls"
dialog_Excel.ShowSave
strPath = dialog_Excel.FileName
If strPath = "" Then Exit Sub
Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(strExcelFilePath)
Set xlSheet = xlBook.Worksheets(1)
xlApp.DataEntryMode = xlOff
 
If Trim(CQuery.arrSqlWhere(0)) <> "" Then
    strWhere = " WHERE " & CQuery.arrSqlWhere(0)
End IfstrSql = " SELECT A.class_no,A.kind_no,A.item_no,A.character_no,A.cn_name,ISNULL(A.num,0) num," & _
        "   ISNULL(C.allot_num,0) AS allot_num,ISNULL(A.num,0)-ISNULL(C.allot_num,0) AS can_num" & _
        " FROM" & _
        "   (SELECT tabStuffStorage.class_no,tabStuffStorage.kind_no,tabStuffStorage.item_no,tabStuffStorage.character_no,f_product_name.cn_name,SUM(tabStuffStorage.num) num" & _
        "   FROM tabStuffStorage" & _
        "   LEFT JOIN f_product_name ON tabStuffStorage.class_no=f_product_name.class_no" & _
        "       AND tabStuffStorage.kind_no=f_product_name.kind_no AND tabStuffStorage.item_no=f_product_name.item_no" & _
        "       AND tabStuffStorage.character_no=f_product_name.character_no AND f_product_name.enable='1'" & _
        "   LEFT JOIN a_product_name ON f_product_name.a_no=a_product_name.a_no " & _
        "       AND f_product_name.class_no=a_product_name.class_no AND a_product_name.enable='1'" & strWhere & _
        "   GROUP BY tabStuffStorage.class_no,tabStuffStorage.kind_no,tabStuffStorage.item_no,tabStuffStorage.character_no,f_product_name.cn_name" & _
        "   )A"
strSql = strSql & _
        " LEFT JOIN" & _
        "   (SELECT B.class_no,B.kind_no,B.item_no,B.character_no,sum(ISNULL(B.require_num,0))-sum(ISNULL(B.give_out_num,0)) AS allot_num" & _
        "   FROM" & _
        "       (SELECT tabProduceMaterial.class_no,tabProduceMaterial.kind_no,tabProduceMaterial.item_no,tabProduceMaterial.character_no,tabProduceMaterial.order_id," & _
        "           tabProduceMaterial.product_no,ISNULL(tabProduceMaterial.require_num,0) AS require_num,ISNULL(tabProduceMaterial.give_out_num,0) as give_out_num" & _
        "       FROM tabProduceMaterial" & _
        "       LEFT JOIN tabShipmentChild ON tabProduceMaterial.order_id=tabShipmentChild.order_id" & _
        "           AND tabProduceMaterial.product_no=tabShipmentChild.product_no AND tabShipmentChild.enable='1'" & _
        "       WHERE ISNULL(tabProduceMaterial.end_sign,'')<>'O' AND tabProduceMaterial.class_no='A' AND tabProduceMaterial.enable='1'" & _
        "           AND ISNULL(tabShipmentChild.goout_tenor,'')<>'B'" & _
        "        ) B" & _
        "   GROUP BY  B.class_no,B.kind_no,B.item_no,B.character_no" & _
        "   )C" & _
        " ON A.class_no= C.class_no AND A.kind_no= C.kind_no AND A.item_no= C.item_no AND A.character_no= C.character_no" & _
        " ORDER BY A.class_no,A.kind_no,A.item_no,A.character_no"
         
Screen.MousePointer = 11
Re.Open strSql, Cn, adOpenStatic, adLockReadOnly, adCmdText

Answer 2

接上面
If Re.RecordCount = 0 Then
    MsgBox "¨S&brvbar;&sup3;°O&iquest;&yacute;!"
    Re.Close
    Cn.Close
    Screen.MousePointer = 0
    Exit Sub
End IfIf (Re.RecordCount / 45) - Int(Re.RecordCount / 45) > 0 Then
    lngPages = Int(Re.RecordCount / 45) + 1
Else
    lngPages = Int(Re.RecordCount / 45)
End If
If lngPages = 0 Then
    lngPages = 1
End If
For i = 1 To lngPages - 1
    xlSheet.Range("A3:I47").Copy Destination:=xlSheet.Range("A" & Trim(Str(45 * i + 1)))
Next
Re.MoveFirst
i = 0
For n = 1 To Re.RecordCount
    If n = 45 * (i + 1) + 1 Then
        i = i + 1
    End If
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 1) = Re("class_no") & ""
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 2) = Re("kind_no") & ""
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 3) = Re("item_no") & ""
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 4) = Re("character_no") & ""
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 5) = Re("cn_name") & ""
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 6) = Re("num") & ""
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 7) = Re("allot_num") & ""
    xlSheet.Cells(45 * i + 2 + n - (45 * i), 9) = Re("can_num") & ""
    Re.MoveNext
Next nxlBook.SaveAs strPath
xlApp.Visible = TrueSet Re = Nothing
Set Cn = Nothing
Set xlApp = Nothing
Re.Close
Screen.MousePointer = 0

Answer 3

Private Sub Command1_Click()
    Dim excelApp As New Excel.Application
    Dim excelWorkBook As Excel.Workbook
    Dim excelWorksheet As Excel.Worksheet
    Set excelWorkBook = excelApp.Workbooks.Add
    Set excelWorksheet = excelWorkBook.Sheets(1)
    excelWorksheet.Cells(2, 3) = "http://powerbasic.cn/bbs/"
    excelWorksheet.Cells(3, 4) = "PowerBASIC中文社区"
    excelApp.Visible = True     '显示excel界面，用于调试
    'excelWorkBook.PrintPreview '打印预览
    excelWorkBook.PrintOut      '打印输出
    excelWorkBook.Saved = True
    excelWorkBook.Close         '关闭工作薄
    excelApp.Quit               '退出excel
End Sub

Answer 4

贴一段我写的，把VS FlexGridPro 8.0删格的内容放到excel表格里面，然后打印
  Dim mybook As Excel.Workbook
  Dim mysheet As Excel.Worksheet
  Dim filename As String
  Dim banci As String
  Dim xlsname As String
  Dim shuifen As Single
  Dim intSheetBanCi As Integer
  Dim tt As Integer  '用于设置excel数据首行位置
  Dim tmp As Integer  '循环变量
  Set myexcel = New Excel.Application
  
  
  filename = Left(Trim(txtDate.Text), 10)
  banci = Right(Trim(txtDate.Text), 1)
  
  If Dir(App.Path & "\xls\" & filename & ".xls") <> "" Then
    xlsname = App.Path & "\xls\" & filename & ".xls"
  Else
    xlsname = App.Path & "\xls\" & "biaozhun.xlt"
  End If
  
  Set mybook = myexcel.Workbooks.Open(xlsname)     '打开excel
  
  If banci = "b" Then
    banci = "白班"
    intSheetBanCi = 1
    Set mysheet = mybook.Worksheets("白班")
  ElseIf banci = "y" Then
    banci = "夜班"
    intSheetBanCi = 2
    Set mysheet = mybook.Worksheets("夜班")
  ElseIf banci = "z" Then
    banci = "中班"
    intSheetBanCi = 3
    Set mysheet = mybook.Worksheets("中班")
  End If
  
   
   'Call js    '调用计算过程，得到计算值
   
   Dim pp As Integer
   tt = 4
  For tmp = 1 To vsfdata.Rows - 1
    If tt <= 24 Then
      mysheet.Cells(tt, 1) = vsfdata.TextMatrix(tmp, 0)
      mysheet.Cells(tt, 2) = vsfdata.TextMatrix(tmp, 1)
      mysheet.Cells(tt, 3) = vsfdata.TextMatrix(tmp, 2)
      mysheet.Cells(tt, 4) = vsfdata.TextMatrix(tmp, 3)
      mysheet.Cells(tt, 5) = vsfdata.TextMatrix(tmp, 4)
    Else
      mysheet.Cells(tt - 21, 6) = vsfdata.TextMatrix(tmp, 0)
      mysheet.Cells(tt - 21, 7) = vsfdata.TextMatrix(tmp, 1)
      mysheet.Cells(tt - 21, 8) = vsfdata.TextMatrix(tmp, 2)
      mysheet.Cells(tt - 21, 9) = vsfdata.TextMatrix(tmp, 3)
      mysheet.Cells(tt - 21, 10) = vsfdata.TextMatrix(tmp, 4)
    End If
    tt = tt + 1
  Next
  
  Dim cc As Integer
  cc = tt
  Dim strRiQi As String
  strRiQi = Left(Trim(txtDate.Text), 4) & "年" & Mid(Trim(txtDate.Text), 6, 2) & "月" & Mid(Trim(txtDate.Text), 9, 2) & "日"
  shuifen = Val(vsfdata.TextMatrix(1, 5)) '---------------填写表头的信息
  mysheet.Cells(2, 2) = shuifen
  mysheet.Cells(2, 3) = strRiQi
  
  If banci = "中班" Then
    
    mysheet.Cells(27, 8) = FormatNumber(Val(lblXiShu.Caption) * 100, 2) & "%"
    
  ElseIf banci = "白班" Then
    mysheet.Cells(25, 8) = FormatNumber(Val(lblXiShu.Caption) * 100, 2) & "%"
  ElseIf banci = "夜班" Then
    mysheet.Cells(25, 8) = FormatNumber(Val(lblXiShu.Caption) * 100, 2) & "%"
  End If
  
  mysheet.Cells(26, 2) = intNanLuShu
  mysheet.Cells(26, 4) = FormatNumber(sinNanLuLiang, 2)
  mysheet.Cells(27, 2) = intBeiLuShu
  mysheet.Cells(27, 4) = FormatNumber(sinBeiLuLiang, 2)
  mysheet.Cells(29, 7) = cobName.Text
  
  If Dir(App.Path & "\xls\" & filename & ".xls") <> "" Then
    mybook.Save
  Else
    mybook.SaveAs App.Path & "\xls\" & filename
  End If
  
  myexcel.Visible = True
  mysheet.PrintPreview
  myexcel.DisplayAlerts = Falseend sub

Answer 5

hdhai9451(新新人类) 
已經很完整了阿

Answer 6

打印用EXCEL 说明软件的完整性很差，依赖性很强，没有必要用到EXCEL。EXCEL的打印功能在VB中都可以实现

Answer 7

虽然没有时候，看完这些代码，但总感觉没必要吧，打印的时候，其实不需要利用EXCEL的
如果想打报表或是单据Activereport最为方便
有兴趣的可以下一个看看其中的范例，没有什么东西打不出来的
比这么多代码强多了

Answer 8

Activereport   哪有例子???

Answer 9

liang80318(小亮) 能够在程序运行时进行设计吗？

Answer 10

liang80318(小亮)不能在设计时进行修改呀!