Oscar Sun on SnipSave | Web-based code snippet manager for developers

分割表格-將原表格每列獨立成為單一表格_且抽出末欄之圖，重複標題列 vbscript

                    Option Explicit

Sub splitTableByEachRowTitleed()
Dim r As Long, cel As Cell, s As Long, e As Long, s1 As Long, e1 As Long, rng As Range
Dim inlsp As InlineShape
Dim rw As Row
r = 1

With Selection
    Set rng = .Range
    Do While (.Information(wdWithInTable))
        .SplitTable
        
        Set rw = .Document.Tables(1).Rows(1)
        rw.Range.Copy
        .Document.Tables(.Document.Tables.Count).Range.Characters(1).Select
        .Collapse wdCollapseStart
        .Paste
        .Document.Tables(.Document.Tables.Count).Range.Characters(1).Select
        .Collapse wdCollapseStart
        .MoveLeft
        
        
        If Selection.Document.Tables(r).Rows.Count = 1 Then
            Set cel = Selection.Document.Tables(r).Cell(1, 8)
        Else
            Set cel = Selection.Document.Tables(r).Cell(2, 8)
        End If
        
        If cel.Range.InlineShapes.Count > 0 Then
        Else
            If Selection.Document.Tables(r).Rows.Count > 1 Then _
                Set cel = Selection.Document.Tables(r).Cell(2, 8)
        End If
        s = .Start: e = .End
        rng.SetRange s, s
        If cel.Range.InlineShapes.Count > 0 Then
             cel.Range.InlineShapes(1).Select
            .Cut
'            cel.Range.InlineShapes(1).Range.Cut ' 若要用Range則記得要DoEvents讓系統剪貼簿完成工作
'            DoEvents'或許剛開始還行，久了還是會出錯。還是用Selection物件才保險、萬無一失
            s1 = .Start: e1 = .End
            If s1 > s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 - 1
                    rng.SetRange s1, s1
                Loop
            ElseIf s1 < s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 + 1
                    rng.SetRange s1, s1
                Loop
            End If
            rng.Select
            .Paste
            If .Previous.InlineShapes.Count > 0 Then
                With .Previous.InlineShapes(1)
                    .LockAspectRatio = msoTrue
                    .Height = 200
                End With
            Else
                .MoveRight wdCharacter, 1, wdExtend
                With .InlineShapes(1)
                    '.LockAspectRatio = msoTrue
                    .Height = .Height + 181
                    .Width = .Width + 181
                End With
            End If
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End If
        Selection.Document.Tables(r).Columns(8).Cells.Delete
        r = r + 1
        If Selection.Document.Tables(r).Rows.Count > 3 Then'結束時，尚須修改。目前可以權且加幾空白列在最後一列後
            Selection.Document.Tables(r).Rows(3).Select
        Else
            Exit Do
        End If
    Loop
End With
Beep
End Sub

漢籍電子文獻資料庫文本整理_以轉貼到中國哲學書電子化計劃 vbscript

View Snippet

                    Sub 漢籍電子文獻資料庫文本整理_以轉貼到中國哲學書電子化計劃()
Dim rng As Range, d As Document, a
Dim rp As Variant, i As Byte
Set d = ActiveDocument
If d.path <> "" Or d.Content.text <> Chr(13) Then Exit Sub
rp = Array("(", "{{", ")", "}}", ChrW(160), "", "【圖】", "", _
     "^p^p", "^p", _
     ChrW(13) & ChrW(45) & ChrW(13) & ChrW(13) & ChrW(11), "^p", _
     ChrW(13) & ChrW(45) & ChrW(13), "^p")
     '原來「ChrW(13) & ChrW(45) & ChrW(13) & ChrW(13) & ChrW(11)」是其中有表格啊
Set rng = d.Range
rng.Paste
漢籍電子文獻資料庫文本整理_注文前後加括號
For Each a In rng.Characters
    If a.Font.Size = 10 Then
        Select Case a.Font.Color
            Case 255, 9915136
                a.Delete
        End Select
    End If
Next a
rng.Cut
rng.PasteAndFormat wdFormatPlainText
For i = 0 To UBound(rp)
    rng.Find.Execute rp(i), , , , , , , wdFindContinue, , rp(i + 1), wdReplaceAll
    i = i + 1
