タイル インターネット レイヤを指定範囲で 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