在投影片內文字選取位置插入等大圖片_以字圖取代文字【PowerPoint VBA】

https://ithelp.ithome.com.tw/articles/10255913 https://snipsave.com/user/oscarsun72/snippet/CCpkPP1j45jd7VP3qp/

Sub 在投影片內文字選取位置插入等大圖片_以字圖取代文字()
Dim sld As Slide, sel As Selection, tr As TextRange
Set sel = ActiveWindow.Selection
Set sld = ActiveWindow.View.Slide
Set tr = sel.TextRange 
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 在投影片內文字選取位置插入等大圖片_以字圖取代文字()
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\"
Set sel = PPT.Application.ActiveWindow.Selection 
Set sld = PPT.Application.ActiveWindow.View.Slide 
If sel.Type = 3 Then 
    Set tr = sel.TextRange2 
    cc = tr.Characters.Count
    If cc = 0 Then MsgBox "請先選取文字！", vbExclamation: Exit Sub
    
    For Each a In tr.Characters
        f = fp & a & ".jpg"        
        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)                
                tr.BoundWidth / cc, tr.BoundHeight)
                pic透明_ppt sp, tr.Font.Fill.ForeColor
                tr.Font.Fill.Transparency = 1 
        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 
        .TransparentBackground = msoTrue 
        .TransparencyColor = RGB(255, 255, 255)        
    End With
End Sub


Public FileSystem As Object
Sub GetFS()
If FileSystem Is Nothing Then Set FileSystem = CreateObject("Scripting.FileSystemObject")
End Sub

=====================================

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