基本信息
源码名称：vb操作Word 示例源码
源码大小：0.02M
文件格式：.zip
开发语言：ASP
更新时间：2017-11-14
友情提示：（无需注册或充值，赞助后即可获取资源下载链接）
嘿，亲！知识可是无价之宝呢，但咱这精心整理的资料也耗费了不少心血呀。小小地破费一下，绝对物超所值哦！如有下载和支付问题，请联系我们QQ(微信同号)：813200300
本次赞助数额为： 2 元×
微信扫码支付：2 元
×
请留下您的邮箱，我们将在2小时内将文件发到您的邮箱
源码介绍
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