frmexport.frm

使用VB和ArcObject结合的程序

'    End If
'    sTitle = "EMF Options"
'    Set pMyPage = New EmfExporterPropertyPage
''CGM is no longer supported at 9.0
''  Case "CGM (*.cgm)"
''    If m_pExporter Is Nothing Then
''      Set m_pExporter = New CGMExporter
''    Else
''      If Not TypeOf m_pExport Is ICGMExporter Then
''        Set m_pExport = New CGMExporter
''      End If
''    End If
''    sTitle = "CGM Options"
''    Set pMyPage = New CGMExporterPropertyPage
''  Case "AI (*.ai)"
''    If m_pExport Is Nothing Then
''      Set m_pExport = New exportai
''    Else
''      If Not TypeOf m_pExport Is IExportAI Then
''        Set m_pExport = New Exportai
''      End If
''    End If
''    sTitle = "AI Options"
''    Set pMyPage = New AIExporterPropertyPage
'  Case "EPS (*.eps)"
'    If m_pExport Is Nothing Then
'      Set m_pExport = New ExportPS
'    Else
'      If Not TypeOf m_pExport Is IExportPS Then
'        Set m_pExport = New ExportPS
'      End If
'    End If
'    sTitle = "EPS Options"
'    Set pMyPage = New PDFExporterPropertyPage
'  Case "PDF (*.pdf)"
'    If m_pExport Is Nothing Then
'      Set m_pExport = New ExportPDF
'    Else
'      If Not TypeOf m_pExport Is IExportPDF Then
'        Set m_pExport = New ExportPDF
'      End If
'    End If
'    sTitle = "PDF Options"
'    Set pMyPage = New PDFExporterPropertyPage
'    Set pMyPage2 = New FontMappingPropertyPage
'  Case "BMP (*.bmp)"
'    If m_pExport Is Nothing Then
'      Set m_pExport = New ExportBMP
'    Else
'      If Not TypeOf m_pExport Is IExportBMP Then
'        Set m_pExport = New ExportBMP
'      End If
'    End If
'    sTitle = "BMP Options"
'    Set pMyPage = New DibExporterPropertyPage
'  Case "TIFF (*.tif)"
'    If m_pExport Is Nothing Then
'      Set m_pExport = New ExportTIFF
'    Else
'      If Not TypeOf m_pExport Is IExportTIFF Then
'        Set m_pExport = New ExportTIFF
'      End If
'    End If
'    sTitle = "TIFF Options"
'    Set pMyPage = New TiffExporterPropertyPage
'  Case "JPEG (*.jpg)"
'    If m_pExport Is Nothing Then
'      Set m_pExport = New ExportJPEG
'    Else
'      If Not TypeOf m_pExport Is IExportJPEG Then
'        Set m_pExport = New ExportJPEG
'      End If
'    End If
'    sTitle = "JPEG Options"
'    Set pMyPage = New JpegExporterPropertyPage
'  End Select
'
'  If m_pExport Is Nothing Then Exit Sub
'
'  pExportSet.Add m_pExport
'
'  Dim pPS As IComPropertySheet
'
'  Set pPS = New ComPropertySheet
'
'  If Not pMyPage Is Nothing Then
'    pPS.AddPage pMyPage
'  End If
'
'  If Not pMyPage2 Is Nothing Then
'    pPS.AddPage pMyPage2
'  End If
'
''  Me.Hide
'  m_pExportFrame.Visible = False
'
'  If pPS.CanEdit(pExportSet) = True Then
'    pPS.Title = sTitle
'    pPS.EditProperties pExportSet, m_pApp.hwnd 'show the property sheet
'  End If
'
''  Me.Show
'  m_pExportFrame.Visible = True
'
'
''  If pMyPage.IsPageDirty = True Then
'    pMyPage.Apply
''  End If
'
'  Exit Sub
'ErrorHandler:
'  MsgBox "cmdOptions_Click - " & Err.Description
'End Sub

