Excel Print

最新推荐文章于 2024-09-07 23:17:41 发布

xubo8219

最新推荐文章于 2024-09-07 23:17:41 发布

阅读量716

点赞数

本文链接：https://blog.csdn.net/xubo8219/article/details/3135121

版权

Private Sub 印刷_Click()

On Error GoTo Err_Handler

    'sheetを作る
    Dim xl As Object
    Set xl = CreateObject("Excel.Sheet")

    Dim strSelsql As String
    Dim intNo As Integer

    Dim db As DAO.Database
    Dim RS As DAO.Recordset
    Set db = CurrentDb

    strSelsql = "SELECT * FROM ***"
    Set RS = db.OpenRecordset(strSelsql, dbOpenDynaset)

    'データの個数を計算する
    intNo = RS.RecordCount

'    結果が0件の場合は処理終了
    If intNo = 0 Then
        MsgBox "該当データがありません!"
        Exit Sub
    End If

'    sheetが見える
'    xl.Application.Visible = True

'    文字列を列幅で折り返す
    xl.Worksheets(1).Range("A:Q").WrapText = True

'    セルの内容　左詰め
    xl.Worksheets(1).Range("A:Q").HorizontalAlignment = xlHAlignLeft

'       横紙
    xl.Worksheets(1).PageSetup.Orientation = xlLandscape
'       印刷範囲
    xl.Worksheets(1).PageSetup.PrintArea = "A1:Q10"
    xl.Worksheets(1).PageSetup.Zoom = False
'       横を1ページに収める
    xl.Worksheets(1).PageSetup.FitToPagesTall = 1
'       縦を1ページに収める
    xl.Worksheets(1).PageSetup.FitToPagesWide = 1
'       印刷紙のsize
    xl.Worksheets(1).PageSetup.PaperSize = xlPaperA4

'       A～Q列目のセル幅をセル内容にあわせて調整する
    xl.Worksheets(1).Columns("A:Q").AutoFit

'    文字を縮小して全体を表示する
'    xl.Worksheets(1).Range("A1:Q6").ShrinkToFit = True

'       罫線
    xl.Worksheets(1).Range("A1:Q6").Borders.LineStyle = xlContinuous   '実線

'       一覧
'    ActiveWindow.View = xlPageBreakPreview

'       sheet名前
    xl.Worksheets(1).Name = "売上案件一覧"

'    列の幅を設定する
    xl.Worksheets(1).Columns(1).ColumnWidth = 15
    xl.Worksheets(1).Columns(2).ColumnWidth = 15
    xl.Worksheets(1).Columns(3).ColumnWidth = 15
    xl.Worksheets(1).Columns(6).ColumnWidth = 15
    xl.Worksheets(1).Columns(7).ColumnWidth = 15

'    セルの内容を書き込む
    xl.Worksheets(1).Range("A1").Value = "**"
    xl.Worksheets(1).Range("A1:A2").Merge

    xl.Worksheets(1).Range("B1").Value = "**"
    xl.Worksheets(1).Range("B1:B2").Merge

    xl.Worksheets(1).Range("C1").Value = "**"
    xl.Worksheets(1).Range("C1:C2").Merge

    xl.Worksheets(1).Range("D1").Value = "**"
    xl.Worksheets(1).Range("D1:D2").Merge

    xl.Worksheets(1).Range("E1").Value = "**"
    xl.Worksheets(1).Range("E1:E2").Merge

    xl.Worksheets(1).Range("F1").Value = "**"
    xl.Worksheets(1).Range("F1:F2").Merge

    xl.Worksheets(1).Range("G1").Value = "**"
    xl.Worksheets(1).Range("G1:G2").Merge

    xl.Worksheets(1).Range("H1").Value = "**"
    xl.Worksheets(1).Range("H1:H2").Merge

    xl.Worksheets(1).Range("I1").Value = "**"
    xl.Worksheets(1).Range("I1:I2").Merge

    xl.Worksheets(1).Range("J1").Value = "**"
    xl.Worksheets(1).Range("J1:J2").Merge

    xl.Worksheets(1).Range("K1").Value = "**"
    xl.Worksheets(1).Range("K1:K2").Merge

    xl.Worksheets(1).Range("L1").Value = "**"
    xl.Worksheets(1).Range("L1:L2").Merge

'    セル結合
    xl.Worksheets(1).Range("M1").Value = "**"
    xl.Worksheets(1).Range("M1:P1").Merge
    xl.Worksheets(1).Range("M1:P1").HorizontalAlignment = xlHAlignCenter

    xl.Worksheets(1).Range("M2").Value = "**"
    xl.Worksheets(1).Range("N2").Value = "**)"
    xl.Worksheets(1).Range("O2").Value = "**"
    xl.Worksheets(1).Range("P2").Value = "**"

    xl.Worksheets(1).Range("Q1").Value = "**"
'    セル結合
    xl.Worksheets(1).Range("Q1:Q2").Merge


    Dim strCustomerDate As String
    Dim strHosterDate As String
    Dim intRow As Integer
    intRow = 2

    Do Until RS.EOF

        intRow = intRow + 1

        '    完了案件が色がグレーに添う

        If RS!完了Flag Then
            xl.Application.Cells(intRow, 1).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 2).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 3).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 4).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 5).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 6).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 7).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 8).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 9).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 10).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 11).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 12).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 13).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 14).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 15).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 16).Interior.ColorIndex = 15
            xl.Application.Cells(intRow, 17).Interior.ColorIndex = 15
        End If

        strCustomerDate = Format(RS!顧客予定納期, "yyyy年mm月dd日")
        strHosterDate = Format(RS!営業売上, "yyyy年mm月dd日")
        xl.Application.Cells(intRow, 1).Value = strCustomerDate
        '        xl.Application.Cells(intRow, 1).Interior.ColorIndex = 15
        xl.Application.Cells(intRow, 2).Value = strHosterDate

        xl.Application.Cells(intRow, 17).Value = RS!総粗利 & "円"
        intNo = intNo + 1
        RS.MoveNext
    Loop

'    日付がエクセルファイル名に追加する
'    Dim Mystr
'    Mystr = Format(Now, "yyyy-mm-dd-Hmm")
'    Mystr = Mystr & "**"

' xl.SaveAs "d:/" & Mystr & ".xls"

'    xl.Application.ActiveWindow.View = xlPageBreakPreview
'    xl.Application.Visible = True
'    xl.Application.Quit

     '保存先を取得する
    strAddress = openFolder()

    MsgBox Len(strAddress)

    If Len(strAddress) = 0 Then Exit Sub

    MsgBox "Address:" & strAddress
    xl.SaveAs strAddress

    Set xl = Nothing

    RS.Close: Set RS = Nothing
    db.Close: Set db = Nothing

    MsgBox "Success !!  ^_^ "
    Exit Sub

Err_Handler:
    MsgBox Err.Number & " : " & Err.Description