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
タイル インターネット レイヤを指定範囲で TIFF 画像に変換
2016/9/1 (木)