Attribute VB_Name = "modExportFromMapObject"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ExportFromMapObject.bas
'
'
' References:
' esriCarto.olb ESRI Carto Object Library
' esriDataSourcesFile.olb ESRI DataSourcesFile Object Library
' esriDisplay.olb ESRI Display Object Library
' esriGeometry.olb ESRI Geometry Object Library
' esriOutput.olb ESRI Output Object Library
' esriGeoDatabase.olb ESRI GeoDatabase Object Library
' esriSystem.olb ESRI System Object Library
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
' these Win32 API definitions will be used to read the display resolution
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
' global variable for license management
Public m_pAoInitialize As IAoInitialize
Sub Main()
' Because this is a stand-alone app, we'll need to manage
' our own license. Exit app if we can't get a valid license
If (InitializeLicense() = False) Then Exit Sub
ExportMap
ExportPageLayout
' Check the license back in.
m_pAoInitialize.Shutdown
End Sub
Private Sub ExportMap()
Dim pActiveView As IActiveView
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pFeatureWorkspace As IFeatureWorkspace
Dim pFeatureLayer As IFeatureLayer
Dim pMap As IMap
Dim pGeoFeatureLayer As IGeoFeatureLayer
Dim deviceFrameRect As tagRECT
Set pMap = New Map
Set pActiveView = pMap
' load a layer from shapefile
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile("C:\Program Files\ArcGIS\Bin\TemplateData\USA", 0)
Set pFeatureLayer = New FeatureLayer
Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass("states")
pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
pMap.AddLayer pFeatureLayer
Set pWorkspaceFactory = Nothing
Set pFeatureWorkspace = Nothing
Set pFeatureLayer = Nothing
' turn labeling on
Set pGeoFeatureLayer = pMap.Layer(0)
pGeoFeatureLayer.DisplayAnnotation = True
Set pGeoFeatureLayer = Nothing
' set a reference scale so the labels will be scaled to a reasonable size
pMap.ReferenceScale = 10000000
' because the Map view is not connected to a hWnd, we must explicitly
' change the Map's DeviceFrame dimensions from "0 x 0" to something
' larger. "800 x 600" should work well for our purposes here.
With deviceFrameRect
.Left = 0
.Right = 800
.Top = 0
.Bottom = 600
End With
pActiveView.ScreenDisplay.DisplayTransformation.DeviceFrame = deviceFrameRect
' export the map
Dim pExport As IExport
Dim iScreenResolution As Integer
Dim iOutputResolution As Integer
Dim exportRECT As tagRECT
Dim pPixelBoundsEnv As IEnvelope
Dim hdc As Long
Set pExport = New ExportPDF
pExport.ExportFileName = "c:\ExportMap.pdf"
Dim tmpDC As Long
tmpDC = GetDC(0)
iScreenResolution = GetDeviceCaps(tmpDC, 88) '88 is Win32 constant for LOGPIXELSX
ReleaseDC 0, tmpDC
iOutputResolution = 1200
pExport.Resolution = iOutputResolution
With exportRECT
.Left = pActiveView.ExportFrame.Left * (iOutputResolution / iScreenResolution)
.Top = pActiveView.ExportFrame.Top * (iOutputResolution / iScreenResolution)
.Right = pActiveView.ExportFrame.Right * (iOutputResolution / iScreenResolution)
.Bottom = pActiveView.ExportFrame.Bottom * (iOutputResolution / iScreenResolution)
End With
Set pPixelBoundsEnv = New Envelope
pPixelBoundsEnv.PutCoords exportRECT.Left, exportRECT.Top, exportRECT.Right, exportRECT.Bottom
pExport.PixelBounds = pPixelBoundsEnv
hdc = pExport.StartExporting
pActiveView.Output hdc, iOutputResolution, exportRECT, Nothing, Nothing
pExport.FinishExporting
Set pMap = Nothing
Set pActiveView = Nothing
Set pExport = Nothing
Set pPixelBoundsEnv = Nothing
End Sub
Private Sub ExportPageLayout()
Dim pActiveView As IActiveView
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pFeatureWorkspace As IFeatureWorkspace
Dim pFeatureLayer As IFeatureLayer
Dim pMap As IMap
Dim pGeoFeatureLayer As IGeoFeatureLayer
Dim deviceFrameRect As tagRECT
Dim pPageLayout As IPageLayout
Dim pMapFrame As IMapFrame
Dim pGraphicsContainer As IGraphicsContainer
Dim pMapElement As IElement
Dim pGeoExt As IGeometry
Dim pMapExt As IEnvelope
Set pPageLayout = New PageLayout
Set pActiveView = pPageLayout
' change the Page to Letter size, Landscape orientation
pPageLayout.Page.FormID = esriPageFormLetter
pPageLayout.Page.Orientation = 2
' add a 6.5 X 9 inch dataframe (Map object wrapped in a MapFrame)
' to the PageLayout
Set pGraphicsContainer = pPageLayout
Set pMap = New Map
Set pMapFrame = New MapFrame
Set pMapExt = New Envelope
pMapExt.XMin = 1
pMapExt.YMin = 1
pMapExt.XMax = 10
pMapExt.YMax = 7.5
Set pGeoExt = pMapExt
Set pMapFrame.Map = pMap
Set pMapElement = pMapFrame
pMapElement.Geometry = pGeoExt
pGraphicsContainer.AddElement pMapElement, 0
Set pGeoExt = Nothing
Set pMapFrame = Nothing
Set pMapElement = Nothing
Set pGraphicsContainer = Nothing
Set pPageLayout = Nothing
' load a layer from shapefile
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile("C:\Program Files\ArcGIS\Bin\TemplateData\USA", 0)
Set pFeatureLayer = New FeatureLayer
Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass("states")
pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
pMap.AddLayer pFeatureLayer
Set pWorkspaceFactory = Nothing
Set pFeatureWorkspace = Nothing
Set pFeatureLayer = Nothing
' turn labeling on
Set pGeoFeatureLayer = pMap.Layer(0)
pGeoFeatureLayer.DisplayAnnotation = True
Set pGeoFeatureLayer = Nothing
' set a reference scale so the labels will be scaled to a reasonable size
pMap.ReferenceScale = 10000000
Set pMap = Nothing
' because the PageLayout view is not connected to a hWnd, we must explicitly
' change the PageLayout's DeviceFrame dimensions from "0 x 0" to something
' larger. "800 x 600" should work well for our purposes here.
With deviceFrameRect
.Left = 0
.Right = 800
.Top = 0
.Bottom = 600
End With
pActiveView.ScreenDisplay.DisplayTransformation.DeviceFrame = deviceFrameRect
' export the map
Dim pExport As IExport
Dim iScreenResolution As Integer
Dim iOutputResolution As Integer
Dim exportRECT As tagRECT
Dim pPixelBoundsEnv As IEnvelope
Dim hdc As Long
Set pExport = New ExportPDF
pExport.ExportFileName = "c:\ExportPageLayout.pdf"
Dim tmpDC As Long
tmpDC = GetDC(0)
iScreenResolution = GetDeviceCaps(tmpDC, 88) '88 is Win32 LOGPIXELSX constant
ReleaseDC 0, tmpDC
iOutputResolution = 1200
pExport.Resolution = iOutputResolution
With exportRECT
.Left = pActiveView.ExportFrame.Left * (iOutputResolution / iScreenResolution)
.Top = pActiveView.ExportFrame.Top * (iOutputResolution / iScreenResolution)
.Right = pActiveView.ExportFrame.Right * (iOutputResolution / iScreenResolution)
.Bottom = pActiveView.ExportFrame.Bottom * (iOutputResolution / iScreenResolution)
End With
Set pPixelBoundsEnv = New Envelope
pPixelBoundsEnv.PutCoords exportRECT.Left, exportRECT.Top, exportRECT.Right, exportRECT.Bottom
pExport.PixelBounds = pPixelBoundsEnv
hdc = pExport.StartExporting
pActiveView.Output hdc, iOutputResolution, exportRECT, Nothing, Nothing
pExport.FinishExporting
Set pActiveView = Nothing
Set pExport = Nothing
Set pPixelBoundsEnv = Nothing
End Sub
Private Function InitializeLicense() As Boolean
Dim licenseStatus As esriLicenseStatus
Dim bSuccess As Boolean
bSuccess = True
'Check for an Engine License
licenseStatus = CheckOutLicenses(esriLicenseProductCodeEngine)
If (licenseStatus = esriLicenseNotLicensed) Then
'Next try Desktop ArcView
licenseStatus = CheckOutLicenses(esriLicenseProductCodeArcView)
End If
If (licenseStatus = esriLicenseNotLicensed) Then
MsgBox "You are not licensed to run this product"
bSuccess = False
ElseIf (licenseStatus = esriLicenseUnavailable) Then
MsgBox "There are insufficient licenses to run"
bSuccess = False
ElseIf (licenseStatus = esriLicenseFailure) Then
MsgBox "Unexpected license failure. Please contact your administrator"
bSuccess = False
End If
InitializeLicense = bSuccess
End Function
Private Function CheckOutLicenses(productCode As esriLicenseProductCode) As esriLicenseStatus
Dim licenseStatus As esriLicenseStatus
Set m_pAoInitialize = New AoInitialize
CheckOutLicenses = esriLicenseUnavailable
licenseStatus = m_pAoInitialize.IsProductCodeAvailable(productCode)
If licenseStatus = esriLicenseAvailable Then
licenseStatus = m_pAoInitialize.Initialize(productCode)
End If
CheckOutLicenses = licenseStatus
End Function