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
感恩感恩 南無阿彌陀佛