frmexport.frm

使用VB和ArcObject结合的程序

145:   If bValid = False Then
146:     MsgBox "You have not typed in a valid path!!!"
    Exit Sub
148:   End If

  '***Need to make sure it's a valid path
  
152:   Set pMouse = New MouseCursor
153:   pMouse.SetCursor 2

155:   Set pMxDoc = m_pApp.Document
156:   sFileName = Left(Me.txtPath.Text, Len(Me.txtPath.Text) - 4)
157:   sFileExt = Right(Me.txtPath.Text, 3)
    
159:   If m_pExport Is Nothing Then
    Select Case sFileExt
    Case "emf"
162:       Set pExport = New ExportEMF
'    Case "cgm"
'      MsgBox "CGMExporter not supported at 9.0, need to change this code to the replacement."
'      Exit Sub
'      Set pExport = New CGMExporter
    Case "eps"
168:       Set pExport = New ExportPS
    Case ".ai"
170:       Set pExport = New ExportAI
    Case "pdf"
172:       Set pExport = New ExportPDF
      'Map the basic fonts
174:       MapFonts pExport
    Case "bmp"
176:       Set pExport = New ExportBMP
    Case "tif"
178:       Set pExport = New ExportTIFF
    Case "jpg"
180:       Set pExport = New ExportJPEG
181:     End Select
182:   Else
183:     Set pExport = m_pExport
184:   End If
        
186:   If pExport Is Nothing Then
187:     MsgBox "No export object!!!"
    Exit Sub
189:   End If
   
  'Switch to the Layout view if we are not already there
192:   If Not TypeOf pMxDoc.ActiveView Is IPageLayout Then
193:     Set pMxDoc.ActiveView = pMxDoc.PageLayout
194:   End If

196:   Set pActiveView = pMxDoc.ActiveView
'  pActiveView.ScreenDisplay.DisplayTransformation.ZoomResolution = False
  'Need to include code here to create a collection of all of the map pages that you can
  'then loop through and print.
  Dim PagesToExport As Collection
  Dim i As Long
  Dim pMapPage As IDSMapPage, pSeriesOpts As IDSMapSeriesOptions
  Dim ExportFrame As tagRECT, pSeriesOpts2 As IDSMapSeriesOptions2
  Dim hdc As Long
  Dim dpi As Integer
  Dim sExportFile As String
207:   Set PagesToExport = New Collection
208:   Set pSeriesOpts = m_pMapSeries
209:   Set pSeriesOpts2 = pSeriesOpts
  
211:   If Not m_pMapPage Is Nothing Then
212:       PagesToExport.Add m_pMapPage
213:   End If
  
215:   If Not m_pMapSeries Is Nothing And m_pMapPage Is Nothing And m_pMapBook Is Nothing Then
216:     If Me.optAll.Value = True Then
217:       For i = 0 To m_pMapSeries.PageCount - 1
218:         If Me.chkDisabled.Value = 1 Then
219:           If m_pMapSeries.Page(i).EnablePage Then
220:             PagesToExport.Add m_pMapSeries.Page(i)
221:           End If
222:          Else
223:             PagesToExport.Add m_pMapSeries.Page(i)
224:         End If
225:       Next i
226:     ElseIf Me.optPages.Value = True Then
      'parse out the pages to export
228:       If chkDisabled.Value = 1 Then
229:         Set PagesToExport = ParseOutPages(Me.txtPages.Text, m_pMapSeries, True)
230:       Else
231:         Set PagesToExport = ParseOutPages(Me.txtPages.Text, m_pMapSeries, False)
232:       End If
      If PagesToExport.count = 0 Then Exit Sub
234:     End If
235:   End If
  
237:   If PagesToExport.count > 0 Then
238:     If pSeriesOpts2.ClipData > 0 Then
239:       g_bClipFlag = True
240:     End If
241:     If pSeriesOpts.RotateFrame Then
242:       g_bRotateFlag = True
243:     End If
244:     If pSeriesOpts.LabelNeighbors Then
245:       g_bLabelNeighbors = True
246:     End If
247:     For i = 1 To PagesToExport.count
248:       Set pMapPage = PagesToExport.Item(i)
249:       pMapPage.DrawPage pMxDoc, m_pMapSeries, False
          
251:       If sFileExt = ".ai" Then
252:         sExportFile = sFileName & "_" & pMapPage.PageName & sFileExt
253:       Else
254:         sExportFile = sFileName & "_" & pMapPage.PageName & "." & sFileExt
255:       End If
256:       lblStatus.Caption = "Exporting to " & sExportFile & " ..."
257:       SetupToExport pExport, dpi, ExportFrame, pActiveView, sExportFile
      
      'Do the export
