การทำจดหมายเวียน (Mail Merge) ด้วย MS Visual Basic 6

Option Explicit

' เปิดไฟล์ Document
Dim oDocFile As String

' ตั้งค่า Path ให้มันถูกต้อง
Dim ApplicationPath As String

' Microsoft Word 11.0 Object library
Dim WordApp As Word.Application

' WinAPI สำหรับการคัดลอกไฟล์ข้อมูล (Copy File)
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) _
  As Long

' ===============================================
' ฟังค์ชั่นที่ใช้เรียก API ในการคัดลอกไฟล์
Private Function APIFileCopy ( _
    Source As String, _
    Destination As String, _
    Optional FailIfDestExists As Boolean _
    ) As Boolean

    Dim lRet As Long
    lRet = CopyFile(Source, Destination, FailIfDestExists)
    ' หากว่า lRet = 0 แสดงว่าเกิดข้อผิดพลาดน่ะครับ ... พี่น้อง
    APIFileCopy = (lRet > 0)

End Function
' ===============================================

' เหตุการณ์ หรือ โปรแกรมย่อยในการเปิดไฟล์ต้นแบบ (Template)
Private Sub cmdOpenDoc_Click()
'On Error Resume Next
On Error GoTo ErrHandler
    
    ' เปิดไฟล์ MS Word
    oDocFile = Trim(txtTemplate.Text) '""
    dlgOpenDoc.FileName = ""
    dlgOpenDoc.InitDir = App.Path
    ' อันนี้ไปดูรายละเอียดเพิ่มเติมจาก MSDN ได้เลยครับ ... พี่น้อง
    dlgOpenDoc.Flags = cdlOFNHideReadOnly + _
                                                cdlOFNOverwritePrompt + _
                                                cdlOFNPathMustExist + _
                                                cdlOFNShareAware
    dlgOpenDoc.DialogTitle = "เลือกไฟล์ Microsoft Word ที่เป็นไฟล์ต้นฉบับ (Template)"
    dlgOpenDoc.Filter = "Microsoft Word (*.doc) | *.doc" ' แสดงผลเฉพาะ MS Word Document
    dlgOpenDoc.CancelError = True ' ไม่สนใจ Error ใดๆ
    dlgOpenDoc.ShowOpen
    dlgOpenDoc.DefaultExt = "*.doc" ' ตั้งค่า MS Word Document เป็น Default
    
    oDocFile = dlgOpenDoc.FileName
    If oDocFile <> "" Then  txtTemplate.Text = oDocFile

ExitProc:
    Exit Sub

ErrHandler:
    ' Error หมายเลข 32755 คือ ผู้ใช้งานกดปุ่ม Cancel เพื่อยกเลิกการเปิดไฟล์
    ' บรรทัด If ... นี้ หมายความว่าไม่ต้องแสดง Error ที่เกิดขึ้น ... จบออกจาก Sub Program ไปเลย
    If Err.Number = 32755 Then Resume ExitProc
    
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    ' หากสั่ง Resume เฉยๆ มันจะไปทำงานบรรทัดต่อจากที่มันเกิด Error น่ะครับ
    Resume ExitProc
    
End Sub

' โปรแกรมย่อยที่ใช้ในการพิมพ์จดหมายเวียน (Mail Merge)
Private Sub cmdMailMerge_Click()
Dim ConnStr As String
Dim Statement As String
Dim FileTemp As String
Dim FileSaveAs As String

'On Error Resume Next
On Error GoTo ErrHandler
    
    If Trim(txtTemplate.Text) = "" Or Len(Trim(txtTemplate.Text)) = 0 Then
        MsgBox "กรุณาเลือกไฟล์ต้นแบบ (Template) ในการทำจดหมายเวียนให้เรียบร้อยก่อนด้วย.", _
                        vbOKOnly + vbExclamation, "รายงานความผิดพลาด"
        Exit Sub
    End If


    ' ข้อมูลในการพิมพ์ ... กรณีนำไปใช้งานจริง ควรทำ Query เพื่อเลือกเฉพาะรายการที่ต้องการ
    Statement = "SELECT * FROM tblCustomer ORDER BY CustomerPK "

    ' สร้างไฟล์ชั่วคราว และกำหนดรูปแบบ เช่น Temp-วันเดือนปี-ชั่วโมงนาทีวินาที
    ' ที่ต้องสร้างไฟล์นี้ก็เพราะต้องป้องกันความผิดพลาด ที่อาจจะมีผลกระทบกับไฟล์ต้นแบบ
    ' พี่น้อง ... อยากได้รูปแบบไหนก็กำหนดเอาเองตามใจชอบของท่านเถิดครับ
    FileTemp = "Temp-" & Format(Date, "ddmmyyyy") & "-" & Format(Time, "hhmmss") & ".Doc"

    Set WordApp = New Word.Application
    ' เริ่มการติดต่อกับ Word
    WordApp.Application.Visible = True
    
    ' คัดลอกไฟล์ต้นแบบ หรือ ต้นฉบับ ไปยังไฟล์ชั่วคราวที่ต้องการแสดงผล
    Call APIFileCopy(txtTemplate, ApplicationPath & FileTemp)
	

