'主文件
'-----------------------------------------------------------
'載入資料庫 所需引用相關變數
Dim Conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim SqlString As String
Dim i As Integer
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\xxxx.MDB"
Dim StartTime As Date
StartTime = Now
SqlString = " Select * from [a] order by BuildTime desc"
Dim OriV As String
Dim Nowid As Integer
'*******************************************************************
'
' 變數資料處理完成，傳送資料到WORD應用程式。
'
'*******************************************************************
Dim Myword As New Word.Application
Dim Newdoc As Word.Document
Myword.Caption = ""
'Myword.Visible = True
Set Newdoc = Myword.Documents.Open(ThisWorkbook.Path & "\模板.doc", , True) '設定成「唯讀」以免資料被寫入。
Dim objSelection
Set objSelection = Myword.Selection
Dim Spage As String '要寫入目前的頁數
Dim SelContent As String '寫入的內容 暫存用
Dim SeparatePage As Integer 一個檔案要多少頁
Dim SeparatePageFileCount As Integer 分頁的檔案編號
SeparatePage = 50 1頁要多少筆資料
SeparatePageFileCount = 0
Const PerItem As Integer = 8
'停用 文法檢查 避免資料輸出太多時的檢查
'Newdoc.GrammarChecked = False
Dim Fn As String
'Myword.Selection.HomeKey
objSelection.TypeParagraph
objSelection.TypeParagraph
'NewDoc.FormFields("pName").Range.Text = Range("E2")
i = 0
While Not rs.EOF
DoEvents '避免當機
i = i + 1
'為利分段處理 將 I 列入 統計
If i >= 1 Then
'************************************************************************************************************************
'
' 每 800筆，製作一個檔案 因為 每 8 筆一頁
'
'************************************************************************************************************************
If ((i) Mod (SeparatePage * PerItem)) = 1 And (i <> 1) Then '每頁*幾筆?
'最後插入目錄
objSelection.HomeKey Unit:=wdStory, Extend:=wdMove '移到最前方
'產生目錄(這個部分 從WORD 錄製巨集後，複製過來時要修改一些參數，例如 With Newdoc、 objSelection.Range )
With Newdoc
.TablesOfContents.Add Range:=objSelection.Range, RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=2, IncludePageNumbers:=True, AddedStyles:="", _
UseHyperlinks:=True, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
True
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With
Debug.Print i & " " & rs("DiscussID")
'先存上一個檔案，再開啟一個新檔案
SeparatePageFileCount = SeparatePageFileCount + 1
Fn = Year(Date) - 1911 & "-" & Month(Date) & "-" & Day(Date) & " [ 筆數 " & (i - SeparatePage * PerItem) & "-" & (i - 1) & " ]文章" & Right("0" & SeparatePageFileCount, 2) & ".doc"
Newdoc.SaveAs ThisWorkbook.Path & "\" & Fn
Newdoc.Close
Set Newdoc = Nothing
Set Newdoc = Myword.Documents.Open(ThisWorkbook.Path & "\文章.doc", , True) '設定成「唯讀」以免資料被寫入。
Set objSelection = Myword.Selection
objSelection.TypeParagraph
objSelection.TypeParagraph
End If
If (i Mod PerItem) = 1 Then
Spage = -Int(-i / PerItem)
objSelection.TypeText ("頁碼： " & Spage) '無條件進位!
objSelection.Style = Newdoc.Styles("標題 1")
objSelection.TypeParagraph
End If
'If Year(UPdateTime) >= 2010 And Month(UPdateTime) >= 7 Then
' objSelection.TypeText ("編號： " & rs("DiscussID") & " " & " 已OK ")
' objSelection.Style = Newdoc.Styles("標題 2")
' objSelection.TypeParagraph
'Else
SelContent = "編號： " & rs("DiscussID") & " " & rs("Subject")
SelContent = Replace(SelContent, vbCrLf, "")
SelContent = Replace(SelContent, vbCr, "")
SelContent = Replace(SelContent, vbLf, "")
objSelection.TypeText (SelContent)
objSelection.Style = Newdoc.Styles("標題 2")
objSelection.TypeParagraph
'處理字串
SelContent = Replace(rs("Message"), ",", "，")
SelContent = Replace(SelContent, ";", "；")
SelContent = Replace(SelContent, vbCrLf, "
")
SelContent = Replace(SelContent, vbCr, "
")
SelContent = Replace(SelContent, vbLf, "
")
SelContent = Replace(SelContent, "
", vbCrLf)
SelContent = Replace(SelContent, "
", vbCrLf)
objSelection.TypeText (SelContent)
'End If
'objSelection.Style = ActiveDocument.Styles("標題 3")
objSelection.TypeParagraph
objSelection.TypeParagraph
objSelection.TypeParagraph
objSelection.TypeParagraph
'Debug.Print i & " " & rs("DiscussID")
rs.MoveNext
'If i > 50 Then
' GoTo lab:
'End If
End If
Wend
lab:
'最後插入目錄
objSelection.HomeKey Unit:=wdStory, Extend:=wdMove '移到最前方
'產生目錄(這個部分 從WORD 錄製巨集後，複製過來時要修改一些參數，例如 With Newdoc、 objSelection.Range )
With Newdoc
.TablesOfContents.Add Range:=objSelection.Range, RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=2, IncludePageNumbers:=True, AddedStyles:="", _
UseHyperlinks:=True, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
True
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With
'修改滑鼠游標
'Me.MousePointer = vbNormal
SeparatePageFileCount = SeparatePageFileCount + 1
Fn = Year(Date) - 1911 & "-" & Month(Date) & "-" & Day(Date) & " [ 筆數 " & (i - SeparatePage * PerItem) & "-" & (i - 1) & " ]文章" & Right("0" & SeparatePageFileCount, 2) & ".doc"
Newdoc.SaveAs ThisWorkbook.Path & "\" & Fn
'清除與WORD物件的連結。
Newdoc.Close
Myword.Quit
Set Newdoc = Nothing
Set Myword = Nothing
MsgBox "請在程式所在目錄之下尋找剛才所建立的WORD檔案！" & vbCrLf & "檔名：" & Fn
MsgBox "完成! 耗時 " & DateDiff("s", StartTime, Now) & "秒"
注意，在處理多個檔案時，Newdoc.Close、Myword.Quit會減少記憶體的耗用!很重要，以免當機。
沒有留言:
張貼留言