260:       hdc = pExport.StartExporting
261:         pActiveView.Output hdc, pExport.Resolution, ExportFrame, Nothing, Nothing
262:         pMapPage.LastOutputted = Format(Date, "mm/dd/yyyy")
263:       pExport.FinishExporting
264:     Next i
265:   End If
            
267:   If Not m_pMapBook Is Nothing Then
    Dim pMapSeries As IDSMapSeries
    Dim count As Long
270:     For i = 0 To m_pMapBook.ContentCount - 1
271:       Set PagesToExport = New Collection
272:       Set pMapSeries = m_pMapBook.ContentItem(i)
273:       Set pSeriesOpts = pMapSeries
    
275:       For count = 0 To pMapSeries.PageCount - 1
276:         If Me.chkDisabled.Value = 1 Then
277:           If pMapSeries.Page(count).EnablePage Then
278:             PagesToExport.Add pMapSeries.Page(count)
279:           End If
280:         Else
281:             PagesToExport.Add pMapSeries.Page(count)
282:         End If
283:       Next count
        
285:       If pSeriesOpts2.ClipData > 0 Then
286:         g_bClipFlag = True
287:       End If
288:       If pSeriesOpts.RotateFrame Then
289:         g_bRotateFlag = True
290:       End If
291:       If pSeriesOpts.LabelNeighbors Then
292:         g_bLabelNeighbors = True
293:       End If
294:       For count = 1 To PagesToExport.count
        'now do export
296:         Set pMapPage = PagesToExport.Item(count)
297:         pMapPage.DrawPage pMxDoc, pMapSeries, False
      
299:         If sFileExt = ".ai" Then
300:             sExportFile = sFileName & "_series_" & i & "_" & pMapPage.PageName & sFileExt
301:         Else
302:             sExportFile = sFileName & "_series_" & i & "_" & pMapPage.PageName & "." & sFileExt
303:         End If
304:         lblStatus.Caption = "Exporting to " & sExportFile & " ..."
305:         SetupToExport pExport, pExport.Resolution, ExportFrame, pActiveView, sExportFile
          
        'Do the export
308:         hdc = pExport.StartExporting
309:           pActiveView.Output hdc, pExport.Resolution, ExportFrame, Nothing, Nothing
310:           pMapPage.LastOutputted = Format(Date, "mm/dd/yyyy")
311:         pExport.FinishExporting
312:       Next count
313:     Next i
314:   End If

'  pActiveView.ScreenDisplay.DisplayTransformation.ZoomResolution = True
317:   If TypeOf pExport Is IOutputCleanup Then
    Dim pCleanup As IOutputCleanup
319:     Set pCleanup = pExport
320:     pCleanup.Cleanup
321:   End If
  
323:   lblStatus.Caption = ""
324:   Set m_pMapBook = Nothing
325:   Set m_pMapPage = Nothing
326:   Set m_pMapSeries = Nothing
327:   m_pExportFrame.Visible = False
328:   Unload Me
  
  Exit Sub
ErrHand:
332:   lblStatus.Caption = ""
333:   MsgBox "cmdExport_Click - " & Err.Description
End Sub

Private Sub MapFonts(pExport As IExport)
On Error GoTo ErrHand:
  If Not TypeOf pExport Is IFontMapEnvironment Then Exit Sub
  
  Dim pFontMapEnv As IFontMapEnvironment, pFontMapColl As IFontMapCollection
  Dim pFontMap As IFontMap2
342:   Set pFontMapEnv = pExport
343:   Set pFontMapColl = pFontMapEnv.FontMapCollection
344:   Set pFontMap = New FontMap
345:   pFontMap.SetMapping "Arial", "Helvetica"
346:   pFontMapColl.Add pFontMap
347:   Set pFontMap = New FontMap
348:   pFontMap.SetMapping "Arial Bold", "Helvetica-Bold"
349:   pFontMapColl.Add pFontMap
350:   Set pFontMap = New FontMap
351:   pFontMap.SetMapping "Arial Bold Italic", "Helvetica-BoldOblique"
352:   pFontMapColl.Add pFontMap


   Set pFontMap = New FontMap
   pFontMap.SetMapping "黑体", "黑体"
   pFontMapColl.Add pFontMap
   
