PictureFormat.CropTop ,CropLeft,CropRight,CropBottom

ning84 · 发表于 2024-8-16 17:23

本帖最后由 ning84 于 2024-8-18 08:48 编辑

file:///C:/Users/Administrator.PC-202201142014/AppData/Local/Microsoft/Windows/Temporary%20Internet%20Files/MsOfficeHelp12/MOH711.tmp/help.gif
PictureFormat.CropTop 属性帮助 > PowerPoint 对象模型参考 > PictureFormat 对象 > 属性

file:///C:/Users/Administrator.PC-202201142014/AppData/Local/Microsoft/Windows/Temporary%20Internet%20Files/MsOfficeHelp12/MOH711.tmp/help.gif
PictureFormat 对象成员帮助 > PowerPoint 对象模型参考 > PictureFormat 对象

file:///C:/Users/Administrator.PC-202201142014/AppData/Local/Microsoft/Windows/Temporary%20Internet%20Files/MsOfficeHelp12/MOH711.tmp/help.gif
PictureFormat.CropLeft 属性帮助 > PowerPoint 对象模型参考 > PictureFormat 对象 > 属性

file:///C:/Users/Administrator.PC-202201142014/AppData/Local/Microsoft/Windows/Temporary%20Internet%20Files/MsOfficeHelp12/MOH711.tmp/help.gif
PictureFormat.CropRight 属性帮助 > PowerPoint 对象模型参考 > PictureFormat 对象 > 属性

file:///C:/Users/Administrator.PC-202201142014/AppData/Local/Microsoft/Windows/Temporary%20Internet%20Files/MsOfficeHelp12/MOH711.tmp/help.gif
PictureFormat.CropBottom 属性帮助 >

返回或设置从指定图片或 OLE 对象的顶部裁剪下的磅值。可读/写 Single 类型。裁剪以相对于图片的原始尺寸计算。例如，如果插入的图片原始高度为 100 磅，将其高度调整为 200 磅，再将 CropTop 属性设置为 50，则会从图片顶部裁剪 100 磅（而不是 50 镑）。
语法

表达式.CropTop

表达式 一个代表 PictureFormat 对象的变量。
返回值
Single
示例

本示例在 myDocument 中第三个形状的顶部裁剪了 20 磅。要使本示例执行，第三个形状必须是图片或 OLE 对象。

Visual Basic for Applications

Set myDocument = ActivePresentation.Slides(1)myDocument.Shapes(3).PictureFormat.CropTop = 20

本示例将选定形状的顶部裁剪用户指定的百分比，而不考虑该形状是否调整过。要使本示例执行，选定的形状必须是图片或 OLE 对象。

Visual Basic for Applications

percentToCrop = InputBox("What percentage do you " & _ "want to crop off the top of this picture?")Set shapeToCrop = ActiveWindow.Selection.ShapeRange(1)With shapeToCrop.Duplicate .ScaleHeight 1, True origHeight = .Height .DeleteEnd WithcropPoints = origHeight * percentToCrop / 100shapeToCrop.PictureFormat.CropTop = cropPoints

Sub lll()
Dim ShpRng As ShapeRange
Set ShpRng = Application.ActiveWindow.Selection.ShapeRange
With ShpRng
Debug.Print .Left, .Top, .Width, .Height
Debug.Print .Top
.PictureFormat.CropTop = 290
.PictureFormat.CropBottom = 700
Stop
Stop
End With
End Sub

复制代码

'''
Sub SelectFolderMapToRng()
Dim Rng As Range, Kk
Set Rng = Selection
Dim Fso As FileSystemObject, oFile As File
Set Fso = New FileSystemObject
Dim oFolder As Folder
Dim Ff As FileDialog
Set Ff = Application.FileDialog(msoFileDialogFolderPicker)
With Ff
.Title = ""
.AllowMultiSelect = True
.InitialFileName = "F:"
.Show
Set oFolder = Fso.GetFolder(.SelectedItems(1))
End With
Kk = 1
For Each oFile In oFolder.Files
Rng(Kk, 1) = oFile.Name
Rng(Kk, 2) = oFile.Path
Kk = Kk + 1
Next oFile
End Sub

复制代码

Sub ll()
Dim Sld As Slide, Slds As Slides
Set Slds = Application.ActivePresentation.Slides
Dim Shp As Shape
For Each Sld In Slds
Set Shp = Sld.Shapes(Sld.Shapes.Count)
Debug.Print Shp.Name
Next Sld
End Sub

复制代码

Sub SelectRngToPptMap()
Dim Fso As FileSystemObject
Set Fso = New FileSystemObject
Dim Img As WIA.ImageFile
Set Img = New WIA.ImageFile
Dim Rng As Range, Sht As Worksheet
Set Rng = Selection
Set Sht = Rng.Parent
Dim Pres As Presentation
Set Pres = OpenPpt(Fso, ThisWorkbook.Path & "" & Sht.Name & ".Pptx")
With Sht
Set Rng = Selection
End With
Debug.Print Pres.FullName, Rng.Address
Dim oScale
Dim ShpRng 'As ShapeRange
''
Dim Sld As Slide, Shp 'As Shape
For ii = 1 To Rng.Rows.Count - 1
Set Sld = Pres.Slides(ii)
PicName = Rng(ii, 2)
Set Shp = Sld.Shapes.AddPicture(PicName, msoCTrue, msoCTrue, 410, -100, 295, 720)
Shp.Name = Rng(ii, 1)
Set ShpRng = Sld.Shapes.Range(Shp.Name)
Debug.Print ShpRng.Name
With ShpRng.PictureFormat
.CropTop = 350
.CropBottom = 550
End With
Next ii
End Sub

复制代码

ning84 · 发表于 2024-8-20 07:30

Sub ll()
Dim Sld As Slide, Slds As Slides
Dim Shp As Shape, Shps As Shapes
Set Slds = Application.ActivePresentation.Slides
For Each Sld In Slds
Set Shps = Sld.Shapes
Debug.Print Sld.Name,
For Each Shp In Shps
Debug.Print Shp.Name,
Next Shp
Debug.Print
Next Sld
End Sub

复制代码

ning84 · 发表于 2024-8-20 08:55

画蛇添足，必须进一步优化。

Sub PptMapToCellsColumnsAB()
Dim PicDict As Dictionary
Set PicDict = New Dictionary
Dim Fso As FileSystemObject
Set Fso = New FileSystemObject
Dim Img As WIA.ImageFile
Set Img = New WIA.ImageFile
Dim Rng As Range, Sht As Worksheet
Set Rng = Selection.CurrentRegion
Set Sht = Rng.Parent
Dim Pres As Presentation
Set Pres = OpenPpt(Fso, ThisWorkbook.Path & "" & Sht.Name & ".Pptx")
Dim ShpRng 'As ShapeRange
Dim Str
''
Dim Sld As Slide, Shp 'As Shape
For Each Sld In Pres.Slides
PicDict(Sld.Name) = ""
Next Sld
Debug.Print PicDict.Count
For ii = Rng.Rows.Count To 1 Step -1
Str = Rng(ii, 2).Value
If PicDict.Exists(Str) Then
Set Sld = Pres.Slides(Rng(ii, 2).Value)
With Sld
Debug.Print .Shapes.Count
Set Shp = .Shapes(.Shapes.Count)
End With
Rng(ii, "AB") = Shp.Name
Else
Rng(ii, 2).EntireRow.Interior.ColorIndex = 4
Rng(ii, 2).EntireRow.Delete
End If
Next ii
End Sub

复制代码

		自动登录	找回密码
密码			免费注册