打印.txt

很好用的通用库存管理程序

' =======================================================================
'
'    模块：所有与打印有关的函数、过程、声明等
'
' =======================================================================

Private Declare Function GetProfileString Lib "KERNEL32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long

'打印变量
Public fromPage, toPage, NumCopies, All_page As Boolean, Cancel As Boolean
Public sysPrinter As String

'水晶报表
Public CRXApplication As New CRAXDRT.Application
Public CRXReport As New CRAXDRT.Report

    

Public Sub Call_Printer(maxNumber As Integer)
    On Error GoTo ErrHandler
    Dim PrintDlg As PrinterDlg
    Dim NewPrinterName As String
    Dim objPrinter As Printer
    Dim strsetting As String

    ' 将打印机指向系统设置
    NewPrinterName = getDefaPrinter()
    If Printer.DeviceName <> NewPrinterName Then
        For Each objPrinter In Printers
            If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                Set Printer = objPrinter
            End If
        Next
    End If

    Set PrintDlg = New PrinterDlg

    With PrintDlg
         .Flags = cdlPDDisablePrintToFile + cdlPDNoSelection
         .fromPage = 1
         .Min = 1
         .Max = maxNumber
         .toPage = .Max
         .Copies = 1
    End With

    Printer.TrackDefault = False

    ' 激活打印对话框
    If Not PrintDlg.ShowPrinter(fMainForm.Text1.hwnd) Then
        Cancel = True
        Exit Sub
    End If


    ' 指向选择的打印机，已经移到PrinterDlg处理
    'NewPrinterName = UCase$(PrintDlg.PrinterName)
    'If printer.DeviceName <> NewPrinterName Then
    '    For Each objPrinter In Printers
    '        If UCase$(objPrinter.DeviceName) = NewPrinterName Then
    '            Set printer = objPrinter
    '        End If
    '    Next
    'End If

    ' 给变量赋值
    If PrintDlg.Flags = 524292 Then
        All_page = True
    Else
        All_page = False
    End If

    fromPage = PrintDlg.fromPage
    toPage = PrintDlg.toPage
    NumCopies = PrintDlg.Copies

    Cancel = False

    Exit Sub

ErrHandler:
    Cancel = True
    Exit Sub
End Sub


'初始化报表参数
Public Function getReportSetting(myRpt As CRAXDRT.Report, myrs As String) As Boolean
    On Error GoTo errMessage

    Dim rs As ADODB.Recordset, print_flag As Boolean
    Set rs = New ADODB.Recordset
    rs.Open myrs, lConnection, adOpenKeyset
    If rs.RecordCount <= 0 Then Exit Function

    sysPrinter = rs.Fields("printer_default")

    '判断打印机设置
    Dim x As Printer
    For Each x In Printers
        If x.DeviceName = sysPrinter Then
            If Not IsNull(sysPrinter) Then myRpt.SelectPrinter rs.Fields("DriverName"), sysPrinter, rs.Fields("PortName")

            '设定为系统缺省打印机，不必再设置报表的打印机。
            Set Printer = x
            print_flag = True
            ' 终止查找打印机。
            Exit For
        End If
    Next x

    If print_flag = False Then
        Dim reSetting As Integer
        reSetting = MsgBox("系统中没有您设置的打印机，更改打印机设置吗？", vbExclamation + vbYesNo, "提示")
        If reSetting = 6 Then
            frmPrinterSetup.Show
        End If
    End If

    If Not IsNull(rs.Fields("paperSize")) Then myRpt.PaperSize = rs.Fields("paperSize")

    If Not IsNull(rs.Fields("Margin_Top")) Then myRpt.TopMargin = rs.Fields("Margin_Top")
    If Not IsNull(rs.Fields("lpOrientation")) Then myRpt.PaperOrientation = rs.Fields("lpOrientation")
    If Not IsNull(rs.Fields("Margin_Bottom")) Then myRpt.BottomMargin = rs.Fields("Margin_Bottom")
    If Not IsNull(rs.Fields("Margin_Left")) Then myRpt.LeftMargin = rs.Fields("Margin_Left")
    If Not IsNull(rs.Fields("Margin_Right")) Then myRpt.RightMargin = rs.Fields("Margin_Right")
    
    p1 = rs.Fields("PaperHeight")
    
    Dim GH As Integer, RH As Integer, RF As Integer
    GH = 0
    Dim i As Integer
    For i = 1 To myRpt.Sections.Count
        If myRpt.Sections(i).Name = "GroupHeaderSection1" Then
            GH = myRpt.Sections.Item("GH").Height
            Exit For
        End If
    Next i

    RH = myRpt.Sections.Item("RH").Height
    If myRpt.Sections.Item("RH").Suppress = True Then
       RH = 0
    End If

    RF = myRpt.Sections.Item("RF").Height
    If myRpt.Sections.Item("RH").Suppress = True Then
        RF = 0
    End If
    
    h1 = RH + myRpt.Sections.Item("PH").Height + GH

    f1 = myRpt.Sections.Item("PF").Height + RF

    p = Int((p1 - h1 - f1 - myRpt.TopMargin - myRpt.BottomMargin) / myRpt.Sections.Item("D").Height)

    For i = 1 To myRpt.FormulaFields.Count
        If myRpt.FormulaFields(i).Name = "{@page_count}" Then
            myRpt.FormulaFields(i).Text = p
        End If
    Next i
    getReportSetting = True
    Exit Function