Set pFontMap = New FontMap
   pFontMap.SetMapping "仿宋_GB2312", "仿宋_GB2312"
   pFontMapColl.Add pFontMap
   
   Set pFontMap = New FontMap
   pFontMap.SetMapping "楷体_GB2312", "楷体_GB2312"
   pFontMapColl.Add pFontMap





353:   Set pFontMap = New FontMap
354:   pFontMap.SetMapping "Arial Italic", "Helvetica-Oblique"
355:   pFontMapColl.Add pFontMap
356:   Set pFontMap = New FontMap
357:   pFontMap.SetMapping "Courier New", "Courier"
358:   pFontMapColl.Add pFontMap
359:   Set pFontMap = New FontMap
360:   pFontMap.SetMapping "Courier New Bold", "Courier-Bold"
361:   pFontMapColl.Add pFontMap
362:   Set pFontMap = New FontMap
363:   pFontMap.SetMapping "Courier New Bold Italic", "Courier-BoldOblique"
364:   pFontMapColl.Add pFontMap
365:   Set pFontMap = New FontMap
366:   pFontMap.SetMapping "Courier New Italic", "Courier-Oblique"
367:   pFontMapColl.Add pFontMap
368:   Set pFontMap = New FontMap
369:   pFontMap.SetMapping "Symbol", "Symbol"
370:   pFontMapColl.Add pFontMap
371:   Set pFontMap = New FontMap
372:   pFontMap.SetMapping "Times New Roman", "Times-Roman"
373:   pFontMapColl.Add pFontMap
374:   Set pFontMap = New FontMap
375:   pFontMap.SetMapping "Times New Roman Bold", "Times-Bold"
376:   pFontMapColl.Add pFontMap
377:   Set pFontMap = New FontMap
378:   pFontMap.SetMapping "Times New Roman Bold Italic", "Times-BoldItalic"
379:   pFontMapColl.Add pFontMap
380:   Set pFontMap = New FontMap
381:   pFontMap.SetMapping "Times New Roman Italic", "Times-Italic"
382:   pFontMapColl.Add pFontMap
  
  Exit Sub
ErrHand:
386:   MsgBox "MapFonts - " & Err.Description
End Sub

Public Sub InitializeTheForm()
    
391:     Me.cmbExportType.Clear
'    Me.cmbExportType.AddItem "EMF (*.emf)"
'    Me.cmbExportType.AddItem "CGM (*.cgm)"
'    Me.cmbExportType.AddItem "EPS (*.eps)"
'    Me.cmbExportType.AddItem "AI (*.ai)"
396:     Me.cmbExportType.AddItem "BMP (*.bmp)"
397:     Me.cmbExportType.AddItem "EPS (*.eps)"
398:     Me.cmbExportType.AddItem "JPEG (*.jpg)"
399:     Me.cmbExportType.AddItem "PDF (*.pdf)"
400:     Me.cmbExportType.AddItem "TIFF (*.tif)"
    
'    Me.cmbExportType.Text = "JPEG (*.jpg)"
    
404:     Me.cmbExportType.ListIndex = 2
    
End Sub

Private Sub ChangeFileExtension(sFileType As String)

Dim sExt As String
411:     sExt = Right(sFileType, 4)
412:     sExt = Left(sExt, 3)
    
Dim sFileName As String
Dim sFileNameExt As String

417:     sFileName = Me.txtPath.Text
418:     sFileNameExt = Right(sFileName, 3)
    
420:     If sExt <> sFileNameExt Then
        Dim aFileName() As String
        
423:         aFileName = Split(sFileName, ".")
        
425:         If sExt <> ".ai" Then
426:             Me.txtPath.Text = aFileName(0) & "." & sExt
427:         Else
428:             Me.txtPath.Text = aFileName(0) & sExt
429:         End If
    
431:     End If
    
End Sub

'Private Sub cmdOptions_Click()
'  On Error GoTo ErrorHandler
'
'  Dim sFileExt As String
'  sFileExt = Me.cmbExportType.Text
'
'  Dim pExportSet As ISet
'  Dim sTitle As String
'  Dim pMyPage As IComPropertyPage   'build the property page
'  Dim pMyPage2 As IComPropertyPage
'
'  'Set m_pExport = Nothing
'
'  Set pExportSet = New esriSystem.Set
'
'  Select Case sFileExt
'  Case "EMF (*.emf)"
'    If m_pExport Is Nothing Then
'      Set m_pExport = New ExportEMF
'    Else
'      If Not TypeOf m_pExport Is IExportEMF Then
'        Set m_pExport = New ExportEMF
'      End If