タイル インターネット レイヤを指定範囲で 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 = "C:\Temp\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.OutputWorldFile = True 
    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