1234

ExcelHome技术论坛

用户名  找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

帖子
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 183|回复: 6

学习msoAutoSizeTextToFitShape

[复制链接]

TA的精华主题

TA的得分主题

发表于 2025-1-5 13:07 | 显示全部楼层 |阅读模式
本帖最后由 ning84 于 2025-1-5 13:17 编辑

image.jpg
结果,不满足目标需求

  1. Sub ll3()
  2.    Dim ShpRng As ShapeRange
  3.    Dim Shp As Shape
  4.    Dim Sld As Slide
  5.        Set Sld = Application.ActivePresentation.Slides(12)
  6.        Sld.Select
  7.       
  8.        Set Shp = Sld.Shapes(1)
  9.        With Shp
  10.             .Fill.ForeColor.RGB = 116247774
  11.             .ZOrder msoBringToFront
  12.             .TextFrame.TextRange.Font.Color.RGB = 0 '516247774
  13.             Debug.Print .TextFrame2.TextRange.Text
  14.             .TextFrame.AutoSize = ppAutoSizeShapeToFitTex
  15.             .TextFrame2.AutoSize = msoAutoSizeTextToFitShape
  16.             
  17.         
  18.        End With
  19.       
  20. End Sub
复制代码


del.zip

55.11 KB, 下载次数: 4

TA的精华主题

TA的得分主题

发表于 2025-1-5 14:22 | 显示全部楼层
建议把你想要处理的过程和结果说明一下。

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-6 19:45 | 显示全部楼层
学习Transparency,AutoSize ,ppAutoSizeShapeToFitText



  1. Sub ll()
  2.    Dim ShpRng As ShapeRange
  3.        Set ShpRng = Application.ActiveWindow.Selection.ShapeRange
  4.        With ShpRng
  5.             Debug.Print .Fill.Transparency
  6.             .Fill.Transparency = 0.1
  7.             .TextFrame.AutoSize = ppAutoSizeNone
  8.             Debug.Print .Height
  9.             
  10.             .Height = .Height * 2
  11.             Stop
  12.             .TextFrame.AutoSize = ppAutoSizeShapeToFitText
  13.             
  14.        End With
  15. End Sub
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-7 09:47 | 显示全部楼层
本帖最后由 ning84 于 2025-1-8 09:40 编辑

学习学习,再学习。


  1. Sub ll()
  2.    Dim Sld As Slide
  3.        Set Sld = Application.ActivePresentation.Slides(1)
  4.    Dim Shp As Shape
  5.        For Each Shp In Sld.Shapes
  6.              With Shp
  7.                  Debug.Print .Name, .Type, .Left, .Top, .Width, .Height
  8.                  Select Case .Type
  9.                       Case 14
  10.                           Debug.Print , .TextEffect.FontName, , .TextFrame.TextRange.Font.Size, .TextFrame.TextRange.Text
  11.                  End Select
  12.              End With
  13.        Next Shp
  14. End Sub
  15. Sub ll1()
  16.    Dim Sld As Slide
  17.        Set Sld = Application.ActivePresentation.Slides(1)
  18.    Dim Shp As Shape
  19.        For ii = 1 To Sld.Shapes.Count
  20.              Set Shp = Sld.Shapes(ii)
  21.              With Shp
  22.                  Debug.Print ii, .Name, .Type, .Left, .Top, .Width, .Height
  23.                  Select Case .Type
  24.                       Case 14
  25.                           Debug.Print , .TextFrame.TextRange.Text, .TextEffect.FontName, , .TextFrame.TextRange.Font.Size,
  26.                           Debug.Print .Fill.ForeColor.RGB, .Fill.Transparency
  27.                  End Select
  28.              End With
  29.        Next
  30. End Sub
复制代码


  1. Sub ll()
  2.    Dim Sld As Slide, Slds As Slides
  3.    Dim Shp As Shape
  4.        Set Slds = Application.ActivePresentation.Slides
  5.        For ii = Slds.Count To 1 Step -1
  6.            Set Sld = Slds(ii)
  7.            Set Shp = Sld.Shapes("Txt2")
  8.            With Shp
  9.                Debug.Print ii, .TextFrame.TextRange.Text
  10.                If .TextFrame.TextRange.Text = "Txt2" Then
  11.                     Sld.Select
  12.                     Sld.Delete
  13.                End If
  14.            End With
  15.            
  16.        Next ii
  17.    
  18. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-20 19:40 | 显示全部楼层
学习学习在学习
  1. Sub ll()
  2.     Dim Sld As Slide, Slds As Slides
  3.         Set Slds = Application.ActivePresentation.Slides
  4.     Dim Shp As Shape, Shps As Shapes
  5.         For Each Sld In Slds
  6.             
  7.              Debug.Print Sld.Name
  8.              Set Shps = Sld.Shapes
  9.              For ii = 1 To Shps.Count
  10.                    Set Shp = Shps(ii)
  11.                    Debug.Print ii, Shp.Name, Shp.Type
  12.                    If Shp.Type = msoTextBox Then
  13.                          Debug.Print Shp.TextFrame.TextRange.Text
  14.                    End If
  15.                   
  16.              Next ii
  17.              Debug.Print "*******"
  18.         Next Sld
  19. End Sub
