clsprint.cls

ao开发指南的东西 源码 希望大家好好学习ao

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 1  'Persistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Print"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit


Private m_pHook As New hook
Private m_frmPrinter As frmPrintExport
Private m_pBitmap As IPictureDisp

Implements ICommand

' Constant used by the Error handler function - DO NOT REMOVE
Const c_ModuleFileName = "clsPrint.cls"


Private Sub Class_Initialize()
  On Error GoTo ErrorHandler

  Set m_frmPrinter = New frmPrintExport
  Set m_pBitmap = LoadResPicture("Print", vbResBitmap)


  Exit Sub
ErrorHandler:
  HandleError True, "Class_Initialize " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub

Private Sub Class_Terminate()
  On Error GoTo ErrorHandler

  Set m_pHook = Nothing
  
  Unload m_frmPrinter
  Set m_frmPrinter = Nothing


  Exit Sub
ErrorHandler:
  HandleError True, "Class_Terminate " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub

Private Property Get ICommand_Enabled() As Boolean
  On Error GoTo ErrorHandler

  If Not m_pHook.ActiveView Is Nothing Then
    ICommand_Enabled = True
  End If

  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Enabled " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Checked() As Boolean
  On Error GoTo ErrorHandler

  ICommand_Checked = False


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Checked " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Name() As String
  On Error GoTo ErrorHandler

  ICommand_Name = "Sample_File_Print"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Name " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property

Private Property Get ICommand_Caption() As String
  On Error GoTo ErrorHandler

  ICommand_Caption = "Print"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Caption " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Tooltip() As String
  On Error GoTo ErrorHandler

  ICommand_Tooltip = "Print"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Tooltip " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Message() As String
  On Error GoTo ErrorHandler

  ICommand_Message = "Prints rectangle or screen (single click)"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Message " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_HelpFile() As String
  On Error GoTo ErrorHandler

  ' TODO: Add your implementation here


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_HelpFile " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_HelpContextID() As Long
  On Error GoTo ErrorHandler

  ' TODO: Add your implementation here


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_HelpContextID " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE
  On Error GoTo ErrorHandler

  ICommand_Bitmap = m_pBitmap


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Bitmap " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Category() As String
  On Error GoTo ErrorHandler

  ICommand_Category = "Sample_File"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Category " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Sub ICommand_OnCreate(ByVal hook As Object)
  On Error GoTo ErrorHandler

  m_pHook.hook = hook


  Exit Sub
ErrorHandler:
  HandleError True, "ICommand_OnCreate " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Sub ICommand_OnClick()
  On Error GoTo ErrorHandler

  m_frmPrinter.Show vbModal
   
  If Not m_frmPrinter.UserCancelled Then
    PrintToPrinter
  End If
  Exit Sub
ErrorHandler:
  HandleError True, "ICommand_OnClick " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub

Private Function ConvertMapUnitsToPixels(RWUnits As Double) As Double
  On Error GoTo ErrorHandler

  Dim realWorldDisplayExtent As Double
  Dim pixelExtent As Long
  Dim sizeOfOnePixel As Double
  Dim pDT As esriDisplay.IDisplayTransformation
  Dim deviceRECT As tagRECT
  Dim pEnv As esriGeometry.IEnvelope
  
  
  ' Get the width of the display extents in Pixels
  ' and get the extent of the displayed data
  ' work out the size of one pixel and then return
  ' the pixels units passed in mulitplied by that value
  Dim pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pHook.ActiveView
  Set pDT = pActiveView.ScreenDisplay.DisplayTransformation
  deviceRECT = pDT.DeviceFrame
  pixelExtent = deviceRECT.Right - deviceRECT.Left
  Set pEnv = pDT.FittedBounds
  
  realWorldDisplayExtent = pEnv.Width
  sizeOfOnePixel = realWorldDisplayExtent / pixelExtent
  ConvertMapUnitsToPixels = RWUnits / sizeOfOnePixel


  Exit Function
ErrorHandler:
  HandleError False, "ConvertMapUnitsToPixels " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Function

Private Sub PrintToPrinter()
  On Error GoTo ErrorHandler

  Dim pPrinter As esriOutput.IPrinter
  Dim screenResolution As Long
  Dim userRECT As tagRECT
  Dim pDriverBounds As esriGeometry.IEnvelope
  Dim oPrinter As Object
  
  Set oPrinter = Printer
  
  If (oPrinter Is Nothing) Then
    Beep
    MsgBox "To plot the map you must have a printer installed", vbExclamation + vbOKOnly, "No Printer Installed"
    Exit Sub
  End If
  
  SetupPrinter oPrinter, pPrinter

  Dim pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pHook.ActiveView
  screenResolution = pActiveView.ScreenDisplay.DisplayTransformation.Resolution
  pPrinter.Resolution = screenResolution
  
  userRECT.Top = 0
  userRECT.Left = 0
  userRECT.Right = ConvertMapUnitsToPixels(pActiveView.Extent.Width)
  userRECT.bottom = ConvertMapUnitsToPixels(pActiveView.Extent.Height)
  
  Set pDriverBounds = New Envelope
  pDriverBounds.PutCoords userRECT.Left, _
                          userRECT.bottom, _
                          userRECT.Right, _
                          userRECT.Top
  pActiveView.Output pPrinter.StartPrinting(pDriverBounds, 0), screenResolution, userRECT, pActiveView.Extent, Nothing
  pPrinter.FinishPrinting


  Exit Sub
ErrorHandler:
  HandleError False, "PrintToPrinter " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub

Private Sub SetupPrinter(oPrinter As Object, pPrinter As esriOutput.IPrinter)
  On Error GoTo ErrorHandler

  Dim pPsPrinter As esriOutput.IPsPrinter
  Dim pPaper As esriOutput.IPaper
  Dim vbPrinter As Printer
  
  If (oPrinter Is Nothing) Then Exit Sub
  Set vbPrinter = oPrinter
  
  ' Build the Postscript printer object
  Set pPsPrinter = New PsPrinter
  Set pPrinter = pPsPrinter
  Set pPaper = New Paper
  
  pPaper.PrinterName = vbPrinter.DeviceName
  Set pPrinter.Paper = pPaper
  pPaper.Orientation = vbPrinter.Orientation


  Exit Sub
ErrorHandler:
  HandleError True, "SetupPrinter " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub