frmexport.frm

一个不错的插件

514:   If TypeOf pExport Is IOutputCleanup Then
    Dim pCleanup As IOutputCleanup
516:     Set pCleanup = pExport
517:     pCleanup.Cleanup
518:   End If
  
520:   SetOutputQuality pActiveView, iPrevOutputImageQuality

522:   lblStatus.Caption = ""
523:   Set m_pMapBook = Nothing
524:   Set m_pMapPage = Nothing
525:   Set m_pMapSeries = Nothing
526:   m_pExportFrame.Visible = False
527:   Unload Me
  
  Exit Sub
ErrorHand:
531:   lblStatus.Caption = ""
532:   MsgBox "cmdExport_Click - " & Erl & " - " & 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 ErrorHand
  
  Dim pEnv As IEnvelope, pPageLayout As IPageLayout, pPage As IPage
  Dim dXmax As Double, dYmax As Double
  Dim pOutputRasterSettings As IOutputRasterSettings

544:    Set pEnv = New Envelope
'   pActiveView.ScreenDisplay.DisplayTransformation.Resolution = pExport.Resolution
  'Setup the Export
547:   ExportFrame = pActiveView.ExportFrame

549:   Set pPageLayout = pActiveView
550:   Set pPage = pPageLayout.Page
  
552:   If pPage.Units <> esriInches Then
553:     pPage.Units = esriInches
554:   End If
  
556:   pPage.QuerySize dXmax, dYmax
557:   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
563:   ExportFrame.Right = dXmax * pExport.Resolution
564:   ExportFrame.bottom = dYmax * pExport.Resolution
  
566:   ExportFrame.Left = 0
567:   ExportFrame.Top = 0
            
569:   With pExport
570:     .PixelBounds = pEnv
571:     .ExportFileName = sExportFileName
572:   End With

  
  ' Output Image Quality of the export.  The value here will only be used if the export
  '  object is a format that allows setting of Output Image Quality, i.e. a vector exporter.
  '  The value assigned to ResampleRatio should be in the range 1 to 5.
  '  1 (esriRasterOutputBest) corresponds to "Best", 5 corresponds to "Fast"
579:   If TypeOf pExport Is IOutputRasterSettings Then
    ' for vector formats, get the ResampleRatio from the export object and call SetOutputQuality
    '   to control drawing of raster layers at export time
582:     Set pOutputRasterSettings = pExport
583:     SetOutputQuality pActiveView, pOutputRasterSettings.ResampleRatio
584:     Set pOutputRasterSettings = Nothing
585:   Else
    'always set the output quality of the display to 1 (esriRasterOutputBest) for image export formats
587:     SetOutputQuality pActiveView, esriRasterOutputBest
588:   End If
  
  
  
  Exit Sub
ErrorHand:
594:   MsgBox "SetupToExport - " & Erl & " - " & Err.Description
End Sub


Public Function ConvertToPixels(sOrient As String, pExport As IExport) As Double
On Error GoTo ErrorHand:
  Dim pixelExtent As Long
  Dim pDT As IDisplayTransformation
  Dim deviceRECT As tagRECT
  Dim pMxDoc As IMxDocument
  
605:   Set pMxDoc = m_pApp.Document
606:   Set pDT = pMxDoc.ActiveView.ScreenDisplay.DisplayTransformation
607:   deviceRECT = pDT.DeviceFrame
  
609:   If sOrient = "Height" Then
610:     pixelExtent = Abs(deviceRECT.Top - deviceRECT.bottom)
611:   ElseIf sOrient = "Width" Then
612:     pixelExtent = Abs(deviceRECT.Top - deviceRECT.bottom)
613:   End If
  
615:   ConvertToPixels = (pExport.Resolution * (pixelExtent / pDT.Resolution))
  
  Exit Function
ErrorHand:
619:   MsgBox "ConvertToPixels - " & Erl & " - " & Err.Description
End Function

Private Sub Form_Load()
623:   chkDisabled.value = 1
End Sub

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

629:   CheckForValidPath = False
  
  Dim aPath() As String
