Sub 在投影片内文字选取位置插入等大图片_以字图取代文字()
'20210320
Dim sld As Slide, sel As Selection, tr As TextRange
Set sel = ActiveWindow.Selection '选取处
Set sld = ActiveWindow.View.Slide '目前的投影片
Set tr = sel.TextRange 'https://docs.microsoft.com/zh-tw/office/vba/api/powerpoint.textrange.boundleft?f1url=%3FappId%3DDev11IDEF1%26l%3Dzh-TW%26k%3Dk(vbapp10.chm569006);k(TargetFrameworkMoniker-Office.Version%3Dv15)%26rd%3Dtrue
sld.Shapes.AddPicture "C:\Users\ssz3\Downloads\" & sel.TextRange.Text & ".jpg" _
, msoTrue, msoTrue, tr.BoundLeft, tr.BoundTop, tr.BoundWidth, tr.BoundHeight
End Sub
===========
Option Explicit
Sub 在投影片内文字选取位置插入等大图片_以字图取代文字()
'20210320
'Dim sld As Slide, sel As Selection, tr As TextRange2, sp As Shape
Dim sld, sel, tr, sp
Static fPPT As String
Dim PPT, fp As String, f As String, a, cc As Integer
If fPPT = "" Then fPPT = "G:\我的云端硬碟\DATA\h\山海关PowerPoint_VBA.pptm"
fPPT = InputBox("请输入PPT的全档名", , fPPT)
If fPPT = "" Then Exit Sub
file_system.GetFS
If file_system.FileSystem.fileexists(fPPT) = False Then MsgBox "全档名有误!请重新输入", vbCritical: Exit Sub
Set PPT = GetObject(fPPT)
fp = "G:\我的云端硬碟\DATA\h\@@@华语文工具及资料@@@\Macros\古文字\行书\others\已改档名_已与档名核对30%大小@4820\"
'fp = "C:\Users\ssz3\Downloads\"
Set sel = PPT.Application.ActiveWindow.Selection '选取处
Set sld = PPT.Application.ActiveWindow.View.Slide '目前的投影片
If sel.Type = 3 Then 'ppSelectionText
Set tr = sel.TextRange2 'https://docs.microsoft.com/zh-tw/office/vba/api/powerpoint.textrange.boundleft?f1url=%3FappId%3DDev11IDEF1%26l%3Dzh-TW%26k%3Dk(vbapp10.chm569006);k(TargetFrameworkMoniker-Office.Version%3Dv15)%26rd%3Dtrue
cc = tr.Characters.Count
If cc = 0 Then MsgBox "请先选取文字!", vbExclamation: Exit Sub
' sld.Shapes.AddPicture fp & sel.TextRange.Text & ".jpg" _
, msoTrue, msoTrue, tr.BoundLeft, tr.BoundTop, tr.BoundWidth, tr.BoundHeight
For Each a In tr.Characters
f = fp & a & ".jpg"
'If Dir(f) <> "" Then
If file_system.FileSystem.fileexists(f) Then
Set tr = a
Set sp = sld.Shapes.AddPicture(f, msoTrue, msoTrue, _
tr.BoundLeft, tr.BoundTop, tr.BoundWidth, tr.BoundHeight)
', msoTrue, msoTrue, tr.BoundLeft + tr.BoundWidth / cc * (a.Start - 1) _
, tr.BoundTop, _
tr.BoundWidth / cc, tr.BoundHeight)
pic透明_ppt sp, tr.Font.Fill.ForeColor
'' a.Font.Hidden = True
' If sel.ShapeRange.Fill.BackColor = 16777215 Then
' 'If sel.ShapeRange.TextFrame.Parent.Child = False Then
' tr.Font.Color = sel.SlideRange.Background.Fill.ForeColor
' 'Else
' ' tr.Font.Color = sel.ShapeRange.TextFrame.Parent.Fill.BackColor
' 'End If
' Else
' tr.Font.Color = sel.ShapeRange.Fill.BackColor
' End If
tr.Font.Fill.Transparency = 1 'https://stackoverflow.com/questions/46326124/powerpoint-2016-text-transparency
'https://www.google.com/search?q=powerpoint+vba+font+transparency&rlz=1C1GCEU_zh-TWTW945TW945&oq=powerpoint+vba+font+tran&aqs=chrome.1.69i57j0i30j69i60.8958j0j7&sourceid=chrome&ie=UTF-8
'https://docs.microsoft.com/zh-tw/office/vba/api/powerpoint.fillformat.transparency
'Apply Transparency to Text in PowerPoint in C#, VB.NET
'https://www.e-iceblue.com/Tutorials/Spire.Presentation/Spire.Presentation-Program-Guide/Paragraph-and-Text/Apply-Transparency-to-Text-in-PowerPoint-in-C-VB.NET.html
End If
Next a
PPT.Application.Activate
Else
MsgBox "请先选取文字!", vbExclamation
End If
Set PPT = Nothing
Beep
End Sub
Sub pic透明_ppt(sp, clr As Long)
With sp.PictureFormat 'https://msdn.microsoft.com/zh-tw/VBA/Word-VBA/articles/pictureformat-transparentbackground-property-word
'https://msdn.microsoft.com/zh-tw/VBA/Word-VBA/articles/inlineshape-pictureformat-property-word
.TransparentBackground = msoTrue '背景透明
.TransparencyColor = RGB(255, 255, 255) '字黑色
'https://docs.microsoft.com/zh-tw/office/vba/api/powerpoint.pictureformat.transparencycolor
End With
' 'http://www.vbaexpress.com/forum/showthread.php?43036-Picture-Format-Painter
' 'sp.Fill.ForeColor.RGB = clr
' sp.Fill.PictureEffects.insert msoEffectPhotocopy
' sp.Fill.ForeColor.RGB = RGB(255, 0, 0) 'clr
' sp.Fill.BackColor.RGB = RGB(255, 0, 0)
' '.Fill..PictureFormat.ColorType=.TransparencyColor = clr
' 'https://docs.microsoft.com/zh-tw/office/vba/api/powerpoint.colorformat
' 'https://docs.microsoft.com/zh-tw/office/vba/api/office.msopictureeffecttype
' 'msoEffectPaintBrush 18 调色盘效果
' 'msoEffectColorTemperature 6 色彩色温效果
' 'msoEffectPhotocopy 23 拓印效果
' 'https://docs.microsoft.com/zh-tw/office/vba/api/office.pictureeffects.insert
'https://docs.microsoft.com/zh-tw/office/vba/api/powerpoint.pictureformat
'https://blog.csdn.net/yq_forever/article/details/78114819
'https://isvincent.pixnet.net/blog/post/48822135-powerpoint-%E7%82%BA%E5%9C%96%E7%89%87%E9%87%8D%E6%96%B0%E8%91%97%E8%89%B2%E4%BB%BB%E6%84%8F%E8%89%B2%E5%BD%A9(%E4%B8%8D%E9%99%90%E6%96%BC%E9%A0%90%E8%A8%AD#comment-form
End Sub
Public FileSystem As Object
Sub GetFS()
If FileSystem Is Nothing Then Set FileSystem = CreateObject("Scripting.FileSystemObject")
End Sub
结果演示:
https://oscarsun72.blogspot.com/2021/03/powerpoint-vba_20.html
感恩感恩 南无阿弥陀佛
<<: [Pytorch] torchvision.transforms()
>>: 【左京淳的JAVA WEB学习笔记】第六章 档案上传
启动 Laravel 专案前的环境设置还是挺麻烦的,不过目前 Laravel 官方指南的安装方式变成...
前情提要 昨天,我们为了让大家更加了解 Cypress 的语法以及要如何攥写 E2E 测试,所以开始...
乞讨功能 写个乞讨的功能...... # cogs/money.py @commands.comma...
到了倒数第二天,一直在想自己该写什麽,在参加这个比赛之前,自己常埋首在自以为是的开发中,无论遇到什麽...
你是谁、你的过去都不重要,成功的能力永远都从你开始。 It doesn’t matter who y...