Next i
Beep
End Sub

Sub 漢籍電子文獻資料庫文本整理_注文前後加括號()
Dim rng As Range, fColor As Long, flg As Boolean
Const fSize As Byte = 10
Set rng = ActiveDocument.Range
rng.Collapse wdCollapseStart
fColor = rng.Font.Color
Do While rng.End < rng.Document.Range.End - 1
    rng.move wdCharacter, 1
    If rng.Font.Color = 204 And rng.Font.Size = 11 Then
        rng.Delete
    ElseIf (rng.Font.Color <> fColor Or rng.Font.Size = fSize) And _
                (rng.Font.Color <> 234 And rng.Font.Bold = False) Then '紅字+粗體為檢索結果
        If flg = False Then
            If rng.Font.Color <> -16777216 Then
                rng.InsertBefore "("
                rng.Characters(1).Font.Color = rng.Next.Next.Font.Color
                rng.Characters(1).Font.Size = rng.Next.Next.Font.Size
                flg = True
            End If
        End If
    ElseIf rng.Font.Color = fColor And flg = True Then
        rng.Previous.InsertAfter ")"
        flg = False
    End If
Loop
Beep
End Sub

分割表格-將原表格每列獨立成為單一表格 vbscript

View Snippet

                    Option Explicit

Sub splitTableByEachRow()
Dim r As Long, cel As Cell, s As Long, e As Long, s1 As Long, e1 As Long, rng As Range
Dim inlsp As InlineShape
r = 1

With Selection
    Set rng = .Range
    Do While (.Information(wdWithInTable))
        .SplitTable
        Set cel = Selection.Document.Tables(r).Cell(1, 8)
        If cel.Range.InlineShapes.Count > 0 Then
        Else
            If Selection.Document.Tables(r).Rows.Count > 1 Then _
                Set cel = Selection.Document.Tables(r).Cell(2, 8)
        End If
        s = .Start: e = .End
        rng.SetRange s, s
        If cel.Range.InlineShapes.Count > 0 Then
             cel.Range.InlineShapes(1).Select
            .Cut
'            cel.Range.InlineShapes(1).Range.Cut ' 若要用Range則記得要DoEvents讓系統剪貼簿完成工作
'            DoEvents'或許剛開始還行，久了還是會出錯。還是用Selection物件才保險、萬無一失
            s1 = .Start: e1 = .End
            If s1 > s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 - 1
                    rng.SetRange s1, s1
                Loop
            ElseIf s1 < s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 + 1
                    rng.SetRange s1, s1
                Loop
            End If
            rng.Select
            .Paste
            If .Previous.InlineShapes.Count > 0 Then
                With .Previous.InlineShapes(1)
                    .LockAspectRatio = msoTrue
                    .Height = 200
                End With
            Else
                .MoveRight wdCharacter, 1, wdExtend
                With .InlineShapes(1)
                    '.LockAspectRatio = msoTrue
                    .Height = .Height + 181
                    .Width = .Width + 181
                End With
            End If
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            Selection.Document.Tables(r).Columns(8).Cells.Delete
        End If
        r = r + 1
        If Selection.Document.Tables(r).Rows.Count > 1 Then
            Selection.Document.Tables(r).Rows(2).Select
        Else
            Exit Do
        End If
    Loop
End With
Beep
End Sub

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

View Snippet

                    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

VBA 16進位轉10進位 vbscript

View Snippet

                    Function HextoDec(hex As String)
Dim i As Byte, l As Byte, d As String, dec As Long
l = Len(hex)
For i = 1 To l
    d = Mid(hex, i, 1)
    If d Like "[0-9]" Then
        'dec = dec + CByte(d) * 16 ^ (l - 1)
    Else
        Select Case d
            Case "A"
                d = "10"
            Case "B"
                d = "11"
            Case "C"
                d = "12"
            Case "D"
                d = "13"
            Case "E"
                d = "14"
            Case "F"
                d = "15"
        End Select
    End If
    dec = dec + CByte(d) * 16 ^ (l - i)
Next i
HextoDec = dec
End Function

← Prev Page Next Page →