MS Word Document Template
    
    ' เปิด Document Template (ไฟล์ MS Word ต้นแบบ)
    WordApp.Documents.Open ApplicationPath & FileTemp

    ' กำหนดไฟล์ฐานข้อมูล
    ConnStr = ApplicationPath & "DataBase.MDB"
    
    ' ให้ MS Word ติดต่อกับฐานข้อมูล พร้อมกับระบุด้วยว่าจะทำจดหมายเวียน (Mail Merge)
    With WordApp.ActiveDocument.MailMerge
        .MainDocumentType = wdNotAMergeDocument
        .MainDocumentType = wdFormLetters
        
        ' รูปแบบการเชื่อมต่อไฟล์ฐานข้อมูล ... ยกมาให้ครบชุดเผื่อเอาไว้ใช้งานอื่นกันไปเลย ... เหอๆๆๆๆ
        .OpenDataSource Name:=ConnStr, SQLStatement:=Statement, _
            ConfirmConversions:=False, ReadOnly:=True, LinkToSource:=True, _
            AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
            WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
            Format:=wdOpenFormatAuto, SQLStatement1:="", _
            OpenExclusive:=True, SubType:=wdMergeSubTypeAccess
            
        ' ส่งข้อมูลออกไปให้ MS Word
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        
        ' ไม่ต้องหยุด ให้แสดงผลไปให้หมดเลย
        .Execute Pause:=False
    End With
	

เมื่อสั่ง Run เพื่อให้ Mail Merge ทำงาน

    ' เตรียมตั้งชื่อไฟล์เอกสารใหม่ เพื่อคัดลอก FileTemp ไปยังไฟล์ใหม่
    ' หากไม่ใช้วิธีการนี้ผมพบว่าจะทำให้เกิด Run-Time Error 5174 หรือ ไม่สามารถเปิดไฟล์ Mail Merge ได้เลย
    FileSaveAs = "MailMerge"
    FileSaveAs = ApplicationPath & FileSaveAs & "-" & _
                                Format(Date, "ddmmyyyy") & "-" & _
                                Format(Time, "hhmmss") & ".doc"
	

    
    ' บันทึกไฟล์เป็น (Save As) ให้ไฟล์เอกสารใหม่
    ' นั่นคือ การเปลี่ยนชื่อไฟล์จาก ...
    ' Temp-วันเดือนปี-ชั่วโมงนาทีวินาที (หรือ Documents.item(1)) ... มาเป็น
    ' MailMerge-วันเดือนปี-ชั่วโมงนาทีวินาที  (หรือ Documents.item(2))
    WordApp.Documents.Item(1).SaveAs FileSaveAs
    
    ' สั่งปิดไฟล์ให้หมด และไม่ต้อง Save As ไฟล์เอกสาร ...
    ' ไฟล์จะปิดเองโดยอัตโนมัติ และไม่ต้องมาถามให้กวนใจอีกว่าจะ Save หรือไม่
    ' หากไม่สั่งปิดจะเกิด Run-Time Error 70 หรือ Permission Denied
    WordApp.Documents.Item(2).Close False    ' ชื่อไฟล์: MailMerge-วันเดือนปี-ชั่วโมงนาทีวินาที
    WordApp.Documents.Item(1).Close False    ' ชื่อไฟล์: Temp-วันเดือนปี-ชั่วโมงนาทีวินาที
	

    
    ' แสดงผล MS Word ใหม่อีกครั้ง ...
    WordApp.Application.Visible = True
    ' เปิด MS Word (ไฟล์ใหม่ที่บันทึก)
    WordApp.Documents.Open FileSaveAs

ExitProc:
    ' คืนค่าหน่วยความจำให้กับระบบปฏิบัติการ
    Set WordApp = Nothing

    ' ลบไฟล์ชั่วคราว (Temporary) ออกไปด้วยคำสั่ง Kill
    If Dir$(ApplicationPath & FileTemp) <> "" Then Kill ApplicationPath & FileTemp
    
    'MsgBox "ทำการสร้างจดหมายเวียน (Mail Merge) เรียบร้อยแล้ว." & vbCrLf & vbCrLf & _
                    "ชื่อไฟล์ : " & FileSaveAs, vbOKOnly + vbInformation, "รายงานสถานะ"
    End ' หรือ Exit Sub

ErrHandler:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    Resume ExitProc
    
End Sub

Private Sub Form_Load()
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    txtTemplate.Text = ""
    
    ' ================= ตั้งค่า Path ให้มันถูกต้อง ===============
    ' หากเป็น Root Directory มันจะมีเครื่องหมาย Back Slash (\) มาด้วย เช่น C:\
    ' หากไม่ใช่ Root Directory ก็จะไม่มีเครื่องหมาย \ ... เช่น C:\Program Files
    ' ตรวจสอบค่าทางขวามือสุดว่ามีเครื่องหมาย Back Slash หรือไม่ ... หากไม่มีก็ให้เพิ่มเข้าไปต่อท้าย
    If Right$(App.Path, 1) <> "\" Then
        ApplicationPath = App.Path & "\"
    Else
        ApplicationPath = App.Path
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmMailMerge = Nothing
    End
End Sub