vbvba基于模版生成word文档的类

vb/vba基于模版生成word文档 vb/vba基于模版生成word文档的类 Word 2009-05-10 21:51:29 阅读378 评论0 字号：大中小 订阅 . http://blog.chinaunix.net/u/9337/showart_175128.html 又一个代码了，2004年写的，vb/vba 操作word的，接口和那个excel的差不多，不过多了一个addimage，呵呵，功能可是大不一样了。至今经常还可以拿出来用用，总算是有点用处的。blog那么冷清，继续垒些代码进去嘿嘿 文件: clsDotWord.rar 大小: 2KB 下载: 下载 Option Explicit ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' Word 从dot 模板 个人简介word模板免费下载关于员工迟到处罚通告模板康奈尔office模板下载康奈尔 笔记本 模板 下载软件方案模板免费下载 构建word文档的类 '' 作者 鄢中堡 '' write by abao++ 2004-12 '' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Type ReplaceStruct srctr As String '源字符串 rplcstr As String '替换为字符串 End Type Public WordVersion As String Private Type FillTableStruct tableindex As Integer '表格索引 Row As Integer ' 表格行 col As Integer '表格列 TextString As String '文字 End Type Enum sf_ScaleMode '图形缩放模式 sf_Userdefine = 1 '使用指定的宽度和高度，不保持原来的比例 sf_FitWidth = 2 '自动按宽度缩放 sf_FitHeight = 3 '自动按高度缩放 sf_AutoFit = 4 '在宽度和高度中选择最大化显示的缩放 sf_Default = 5 '默认 sf_AutoFittable = 6 End Enum Private Type InsertImageStruct tableindex As Integer '表格位置 Row As Integer '行 col As Integer '列 picfilename As String '图片文件名 ScaleMode As sf_ScaleMode '缩放模式 width As Integer '宽度 Height As Integer '高度 End Type Dim ReplaceInfo() As ReplaceStruct '替换数组 Dim TableInfo() As FillTableStruct '表格填入数组 Dim ImageInfo() As InsertImageStruct '图片填入数组 Private Sub class_initialize() ReDim ReplaceInfo(0) ReDim TableInfo(0) ReDim ImageInfo(0) End Sub Function ClearInfo() '清除所有信息 ReDim ReplaceInfo(0) ReDim TableInfo(0) ReDim ImageInfo(0) End Function Function AddDotReplace(sstr, rstr) '添加一个替换,其中 sstr为<%%>中间内容, Call AddReplace("<%" & sstr & "%>", rstr) End Function Function AddReplace(sstr, rstr) '添加一个替换 Dim i As Integer i = UBound(ReplaceInfo) + 1 ReDim Preserve ReplaceInfo(i) ReplaceInfo(i).srctr = sstr ReplaceInfo(i).rplcstr = rstr End Function Function AddFillTable(tableindex, x, y, value) '在表格tableindex 的x行 y列填入字符 value Dim i As Integer i = UBound(TableInfo) + 1 ReDim Preserve TableInfo(i) TableInfo(i).tableindex = tableindex TableInfo(i).Row = x TableInfo(i).col = y TableInfo(i).TextString = value End Function Function AddImage(tableindex, x, y, filename, mode As sf_ScaleMode, width, Height) '在表格tableindex 的x行 y列填入字符 value Dim i As Integer i = UBound(ImageInfo) + 1 ReDim Preserve ImageInfo(i) ImageInfo(i).tableindex = tableindex ImageInfo(i).Row = x ImageInfo(i).col = y ImageInfo(i).picfilename = filename ImageInfo(i).ScaleMode = mode ImageInfo(i).width = width ImageInfo(i).Height = Height End Function Function MakeDocFile(filename, dotname) As String '生成word文件到文件名,使用模板文件名 dotname 使用当前的信息 Dim i As Integer Dim objword As Word.Application Dim objDoc As Word.Document Dim renum, tablenum, imagenum 'On Error GoTo errhandle renum = UBound(ReplaceInfo) tablenum = UBound(TableInfo) imagenum = UBound(ImageInfo) Set objword = New Word.Application objword.Visible = False Debug.Print objword.Version 'Set objdoc = Documents() If dotname <> "" Then objword.Documents.Add Template:=dotname objword.Selection.Document.SaveAs filename:=filename, FileFormat:=wdFormatDocument, _ LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _ :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _ False Else objword.Documents.Open filename End If Set objDoc = objword.Documents(objword.Documents.Count) '替换部分 With objword.Selection.Find For i = 1 To UBound(ReplaceInfo) Step 1 DoEvents .ClearFormatting .Text = ReplaceInfo(i).srctr .Replacement.ClearFormatting .Replacement.Text = ReplaceInfo(i).rplcstr .Execute Replace:=wdReplaceAll, Forward:=True, _ Wrap:=wdFindContinue Next i End With '替换页眉页脚部分 If objword.ActiveWindow.View.SplitSpecial <> wdPaneNone Then objword.ActiveWindow.Panes(2).Close End If If objword.ActiveWindow.ActivePane.View.Type = wdNormalView Or objword.ActiveWindow. _ ActivePane.View.Type = wdOutlineView Then objword.ActiveWindow.ActivePane.View.Type = wdPrintView End If objword.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader objword.Selection.Find.ClearFormatting objword.Selection.Find.Replacement.ClearFormatting With objword.Selection.Find For i = 1 To UBound(ReplaceInfo) Step 1 .Text = ReplaceInfo(i).srctr .Replacement.Text = ReplaceInfo(i).rplcstr .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll Next i End With objword.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '生成表格部分 For i = 1 To UBound(TableInfo) Step 1 DoEvents With objDoc.Tables(TableInfo(i).tableindex) .Cell(Row:=TableInfo(i).Row, Column:=TableInfo(i).col).Range.Delete .Cell(Row:=TableInfo(i).Row, Column:=TableInfo(i).col).Range.InsertAfter Text:=TableInfo(i).TextString End With Next i Dim MyInshape As InlineShape Dim tmode As sf_ScaleMode For i = 1 To UBound(ImageInfo) If FileExists(CStr(ImageInfo(i).picfilename)) Then With objDoc.Tables(ImageInfo(i).tableindex) tmode = ImageInfo(i).ScaleMode Set MyInshape = .Cell(Row:=ImageInfo(i).Row, Column:=ImageInfo(i).col).Range.InlineShapes.AddPicture(filename:=ImageInfo(i).picfilename, _ LinkToFile:=False, SaveWithDocument:=True) Select Case tmode Case sf_Userdefine MyInshape.width = ImageInfo(i).width MyInshape.Height = ImageInfo(i).Height Case sf_FitWidth MyInshape.Height = MyInshape.Height * ImageInfo(i).width / MyInshape.width MyInshape.width = ImageInfo(i).width Case sf_FitHeight MyInshape.width = MyInshape.width * ImageInfo(i).Height / MyInshape.Height MyInshape.Height = ImageInfo(i).Height Case sf_AutoFittable, sf_AutoFit If tmode = sf_AutoFittable Then ImageInfo(i).width = .Cell(Row:=ImageInfo(i).Row, Column:=ImageInfo(i).col).width ImageInfo(i).Height = .Cell(Row:=ImageInfo(i).Row, Column:=ImageInfo(i).col).Height End If If MyInshape.width / MyInshape.Height > ImageInfo(i).width / ImageInfo(i).Height Then MyInshape.Height = MyInshape.Height * ImageInfo(i).width / MyInshape.width MyInshape.width = ImageInfo(i).width Else MyInshape.width = MyInshape.width * ImageInfo(i).Height / MyInshape.Height MyInshape.Height = ImageInfo(i).Height End If Case sf_Default '系统默认 End Select End With Else MakeDocFile = MakeDocFile & vbCrLf & "警告:没有找到图片文件" & ExtractFileName(ImageInfo(i).picfilename) & "(文档:" & ExtractFileName(filename) & ")" & vbCrLf End If Next i objDoc.Save objDoc.Close objword.Quit Set objDoc = Nothing Set objword = Nothing Exit Function errhandle: MakeDocFile = MakeDocFile & vbCrLf & "错误:" & Err.Description & "(" & Err.Number & ")" End Function