errMessage:
    If Err <> 0 Then
        getReportSetting = False
        MsgBox Err.Description
    End If
End Function

'预览
Public Sub CRPreview(myForm_Name As String, mySQL As String, i As Integer)
    frmPreview.active_form = myForm_Name
    frmPreview.mySQL = mySQL
    frmPreview.number = i
    frmPreview.CRViewer91.ReportSource = CRXReport
    frmPreview.CRViewer91.DisplayGroupTree = False
    frmPreview.CRViewer91.ViewReport
    Screen.MousePointer = vbNormal
End Sub

'打印
Public Sub CRPrint()
    Dim DGroup, Pnumber As Integer
    DGroup = Array()
    CRXReport.DisplayProgressDialog = False
    
    Pnumber = CRXReport.PageEngine.CreatePageGenerator(DGroup).Pages.Count

    Screen.MousePointer = vbNormal
    
    Call Call_Printer(Pnumber)

    If Cancel = True Then Exit Sub

    If All_page = True Then
        CRXReport.PrintOut False
    Else
        CRXReport.PrintOut False, CInt(NumCopies), , CInt(fromPage), CInt(toPage)
    End If
    Set CRXReport = Nothing
End Sub

'初始化报表数据
Public Function rpt_ini(actForm_Name As String, mySQL As String, Rpt_Number As Integer) As Boolean
    On Error GoTo myErr
    Screen.MousePointer = vbHourglass

    Dim cmdText As String, rpt_File As String, File_Name As String, SqlString As String

    If actForm_Name = "frmJit206" Then
        cmdText = "SELECT * FROM jit2_line_schedule_v"
        rpt_File = "rptJit206_1.rpt"
        File_Name = "rptJit206_1"
        SqlString = "SELECT * FROM jit2_line_schedule_v WHERE " & mySQL & "  ORDER BY seq_no"
    End If

    If actForm_Name = "frmJit305" And Rpt_Number = 1 Then
        cmdText = "SELECT * FROM jit2_trans_detail_vs"
        rpt_File = "rptJit305_s.rpt"
        File_Name = "rptJit305_s"
        SqlString = "SELECT * FROM jit2_trans_detail_vs WHERE " & mySQL & " and bill_status = 'R' ORDER BY bill"
    End If

    If actForm_Name = "frmJit305" And Rpt_Number = 2 Then
        cmdText = "SELECT * FROM jit2_trans_detail_vm"
        rpt_File = "rptJit305_m.rpt"
        File_Name = "rptJit305_m"
        SqlString = "SELECT * FROM jit2_trans_detail_vm WHERE " & mySQL & " and bill_status = 'R' ORDER BY bill"
    End If

    Dim dataCmd1 As ADODB.Command
    Dim CRTable As CRAXDRT.DatabaseTable

    Set dataCmd1 = New ADODB.Command
    Set dataCmd1.ActiveConnection = oConnection
    dataCmd1.CommandType = adCmdText

    dataCmd1.CommandText = cmdText
    
    Set CRXReport = CRXApplication.OpenReport(App.Path & "\" & rpt_File, 1)

    For Each CRTable In CRXReport.Database.Tables
        With CRTable.ConnectionProperties
            .Item("data Source") = Server_Str
            .Item("User ID") = user_id
            .Item("password") = Pass_Word
            .Item("Initial Catalog") = Database_Str
        End With
    Next

    CRXReport.Database.AddADOCommand oConnection, dataCmd1

    If getReportSetting(CRXReport, "SELECT * FROM report_setting WHERE rptName='" & File_Name & "'") = False Then Screen.MousePointer = vbNormal: rpt_ini = False: Exit Function

    CRXReport.SQLQueryString = SqlString

    rpt_ini = True

    Exit Function

myErr:
    Screen.MousePointer = vbNormal
    MsgBox Err.Description
    rpt_ini = False
End Function

Private Function getDefaPrinter() As String
    Dim nRet As String
    Dim sRet As String

    sRet = Space(255)
    nRet = GetProfileString("windows", ByVal "device", "", sRet, Len(sRet))

    getDefaPrinter = Left(sRet, InStr(sRet, ",") - 1)
End Function