632:       aPath = Split(sPathName, ".")

634:   If UBound(aPath) = 0 Then
    Exit Function
636:   ElseIf UBound(aPath) = 1 Then
    
    Dim sPath As String
    Dim lPos As Long
    
641:       lPos = InStrRev(sPathName, "\")
642:       sPath = Left$(sPathName, (Len(sPathName) - (Len(sPathName) - lPos + 1)))
      
644:       If Dir(sPath, vbDirectory) <> "" Then
645:         CheckForValidPath = True
        Exit Function
647:       Else
        Exit Function
649:       End If
      
651:   ElseIf UBound(aPath) > 1 Then
    Exit Function
653:   End If
  
  Exit Function
ErrorHand:
657:   MsgBox "CheckForValidPath - " & Erl & " - " & Err.Description
End Function

Public Sub SetOutputQuality(pActiveView As IActiveView, ByVal lOutputQuality As Long)
On Error GoTo ErrorHand
  Dim pMap As IMap
  Dim pGraphicsContainer As IGraphicsContainer
  Dim pElement As IElement
  Dim pOutputRasterSettings As IOutputRasterSettings
  Dim pMapFrame As IMapFrame
  Dim pTmpActiveView As IActiveView
  
  
670:   If TypeOf pActiveView Is IMap Then
671:     Set pOutputRasterSettings = pActiveView.ScreenDisplay.DisplayTransformation
672:     pOutputRasterSettings.ResampleRatio = lOutputQuality
673:   ElseIf TypeOf pActiveView Is IPageLayout Then
    
    'assign ResampleRatio for PageLayout
676:     Set pOutputRasterSettings = pActiveView.ScreenDisplay.DisplayTransformation
677:     pOutputRasterSettings.ResampleRatio = lOutputQuality
    
    'and assign ResampleRatio to the Maps in the PageLayout
680:     Set pGraphicsContainer = pActiveView
681:     pGraphicsContainer.Reset
682:     Set pElement = pGraphicsContainer.Next
683:     Do While Not pElement Is Nothing
684:       If TypeOf pElement Is IMapFrame Then
685:         Set pMapFrame = pElement
686:         Set pTmpActiveView = pMapFrame.Map
687:         Set pOutputRasterSettings = pTmpActiveView.ScreenDisplay.DisplayTransformation
688:         pOutputRasterSettings.ResampleRatio = lOutputQuality
689:       End If
690:       DoEvents
691:       Set pElement = pGraphicsContainer.Next
692:     Loop
693:     Set pMap = Nothing
694:     Set pMapFrame = Nothing
695:     Set pGraphicsContainer = Nothing
696:     Set pTmpActiveView = Nothing
697:   End If
698:   Set pOutputRasterSettings = Nothing
  
  Exit Sub
ErrorHand:
702:   MsgBox "SetOutputQuality - " & Erl & " - " & Err.Description
End Sub


Private Sub Form_Unload(Cancel As Integer)
707:   Set m_pMapPage = Nothing
708:   Set m_pMapSeries = Nothing
709:   Set m_pMapBook = Nothing
710:   Set m_pApp = Nothing
711:   Set m_pExport = Nothing
712:   Set m_pExportFrame = Nothing
713:   Set m_ExportersCol = Nothing
End Sub

Public Function GetMxdName() As String
On Error GoTo ErrorHand
  Dim pTemplates As ITemplates
  Dim lTempCount As Long
  Dim strDocPath As String
  
722:   Set pTemplates = Application.Templates
723:   lTempCount = pTemplates.count
  
  ' The document is always the last item
726:   strDocPath = pTemplates.Item(lTempCount - 1)
727:   GetMxdName = Split(strDocPath, "\")(UBound(Split(strDocPath, "\")))
  Exit Function
ErrorHand:
730:   MsgBox "GetMxdName - " & Erl & " - " & Err.Description
End Function

Public Function GetRootNameFromPath(sPathAndFilename As String) As String
On Error GoTo ErrorHand

  Dim sRootName As String
737:   sRootName = Split(sPathAndFilename, "\")(UBound(Split(sPathAndFilename, "\")))
738:   sRootName = Split(sRootName, ".")(0)
739:   GetRootNameFromPath = sRootName
  Exit Function
ErrorHand:
742:   MsgBox "GetRootNameFromPath - " & Erl & " - " & Err.Description
End Function

Public Function GetPathFromPathAndFilename(sPathAndFilename As String) As String
On Error GoTo ErrorHand

  Dim sPathName As String
  Dim sRootName As String
750:   sRootName = Split(sPathAndFilename, "\")(UBound(Split(sPathAndFilename, "\")))
751:   sPathName = Left(sPathAndFilename, Len(sPathAndFilename) - Len(sRootName))

753:   GetPathFromPathAndFilename = sPathName
  Exit Function
ErrorHand:
756:   MsgBox "GetPathFromPathAndFilename - " & Erl & " - " & Err.Description
End Function


' Read a Registry value.
' Use KeyName = "" for the default value.
' Supports only DWORD, SZ, and BINARY value types.

Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
    ByVal ValueName As String, ByVal KeyType As Integer, _
    Optional DefaultValue As Variant = Empty) As Variant
On Error GoTo ErrorHand

    Dim handle As Long, resLong As Long
    Dim resString As String, length As Long
    Dim resBinary() As Byte
    
    ' Prepare the default result.
774:     GetRegistryValue = DefaultValue
    ' Open the key, exit if not found.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
    
    Select Case KeyType
        Case REG_DWORD
            ' Read the value, use the default if not found.
781:             If RegQueryValueEx(handle, ValueName, 0, REG_DWORD, _
                resLong, 4) = 0 Then
783:                 GetRegistryValue = resLong
784:             End If
        Case REG_SZ
786:             length = 1024: resString = Space$(length)
787:             If RegQueryValueEx(handle, ValueName, 0, REG_SZ, _
                ByVal resString, length) = 0 Then
                ' If value is found, trim characters in excess.
790:                 GetRegistryValue = Left$(resString, length - 1)
791:             End If
        Case REG_BINARY
793:             length = 4096
            ReDim resBinary(length - 1) As Byte
795:             If RegQueryValueEx(handle, ValueName, 0, REG_BINARY, _
                resBinary(0), length) = 0 Then
797:                 GetRegistryValue = resBinary()
798:             End If
        Case Else
800:             Err.Raise 1001, , "Unsupported value type"
801:     End Select
    
803:     RegCloseKey handle
    
    Exit Function
ErrorHand:
807:   MsgBox "GetRegistryvalue - " & Erl & " - " & Err.Description
End Function

' Write / Create a Registry value.
' Use KeyName = "" for the default value.
' Supports only DWORD, SZ, REG_MULTI_SZ, and BINARY value types.

Sub SetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, ByVal ValueName As String, ByVal KeyType As Integer, value As Variant)
On Error GoTo ErrorHand
    Dim handle As Long, lngValue As Long
    Dim strValue As String
    Dim binValue() As Byte, length As Long
    
    ' Open the key, exit if not found.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then Exit Sub
    
    Select Case KeyType
        Case REG_DWORD
825:             lngValue = value
826:             RegSetValueEx handle, ValueName, 0, KeyType, lngValue, 4
        Case REG_SZ
828:             strValue = value
829:             RegSetValueEx handle, ValueName, 0, KeyType, ByVal strValue, Len(strValue)
        Case REG_MULTI_SZ
831:             strValue = value
832:             RegSetValueEx handle, ValueName, 0, KeyType, ByVal strValue, Len(strValue)
        Case REG_BINARY
834:             binValue = value
835:             length = UBound(binValue) - LBound(binValue) + 1
836:             RegSetValueEx handle, ValueName, 0, KeyType, binValue(LBound(binValue)), length
837:     End Select
    
    ' Close the key.
840:     RegCloseKey handle
    
    Exit Sub
ErrorHand:
844:   MsgBox "SetRegistryValue - " & Erl & " - " & Err.Description
End Sub