タイル インターネット レイヤを指定範囲で TIFF 画像に変換

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Sub run()
 
    Dim i As Long
    Dim j As Long
     
    Dim pMxDocument As IMxDocument
    Set pMxDocument = ThisDocument
     
    Dim pEnvelope As IEnvelope
    Set pEnvelope = pMxDocument.ActiveView.Extent
     
    Dim pClone As IClone
    Set pClone = pEnvelope
     
    Dim pNewEnvelope As IEnvelope
 
     
    Dim Overlap As Double
    Overlap = 400 'オーバーラップ
     
    Dim pTransform2D As ITransform2D
     
    For i = 0 To 10
        For j = 0 To 20
             
            Set pNewEnvelope = pClone.Clone
            Set pTransform2D = pNewEnvelope
             
            Call pTransform2D.Move(pEnvelope.Width * j - Overlap * j, -pEnvelope.Height * i + Overlap * i)
             
             
             
            pMxDocument.ActiveView.Extent = pTransform2D
            pMxDocument.ActiveView.Refresh
            DoEvents
            'Call Sleep(30)
                    
            'Call ExportTIFF
         
        Next j
             
     
    Next i
     
     
    MsgBox "おしまい"
 
End Sub
 
 
Public Sub ExportTIFF()
 
    Dim dt_path As String
    dt_path = "D:\Student\New Folder\Data"
 
 
 
    Dim ExportFileName As String
    Dim i As Long
   ExportFileName = Dir(dt_path & "\output" & i & ".tif")
    Do While ExportFileName <> ""
 
        i = i + 1
        ExportFileName = Dir(dt_path & "\output" & i & ".tif")
    Loop
 
 
 
 
 
    ExportFileName = dt_path & "\output" & i & ".tif"
     
    Dim ExportResolution As Integer
    ExportResolution = 300
     
    Dim DPI As Integer
    DPI = 96
 
    Dim pMxDocument As IMxDocument
    Set pMxDocument = ThisDocument
     
    Dim pActiveView As IActiveView
    Set pActiveView = pMxDocument.ActiveView
     
    Dim pOutputRasterSettings As IOutputRasterSettings
    Set pOutputRasterSettings = pActiveView.ScreenDisplay.DisplayTransformation
    pOutputRasterSettings.ResampleRatio = 1 'ラスタのピクセル比率を1に変更
         
    Dim pExport As IExport
    Set pExport = New ExportTIFF
    pExport.ExportFileName = ExportFileName     '保存場所
    pExport.Resolution = ExportResolution       '解像度
     
    Dim pExportTIFF As IExportTIFF
    Set pExportTIFF = pExport
    pExportTIFF.GeoTiff = True
    pExportTIFF.CompressionType = esriTIFFCompressionLZW
     
    Dim pWorldFileSettings As IWorldFileSettings
    Set pWorldFileSettings = pExport
    pWorldFileSettings.MapExtent = pActiveView.Extent
 
     
     
    '出力地図範囲
    Dim pVisibleBounds As IEnvelope
    Set pVisibleBounds = pActiveView.Extent
 
    
    '出力ラスタ ピクセル サイズ
    Dim pRECT As tagRECT
    pRECT = pActiveView.ExportFrame
    pRECT.Left = 0
    pRECT.Top = 0
    pRECT.Right = pRECT.Right * pExport.Resolution / DPI
    pRECT.bottom = pRECT.bottom * pExport.Resolution / DPI
 
    Dim pPixelBounds As IEnvelope
    Set pPixelBounds = New Envelope
    pPixelBounds.PutCoords pRECT.Left, pRECT.Top, pRECT.Right, pRECT.bottom
 
    pExport.PixelBounds = pPixelBounds
     
    Dim hDc As OLE_HANDLE
    hDc = pExport.StartExporting
     
    pActiveView.Output hDc, pExport.Resolution, pRECT, pVisibleBounds, Nothing      '第2引数をあげると出力画像の線が細くなる
     
    pExport.FinishExporting
    pExport.Cleanup
     
    DoEvents
         
End Sub