สวัสดีทุกท่านผมต้องการความช่วยเหลือ เกี่ยวกับการเขียนโค๊ด VBA ในการสั่งพิมพ์ หัวกระดาษทุกแผ่น

[SuminO]

สวัสดีทุกท่านผมต้องการความช่วยเหลือ เกี่ยวกับการเขียนโค๊ด VBA ในการสั่งพิมพ์ หัวกระดาษทุกแผ่น
แต่ปัญหาที่ผมเจอ คือ
เมื่อ ขนาด เท่า A4 มันไม่ตัดขึ้นแผ่นใหม่ให้
และหัวกระดาษไม่แสดงแผ่นใหม่

และมีคำว่า รหัสลูกค้า :
ชื่อลูกค้า :
ที่อยู่ลูกค้า :

โทรศัพท์ :


แทรกตรงกลาง

Code: Select all

Sub PreviewWithHeaderFooter()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("ฟอร์ม")
    
    With ws.PageSetup
        ' ตั้งค่ากระดาษ A4
        .PaperSize = xlPaperA4
        .Orientation = xlPortrait
        
        ' ระยะขอบ
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.3)
        .RightMargin = Application.InchesToPoints(0.3)
        
        ' แถวหัวคอลัมน์ (A9) ซ้ำทุกหน้า
        .PrintTitleRows = "$9:$9"
        .PrintTitleColumns = ""
        
        ' ปรับขนาดการพิมพ์
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        
        ' ปิด gridlines
        .PrintGridlines = False
        
        ' ใส่ข้อความหัวกระดาษจากเซลล์ A1:A7 รวมกัน
        Dim headerText As String
        Dim i As Long
        For i = 1 To 7
            headerText = headerText & ws.Cells(i, 1).Text & vbCrLf
        Next i
        
        .CenterHeader = headerText
    End With

    ' แสดงตัวอย่างก่อนพิมพ์
    ws.Range("A1:S96").PrintPreview

End Sub

[snasui]

ลบ Custom Header ทิ้งตามภาพครับ

[SuminO]

ลบออกแล้วแต่มันยังไปกำหนดใหม่ใน Header เหมือนเดิมครับ
แล้วส่วนท้ายก็ให้แสดงเริ่มต้นแต่หน้าแรกเลย

[SuminO]

แก้หายแล้วแต่อยากให้ แสดง Footer แสดงตั้งแต่หน้าแรกครับ

[snasui]

ต้องการแสดงอะไรใน Footer ลองอธิบาย หากมีภาพช่วยแนบมาด้วยครับ

[SuminO]

ต้องการจากช่วง A87:S96 ครับตามภาพ
ที่ผมทำไว้มันแสดงแต่แผ่นสุดท้าย

[snasui]

การทำ Footer ตามภาพที่แนบมานั้นจะต้องใช้เทคนิคจับเป็นภาพ, Save แล้วแนบไว้ใน Custom Footer

การทำเช่นนี้จะต้องมั่นใจว่าหากมีการ Link ข้อมูลมาแสดง ก่อนจับภาพไปใช้เป็น Footer ข้อมูลต้องมีการ Update เรียบร้อยแล้ว

ลองทำมาเองก่อนด้วย VBA ตามที่แนะนำไปด้านบน ติดแล้วค่อยถามกันต่อครับ

[SuminO]

ผมพยายามแล้วครับไปไม่ถูกจริง ๆ
รบกวนด้วยครับงมมา 3 วันแล้ว

Code: Select all

Sub PrintFormSheet()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("ฟอร์ม")

    Dim headerRange As Range
    Dim contentRange As Range
    Dim footerRange As Range
    Set headerRange = ws.Range("A1:S9")
    Set contentRange = ws.Range("A10:S86")
    Set footerRange = ws.Range("U10:AM19")

    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=100, Top:=100, Width:=footerRange.Width, Height:=footerRange.Height)

    footerRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    chartObj.Chart.Paste

    Dim imgPath As String
    imgPath = Environ$("TEMP") & "\footer_temp.png"
    chartObj.Chart.Export Filename:=imgPath, FilterName:="PNG"
    chartObj.Delete

    With ws.PageSetup
        .PrintArea = headerRange.Address & "," & contentRange.Address
        .PaperSize = xlPaperA4
        .Orientation = xlPortrait
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)

        .PrintTitleRows = "$1:$9"
        .PrintTitleColumns = ""
        .CenterFooterPicture.Filename = imgPath
        .CenterFooter = "&G"

        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
    ws.ResetAllPageBreaks
    Dim i As Long
    For i = 40 To 86 Step 40
        ws.HPageBreaks.Add Before:=ws.Rows(i + 10)
    Next i
    ws.PrintPreview
End Sub

[snasui]

ไฟล์ที่แนบมาสามารถแสดง Footer ได้แล้ว ไม่ทราบว่ามีปัญหาอะไร กรุณาแจ้งมาด้วยจะได้เข้าใจตรงกันครับ

[SuminO]

ผมลองใช้ช่วง U10:AM19 เป็นภาพส่วนท้ายแล้ว มันแสดงทุกหน้าได้ตามต้องการ ซึ่งดีมากครับ
แต่ภาพที่แสดงออกมามีมีช่องสี่เหลี่ยมสีขาวด้านซ้าย ทำให้ดูไม่เรียบร้อย

รบกวนช่วยแนะนำหน่อยได้ไหมครับว่าจะปรับภาพยังไงให้ พอดีขอบ และ ไม่มีขอบขาวเกิน
ขอบคุณล่วงหน้ามาก ๆ เลยครับ

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub PrintFormSheet()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("¿ÍÃìÁ")

    Dim headerRange As Range
    Dim contentRange As Range
    Dim footerRange As Range
    Set headerRange = ws.Range("A1:S9")
    Set contentRange = ws.Range("A10:S86")
    Set footerRange = ws.Range("U10:AM19")

    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=600, Top:=500, Width:=footerRange.Width - 50, Height:=footerRange.Height + 20)

    footerRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    chartObj.Chart.Paste

    Dim imgPath As String

    imgPath = Environ$("TEMP") & "\footer_temp.png"
    chartObj.Chart.Export Filename:=imgPath, FilterName:="PNG"
    chartObj.Delete

    With ws.PageSetup
        .PrintArea = headerRange.Address & "," & contentRange.Address
        .PaperSize = xlPaperA4
        .Orientation = xlPortrait
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)

        .PrintTitleRows = "$1:$9"
        .PrintTitleColumns = ""
        .CenterFooterPicture.Filename = imgPath
        .CenterFooter = "&G"

        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
    ws.ResetAllPageBreaks
    Dim i As Long
    For i = 10 To 86 Step 18
        ws.HPageBreaks.Add Before:=ws.Rows(i + 18)
    Next i
    ws.PrintPreview
End Sub

[SuminO]

ขอบคุณมากๆครับ