在投影片内文字选取位置插入等大图片_以字图取代文字【PowerPoint VBA】

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
感恩感恩 南无阿弥陀佛

GitHub


<<:  [Pytorch] torchvision.transforms()

>>:  【左京淳的JAVA WEB学习笔记】第六章 档案上传

启动专案 (Docker)

启动 Laravel 专案前的环境设置还是挺麻烦的,不过目前 Laravel 官方指南的安装方式变成...

[Day26] Vue3 E2E Testing: Cypress 实战之 Todo MVC (中)

前情提要 昨天,我们为了让大家更加了解 Cypress 的语法以及要如何攥写 E2E 测试,所以开始...

没钱就跟别人要钱,别人的钱就是我的钱,但我的钱还是我的钱

乞讨功能 写个乞讨的功能...... # cogs/money.py @commands.comma...

Laravel 实战经验分享 - Day29 剩下最後的两篇,该讲些什麽呢?

到了倒数第二天,一直在想自己该写什麽,在参加这个比赛之前,自己常埋首在自以为是的开发中,无论遇到什麽...

你是谁、你的过去都不重要,成功的能力永远都从你开始。

你是谁、你的过去都不重要,成功的能力永远都从你开始。 It doesn’t matter who y...