clsexport.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 = "Export"
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_FileName As String
Private m_frmExport As frmPrintExport
Private m_pBitmap As IPictureDisp

Private Const VK_CONTROL = &H11
Private Declare Function GetKeyState% Lib "user32" (ByVal nKey%)

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


Private Sub Class_Initialize()
  On Error GoTo ErrorHandler

  Set m_frmExport = New frmPrintExport
  Set m_pBitmap = LoadResPicture("Export", 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_frmExport
  Set m_frmExport = 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

  ICommand_Enabled = Not (m_pHook.ActiveView Is Nothing)

  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_Export"

  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 = "Export"

  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 = "Export"

  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 = "Exports rectangle or screen (single click) to file"

  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 esriCore.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_frmExport.dlgCommon.Filter = "JPEG Files (*.jpg) | *.jpg|PDF Files (*.pdf) |*.pdf|BMP Files (*.bmp) |*.bmp" '|TIFF Files (*.tif) | *.tif"
  m_frmExport.dlgCommon.FilterIndex = 4
  m_frmExport.dlgCommon.DialogTitle = "Enter Export File Name"
  m_frmExport.dlgCommon.FileName = ""
  m_frmExport.dlgCommon.InitDir = "C:\Temp\"
  m_frmExport.dlgCommon.CancelError = False
  m_frmExport.dlgCommon.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt
  m_frmExport.dlgCommon.ShowSave
        
  If m_frmExport.dlgCommon.FileName = "" Then
    Exit Sub
  Else
    m_FileName = m_frmExport.dlgCommon.FileName
  End If

  ExportToFile

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


Private Sub ExportToFile()
  On Error GoTo ErrorHandler

  Dim pExporter As esriCore.IExporter
  Dim pDriverBounds As esriCore.IEnvelope
  Dim drvResolution As Long
  Dim screenResolution As Long
  Dim deviceRECT As tagRECT
  Dim userRECT As tagRECT
  Dim pCancel As esriCore.ITrackCancel
  
  If (Len(m_FileName) < 5) Then
    Beep
    MsgBox "No valid file name has been specified.", vbExclamation + vbOKOnly, "Filename Missing"
    Exit Sub
  End If
  
  Dim pActiveView As esriCore.IActiveView
  Set pActiveView = m_pHook.ActiveView
  screenResolution = pActiveView.ScreenDisplay.DisplayTransformation.Resolution
  drvResolution = screenResolution
  
  
  ' cocreate the appropriate filter
  Select Case Right(m_FileName, 3)
    Case "jpg"
      Set pExporter = New JpegExporter
      pExporter.Resolution = drvResolution
    Case "pdf"
      Set pExporter = New PDFExporter
      pExporter.Resolution = drvResolution
    Case "bmp"
      Set pExporter = New DibExporter
    'Case "tif"
    '  Set pExporter = New TiffExporter
    '  pExporter.Resolution = drvResolution
  End Select
  
  If (pExporter Is Nothing) Then
    Beep
    MsgBox "An unrecognised graphics format has been selected", vbExclamation + vbOKOnly, "Upsupported Format"
    Exit Sub
  End If
  

  
  pExporter.ExportFileName = m_FileName
  
 
  deviceRECT = pActiveView.ScreenDisplay.DisplayTransformation.DeviceFrame
  userRECT.Top = 0
  userRECT.Left = 0
  userRECT.Right = ConvertMapUnitsToPixels(pActiveView.Extent.Width)
  userRECT.bottom = ConvertMapUnitsToPixels(pActiveView.Extent.Height)
  
  ' We must calculate the size of the user specified Rectangle in Device units
  ' Hence convert width and height
  Set pDriverBounds = New Envelope
  pDriverBounds.PutCoords userRECT.Left, _
                          userRECT.bottom, _
                          userRECT.Right, _
                          userRECT.Top
  pExporter.PixelBounds = pDriverBounds
  Set pCancel = New CancelTracker
  
  pActiveView.Output pExporter.StartExporting, screenResolution, userRECT, pActiveView.Extent, pCancel
  pExporter.FinishExporting


  Exit Sub
ErrorHandler:
  HandleError False, "ExportToFile " & 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 esriCore.IDisplayTransformation
  Dim deviceRECT As tagRECT
  Dim pEnv As esriCore.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 esriCore.IActiveView
  Set pActiveView = m_pHook.ActiveView
  Set pDT = pActiveView.ScreenDisplay.DisplayTransformation
  deviceRECT = pDT.DeviceFrame
  pixelExtent = deviceRECT.Right - deviceRECT.Left
  Set pEnv = pDT.VisibleBounds
  
  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