VBA, clip, cut Image

Source: Internet
Author: User
Sub clip ()

Dim pmxdoc as imxdocument
Set pmxdoc = thisdocument
Dim pmap as IMAP
Set pmap = pmxdoc. focusmap

Dim pfeaturelayer as ifeaturelayer
Dim prasterlayer as irasterlayer

Set pfeaturelayer = pmap. layer (0)
Set prasterlayer = pmap. layer (1)

Dim pfeatureclass as ifeatureclass
Set pfeatureclass = pfeaturelayer. featureclass

Dim pinputraster as iraster
Set pinputraster = prasterlayer. Raster

Dim pinputdataset as igeodataset
Set pinputdataset = pinputraster

Dim pfeaturecursor as ifeaturecursor
Set pfeaturecursor = pfeatureclass. Search (nothing, false)

Dim pfeature as ifeature
Set pfeature = pfeaturecursor. nextfeature

Dim pfields as ifields
Set pfields = pfeatureclass. Fields

Dim index as long
Index = pfields. findfield ("name ")

Dim ppolygon as ipolympus gon

Dim clipraster as iraster

Dim pwksf as iworkspacefactory
Set pwksf = new rasterworkspacefactory

Dim PWS as iworkspace
Set PWS = pwksf. openfromfile ("F: \", 0)

Dim psaveas as isaveas

Do until pfeature is nothing

Set ppolygon = pfeature. Shape
Set clipraster = cliprasterbypolgon (pinputdataset, ppolygon)
Set psaveas = clipraster
Psaveas. saveas pfeature. Value (INDEX), PWS, "tiff"
Set pfeature = pfeaturecursor. nextfeature

Loop

Msgbox "done! "

End sub

Public Function cliprasterbypolgon (pingeodataset as igeodataset, ppolygon as ipolympus gon) as iraster

Dim praster as iraster
If typeof pingeodataset is irasterlayer then
Dim prasterlayer as irasterlayer
Set prasterlayer = pingeodataset
Set praster = prasterlayer. Raster
Elseif typeof pingeodataset is irasterdataset then
Dim prasterdataset as irasterdataset
Set prasterdataset = pingeodataset
Set praster = prasterdataset. createdefaultraster
Elseif typeof pingeodataset is iraster then
Set praster = pingeodataset
Else
Exit Function
End if

Dim pinputdataset as igeodataset
Set pinputdataset = praster

Dim pextractionop as iextractionop
Set pextractionop = new rasterextractionop
Dim prasteranalysisenvironment as irasteranalysisenvironment
Set prasteranalysisenvironment = pextractionop
Prasteranalysisenvironment. setcellsize esrirasterenvvalue, getrastercellsize (praster)
Prasteranalysisenvironment. setextent esrirasterenvvalue, ppolygon. Envelope

Dim poutputdataset as igeodataset
Set poutputdataset = pextractionop. polygon (pinputdataset, ppolygon, true)

Set cliprasterbypolgon = poutputdataset
End Function

Public Function getrastercellsize (praster as iraster) as double
Dim pprops as irasterprops
Set pprops = praster
Getrastercellsize = pprops. meancellsize. x
End Function

1, RedCodeIs not clear

2. Sometimes, what errors are returned under drive C temp, which can be solved by finding the right machine and the right Operating System

Contact Us

The content source of this page is from Internet, which doesn't represent Alibaba Cloud's opinion; products and services mentioned on that page don't have any relationship with Alibaba Cloud. If the content of the page makes you feel confusing, please write us an email, we will handle the problem within 5 days after receiving your email.

If you find any instances of plagiarism from the community, please send an email to: info-contact@alibabacloud.com and provide relevant evidence. A staff member will contact you within 5 working days.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

  • Sales Support

    1 on 1 presale consultation

  • After-Sales Support

    24/7 Technical Support 6 Free Tickets per Quarter Faster Response

  • Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.