复制代码


结果

Slide93
1            图片 2097178   13
2            TextBox 1048609              17
时间:2025.01.20 10:16:06,地点:广东省珠海市香洲区前山街道·桂花村A区,天气:晴18°C PM2.5 44空气质量75良
*******
Slide94
1            图片 2097179   13
2            TextBox 1048610              17
时间:2025.01.20 10:15:58,地点:广东省珠海市香洲区前山街道·桂花村A区,天气:晴18°C PM2.5 44空气质量75良
*******


TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-20 21:56 | 显示全部楼层
学习正则方法。


  1. Sub ll()
  2.     Dim Sld As Slide, Slds As Slides
  3.         Set Slds = Application.ActivePresentation.Slides
  4.     Dim Shp As Shape, Shps As Shapes
  5.         For Each Sld In Slds
  6.             
  7.              Debug.Print Sld.Name
  8.              Set Shps = Sld.Shapes
  9.              For ii = 1 To Shps.Count
  10.                    Set Shp = Shps(ii)
  11.                    Debug.Print ii, Shp.Name, Shp.Type
  12.                    If Shp.Type = msoTextBox Then
  13.                          Debug.Print Shp.TextFrame.TextRange.Text
  14.                    End If
  15.                   
  16.              Next ii
  17.              Debug.Print "*******"
  18.         Next Sld
  19. End Sub
  20. Sub ll1()
  21.     Dim inputStr As String
  22.     Dim regexTime As VBScript_RegExp_55.RegExp, regexLocation As RegExp, regexWeather           As RegExp
  23.     Dim matchesTime As MatchCollection, matchesLocation As MatchCollection, matchesWeather As MatchCollection
  24.     Dim timeStr As String, locationStr As String, weatherStr As String
  25.         Set regexTime = New VBScript_RegExp_55.RegExp
  26.         Set regexLocation = New VBScript_RegExp_55.RegExp
  27.         Set regexWeather = New VBScript_RegExp_55.RegExp

  28.     Dim Reg As New RegExp
  29.     Dim Sld As Slide, Slds As Slides
  30.         Set Slds = Application.ActivePresentation.Slides
  31.     Dim Shp As Shape, Shps As Shapes
  32.   
  33.         For Each Sld In Slds
  34.             
  35.              Debug.Print Sld.Name
  36.              Set Shps = Sld.Shapes
  37.              Set Shp = Shps(2)
  38.              '''
  39.              inputStr = Shp.TextFrame.TextRange
  40.              regexTime.Pattern = "时间:(\d{4}\.\d{2}\.\d{2} \d{2}:\d{2}:\d{2})"
  41.              regexLocation.Pattern = "地点:(.*?)(?=,天气:|$)"
  42.              regexWeather.Pattern = "天气:(.*)"
  43.              ''
  44.              Set matchesTime = regexTime.Execute(inputStr)
  45.              Set matchesLocation = regexLocation.Execute(inputStr)
  46.              Set matchesWeather = regexWeather.Execute(inputStr)
  47.             
  48.              ' 提取匹配结果
  49.              If Not matchesTime Is Nothing Then
  50.                  timeStr = matchesTime(0).SubMatches(0)
  51.                  Debug.Print timeStr
  52.              End If
  53.              '''
  54.              If Not matchesLocation Is Nothing Then
  55.                  locationStr = matchesLocation(0).SubMatches(0)
  56.                  Debug.Print locationgstr
  57.              End If
  58.              ''
  59.              If Not matchesWeather Is Nothing Then
  60.                  weatherStr = matchesWeather(0).SubMatches(0)
  61.                
  62.              End If

  63.              Debug.Print "*******"
  64.         Next Sld
  65. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-22 09:13 | 显示全部楼层
Sld.NotesPage.Shapes.Count=1


image.png




  1. Sub ll()
  2.    Dim Sld As Slide, Slds As Slides
  3.        Set Slds = Application.ActivePresentation.Slides
  4.    Dim Shp As Shape, Shps As Shapes
  5.        For Each Sld In Slds
  6.              Set Shps = Sld.Shapes
  7.              For Each Shp In Shps
  8.                   If Shp.Name = "Intro" Then
  9.                       Shp.Delete
  10.                   End If
  11.              Next Shp
  12.              Debug.Print Sld.NotesPage.Count, Sld.NotesPage.Shapes.Count
  13.             
  14.              Set Shp = Shps.AddTextbox(msoTextOrientationHorizontal, 5, 5, 400, 400)
  15.              With Shp
  16.                  .Name = "Intro"
  17.                  If Sld.NotesPage.Shapes.Count = 1 Then
  18.                      Debug.Print , TypeName(Sld.NotesPage.Shapes(1).TextFrame.TextRange.Text)
  19.                      .TextFrame.TextRange.Text = "Intro" & Sld.NotesPage.Shapes(1).TextFrame.TextRange.Text
  20.                  End If
  21.                  .TextEffect.FontSize = 15
  22.                  .Fill.ForeColor.SchemeColor = ppAccent1
  23.              End With
  24.        Next Sld
  25.       
  26. End Sub
复制代码


您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

1234

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-2-13 15:49 , Processed in 0.022841 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表