Private Sub cmdOptions_Click()
  On Error GoTo ErrorHandler

  Dim sFileExt As String
576:   sFileExt = Me.cmbExportType.Text
      
  Dim sTitle As String

  Select Case sFileExt
  Case "EMF (*.emf)"
582:     If m_pExport Is Nothing Then
583:       Set m_pExport = New ExportEMF
584:     Else
585:       If Not TypeOf m_pExport Is IExportEMF Then
586:         Set m_pExport = New ExportEMF
587:       End If
588:     End If
589:     sTitle = "EMF Options"
'  Case "AI (*.ai)"
'    If m_pExport Is Nothing Then
'      Set m_pExport = New exportai
'    Else
'      If Not TypeOf m_pExport Is IExportAI Then
'        Set m_pExport = New Exportai
'      End If
'    End If
'    sTitle = "AI Options"
'    Set pMyPage = New AIExporterPropertyPage
  Case "EPS (*.eps)"
601:     If m_pExport Is Nothing Then
602:       Set m_pExport = New ExportPS
603:     Else
604:       If Not TypeOf m_pExport Is IExportPS Then
605:         Set m_pExport = New ExportPS
606:       End If
607:     End If
608:     sTitle = "EPS Options"
  Case "PDF (*.pdf)"
610:     If m_pExport Is Nothing Then
611:       Set m_pExport = New ExportPDF
612:     Else
613:       If Not TypeOf m_pExport Is IExportPDF Then
614:         Set m_pExport = New ExportPDF
615:       End If
616:     End If
617:     sTitle = "PDF Options"
  Case "BMP (*.bmp)"
619:     If m_pExport Is Nothing Then
620:       Set m_pExport = New ExportBMP
621:     Else
622:       If Not TypeOf m_pExport Is IExportBMP Then
623:         Set m_pExport = New ExportBMP
624:       End If
625:     End If
626:     sTitle = "BMP Options"
  Case "TIFF (*.tif)"
628:     If m_pExport Is Nothing Then
629:       Set m_pExport = New ExportTIFF
630:     Else
631:       If Not TypeOf m_pExport Is IExportTIFF Then
632:         Set m_pExport = New ExportTIFF
633:       End If
634:     End If
635:     sTitle = "TIFF Options"
  Case "JPEG (*.jpg)"
637:     If m_pExport Is Nothing Then
638:       Set m_pExport = New ExportJPEG
639:     Else
640:       If Not TypeOf m_pExport Is IExportJPEG Then
641:         Set m_pExport = New ExportJPEG
642:       End If
643:     End If
644:     sTitle = "JPEG Options"
645:   End Select

  If m_pExport Is Nothing Then Exit Sub
  
'  Me.Hide
650:   m_pExportFrame.Visible = False
              
652:   Set frmExportPropDlg.Export = m_pExport
653:   frmExportPropDlg.Caption = sTitle
654:   frmExportPropDlg.Show vbModal, Me
  
  'The ExportSVG class has a Compression property that changes the value of the Filter property,
  ' and we must syncronize our file extension to account for the possible change.
658:   If TypeOf m_pExport Is IExportSVG Then
659:     cboSaveAsType.List(cboSaveAsType.ListIndex) = Split(m_pExport.Filter, "|")(0)
660:     m_sFileExtension = Split(Split(cboSaveAsType.Text, "(")(1), ")")(0)
661:     m_sFileExtension = Right(m_sFileExtension, Len(m_sFileExtension) - 1)
662:     txtFileName.Text = "Unititled" & m_sFileExtension
663:   End If
              
'  Me.Show
666:   m_pExportFrame.Visible = True
        
  Exit Sub
ErrorHandler:
670:   MsgBox "cmdOptions_Click - " & Err.Description
End Sub

