实例介绍
【实例简介】
【实例截图】
【核心代码】
VERSION 5.00 Begin VB.Form Form1 BorderStyle = 3 'Fixed Dialog Caption = "征询函自动生成工具" ClientHeight = 4620 ClientLeft = -15 ClientTop = 270 ClientWidth = 8040 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 4620 ScaleWidth = 8040 ShowInTaskbar = 0 'False StartUpPosition = 2 '屏幕中心 Begin VB.CommandButton Command3 Caption = "生成征询函" Height = 885 Left = 2340 TabIndex = 3 Top = 1320 Width = 3405 End Begin VB.CommandButton Command2 Caption = "生成征询函" Height = 885 Left = 2370 TabIndex = 2 Top = 1830 Visible = 0 'False Width = 3405 End Begin VB.CommandButton Command1 Caption = "生成征询函" Height = 975 Left = 2250 TabIndex = 0 Top = 600 Visible = 0 'False Width = 3465 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "正在生成征询函,请耐心等待......" BeginProperty Font Name = "宋体" Size = 14.25 Charset = 134 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00800000& Height = 375 Left = 90 TabIndex = 1 Top = 2700 Width = 7875 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Dim cnExcel As New ADODB.Connection Dim strConn As String '连接Excel文件 Private Function ConnectDB(ByVal cnType As String, ByVal sFileName As String) As Boolean On Error GoTo err1: If cnExcel.State = 1 Then cnExcel.Close Set cnExcel = Nothing End If If cnType = "2003" Then strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Persist Security Info=false;" & _ "Data Source=" & sFileName & ";" & _ "Extended Properties='Excel 8.0;HDR=Yes'" Else strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Persist Security Info=false;" & _ "Data Source=" & sFileName & ";" & _ "Extended Properties='Excel 8.0;HDR=Yes'" End If 'cnExcel.CursorLocation = adUseClient cnExcel.Open strConn ConnectDB = True Exit Function err1: ConnectDB = False End Function Public Function NullToStr(ByVal varValue As Variant, Optional sDefault As String = "") As String If IsNull(varValue) Then NullToStr = sDefault Else NullToStr = varValue End If End Function Private Sub Command3_Click() Dim rsCus As New ADODB.Recordset Dim rs As New ADODB.Recordset Dim sFileName2003 As String Dim iRow As Integer Dim fQuantity As Double Dim strPathTmp As String Dim objExcellApp As Excel.Application Dim objExcellWorkBook As Excel.Workbook Dim objExcellWorkSheet As Excel.Worksheet Dim objFSO As New FileSystemObject Dim i As Integer Dim j As Integer Me.Enabled = False On Error GoTo err: strPathTmp = App.Path & "\往来询证函-模版.doc" Set objWordApp = CreateObject("Word.Application") sFileName2003 = App.Path & "\询证函.xls" Set objExcellApp = CreateObject("excel.application") objExcellApp.Workbooks.Open sFileName2003 Set objExcellWorkBook = objExcellApp.Workbooks(1) Set objExcellWorkSheet = objExcellWorkBook.Worksheets(2) If ConnectDB("2003", sFileName2003) = True Then If rsCus.State = 1 Then rsCus.Close 'rsCus.CursorLocation = adUseClient rsCus.Open "Select * From [Sheet1$] WHERE 客商编码<>'' ORDER BY 序号", cnExcel, adOpenStatic, adLockOptimistic ' 序号,序号1,客商编码,客商,应付款,暂估应付款,工程设备,其他 '客户 i = 0 rsCus.MoveFirst Do While Not rsCus.EOF i = i 1 Me.Label1.Caption = "正在生成第" & Trim(Str(i)) & "份征询函,请耐心等待......" strPathDoc = App.Path & "\往来询证函\往来询证函_" & Replace(rsCus.Fields(1).Value, " ", "") & "_" & rsCus.Fields(3).Value & ".doc" objFSO.CopyFile strPathTmp, strPathDoc, True objWordApp.Documents.Open strPathDoc objWordApp.ActiveDocument.Content.Find.Execute "@@Code", , , , , , , , , rsCus.Fields(1).Value, Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@CusName", , , , , , , , , rsCus.Fields(3).Value, Replace:=wdReplaceAll If objExcellWorkSheet.Cells(i 1, 5) > 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@YF ", , , , , , , , , Format(objExcellWorkSheet.Cells(i 1, 5), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@YF-", , , , , , , , , strNull, Replace:=wdReplaceAll ElseIf objExcellWorkSheet.Cells(i 1, 5) < 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@YF-", , , , , , , , , -1 * Format(objExcellWorkSheet.Cells(i 1, 5), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@YF ", , , , , , , , , strNull, Replace:=wdReplaceAll Else objWordApp.ActiveDocument.Content.Find.Execute "@@YF ", , , , , , , , , strNull, Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@YF-", , , , , , , , , strNull, Replace:=wdReplaceAll End If If objExcellWorkSheet.Cells(i 1, 6) > 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@ZG ", , , , , , , , , Format(objExcellWorkSheet.Cells(i 1, 6), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@ZG-", , , , , , , , , strNull, Replace:=wdReplaceAll ElseIf objExcellWorkSheet.Cells(i 1, 6) < 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@ZG-", , , , , , , , , -1 * Format(objExcellWorkSheet.Cells(i 1, 6), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@ZG ", , , , , , , , , strNull, Replace:=wdReplaceAll Else objWordApp.ActiveDocument.Content.Find.Execute "@@ZG ", , , , , , , , , strNull, Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@ZG-", , , , , , , , , strNull, Replace:=wdReplaceAll End If If objExcellWorkSheet.Cells(i 1, 7) > 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@GZ ", , , , , , , , , Format(objExcellWorkSheet.Cells(i 1, 7), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@GZ-", , , , , , , , , strNull, Replace:=wdReplaceAll ElseIf objExcellWorkSheet.Cells(i 1, 7) < 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@GZ-", , , , , , , , , -1 * Format(objExcellWorkSheet.Cells(i 1, 7), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@GZ ", , , , , , , , , strNull, Replace:=wdReplaceAll Else objWordApp.ActiveDocument.Content.Find.Execute "@@GZ ", , , , , , , , , strNull, Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@GZ-", , , , , , , , , strNull, Replace:=wdReplaceAll End If If objExcellWorkSheet.Cells(i 1, 8) > 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@QT ", , , , , , , , , Format(objExcellWorkSheet.Cells(i 1, 8), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@QT-", , , , , , , , , strNull, Replace:=wdReplaceAll ElseIf objExcellWorkSheet.Cells(i 1, 8) < 0 Then objWordApp.ActiveDocument.Content.Find.Execute "@@QT-", , , , , , , , , -1 * Format(objExcellWorkSheet.Cells(i 1, 8), "#0.00"), Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@QT ", , , , , , , , , strNull, Replace:=wdReplaceAll Else objWordApp.ActiveDocument.Content.Find.Execute "@@QT ", , , , , , , , , strNull, Replace:=wdReplaceAll objWordApp.ActiveDocument.Content.Find.Execute "@@QT-", , , , , , , , , strNull, Replace:=wdReplaceAll End If objWordApp.ActiveDocument.Close True rsCus.MoveNext Loop Me.Label1.Caption = "全部生成完毕!" objWordApp.Quit Set objWordApp = Nothing If rsCus.State = 1 Then rsCus.Close If rs.State = 1 Then rs.Close If cnExcel.State = 1 Then cnExcel.Close Set rsCus = Nothing Set rs = Nothing Set cnExcel = Nothing Me.Enabled = True End If Exit Sub err: MsgBox "发生错误!", vbInformation vbOKOnly vbDefaultButton1, "提示:" End Sub
好例子网口号:伸出你的我的手 — 分享!
小贴士
感谢您为本站写下的评论,您的评论对其它用户来说具有重要的参考价值,所以请认真填写。
- 类似“顶”、“沙发”之类没有营养的文字,对勤劳贡献的楼主来说是令人沮丧的反馈信息。
- 相信您也不想看到一排文字/表情墙,所以请不要反馈意义不大的重复字符,也请尽量不要纯表情的回复。
- 提问之前请再仔细看一遍楼主的说明,或许是您遗漏了。
- 请勿到处挖坑绊人、招贴广告。既占空间让人厌烦,又没人会搭理,于人于己都无利。
关于好例子网
本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享,对搜索内容的合法性不具有预见性、识别性、控制性,仅供学习研究,请务必在下载后24小时内给予删除,不得用于其他任何用途,否则后果自负。基于互联网的特殊性,平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查;无论平台是否已进行审查,用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场,基于网友分享,根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定,若资源存在侵权或相关问题请联系本站客服人员,点此联系我们。关于更多版权及免责申明参见 版权及免责申明
网友评论
我要评论