Public Sub SetupToExport(ByRef pExport As IExport, ByRef dpi As Integer, ByRef ExportFrame As tagRECT, pActiveView As IActiveView, sExportFileName As String)
  On Error GoTo ErrorHandler
  
  Dim pEnv As IEnvelope, pPageLayout As IPageLayout, pPage As IPage
  Dim dXmax As Double, dYmax As Double
  
679:    Set pEnv = New Envelope
'   pActiveView.ScreenDisplay.DisplayTransformation.Resolution = pExport.Resolution
  'Setup the Export
682:   ExportFrame = pActiveView.ExportFrame

684:   Set pPageLayout = pActiveView
685:   Set pPage = pPageLayout.Page
  
687:   If pPage.Units <> esriInches Then
688:     pPage.Units = esriInches
689:   End If
  
691:   pPage.QuerySize dXmax, dYmax
692:   pEnv.PutCoords 0, 0, dXmax * pExport.Resolution, dYmax * pExport.Resolution

'Commented out code removes a quarter of a unit, most likely an inch, from the extent to make it
'fit better on the page
'  ExportFrame.Top = pExport.Resolution * 0.25
'  ExportFrame.Right = (dXmax - 0.25) * pExport.Resolution
698:   ExportFrame.Right = dXmax * pExport.Resolution
699:   ExportFrame.bottom = dYmax * pExport.Resolution
  
701:   ExportFrame.Left = 0
702:   ExportFrame.Top = 0
            
704:   With pExport
705:     .PixelBounds = pEnv
706:     .ExportFileName = sExportFileName
707:   End With

  
  Exit Sub
ErrorHandler:
712:   MsgBox "SetupToExport - " & Err.Description
End Sub


Public Function ConvertToPixels(sOrient As String, pExport As IExport) As Double
On Error GoTo ErrHand:
  Dim pixelExtent As Long
  Dim pDT As IDisplayTransformation
  Dim deviceRECT As tagRECT
  Dim pMxDoc As IMxDocument
  
723:   Set pMxDoc = m_pApp.Document
724:   Set pDT = pMxDoc.ActiveView.ScreenDisplay.DisplayTransformation
725:   deviceRECT = pDT.DeviceFrame
  
727:   If sOrient = "Height" Then
728:     pixelExtent = Abs(deviceRECT.Top - deviceRECT.bottom)
729:   ElseIf sOrient = "Width" Then
730:     pixelExtent = Abs(deviceRECT.Top - deviceRECT.bottom)
731:   End If
  
733:   ConvertToPixels = (pExport.Resolution * (pixelExtent / pDT.Resolution))
  
  Exit Function
ErrHand:
737:   MsgBox "ConvertToPixels - " & Err.Description
End Function

Private Sub Form_Load()
741:   chkDisabled.Value = 1
End Sub

Private Function CheckForValidPath(sPathName As String) As Boolean
  On Error GoTo ErrorHandler

747:   CheckForValidPath = False
  
  Dim aPath() As String
750:       aPath = Split(sPathName, ".")

752:   If UBound(aPath) = 0 Then
    Exit Function
754:   ElseIf UBound(aPath) = 1 Then
    
    Dim sPath As String
    Dim lPos As Long
    
759:       lPos = InStrRev(sPathName, "\")
760:       sPath = Left$(sPathName, (Len(sPathName) - (Len(sPathName) - lPos + 1)))
      
762:       If Dir(sPath, vbDirectory) <> "" Then
763:         CheckForValidPath = True
        Exit Function
765:       Else
        Exit Function
767:       End If
      
769:   ElseIf UBound(aPath) > 1 Then
    Exit Function
771:   End If
  
  Exit Function
ErrorHandler:
775:   MsgBox "CheckForValidPath - " & Err.Description
End Function

Private Sub Form_Unload(Cancel As Integer)
779:   Set m_pMapPage = Nothing
780:   Set m_pMapSeries = Nothing
781:   Set m_pMapBook = Nothing
782:   Set m_pApp = Nothing
783:   Set m_pExport = Nothing
784:   Set m_pExportFrame = Nothing
End Sub