Oscar Sun

                  Option Explicit
Sub 匯出字圖()
Dim ip As InlineShapes, d As Document, p As Paragraph, w As String ', d2 As Document
Const f As String = "C:\黃老師工作_守真\!!!!!字源\小篆\"
Dim pic As IPictureDisp 'https://stackoverflow.com/questions/31922261/word-vba-how-to-save-picture-from-image-object-to-file
'Dim MyChart ' As Chart
'https://stackoverflow.com/questions/31922261/word-vba-how-to-save-picture-from-image-object-to-file
'Dim clipboardData As New DataObject
'https://stackoverflow.com/questions/25333558/export-pictures-excel-vba
'https://ithelp.ithome.com.tw/articles/10159745
'https://www.experts-exchange.com/questions/21068673/Saving-Images-from-Word-Documents-Programatically.html
filesystem_checkPathExists f
Set d = ActiveDocument
'Set d2 = Documents.Add
For Each p In d.Paragraphs
    w = "test" 'p.Range
    'p.Range.InlineShapes(1).ConvertToShape
    If p.Range.InlineShapes.Count > 0 And InStr(p.Range, "（") > 0 Then
        'p.Range.InlineShapes(1).Range.CopyAsPicture
        'Set MyChart = d.InlineShapes.AddChart2
        'Set MyChart = d.Shapes.AddChart2(
        'MyChart.ChartArea.Select
        'MyChart.Range.Paste
'        Set MyChart = p.Range.InlineShapes(1)
        'MyChart.Chart.Export f & w & ".png"
        'Set pic = myForm.Image1.Picture
        'stdole.SavePicture pic, f & w & ".png" '"C:\myfile.jpg"
        'p.Range.InlineShapes(1).Range.CopyAsPicture
        p.Range.InlineShapes(1).Select
        Selection.CopyAsPicture
'        d2.Range.Paste
'        d2.InlineShapes(1).Chart.Export f & w & ".png"
        stdole.SavePicture ClipBoard_GetData, f & w & ".png" '"C:\myfile.jpg"
    End If
    'SavePicture
    'https://www.experts-exchange.com/questions/21068673/Saving-Images-from-Word-Documents-Programatically.html
    'https://groups.google.com/forum/#!topic/microsoft.public.word.drawing.graphics/juGgXPzlWxA
    'https://social.msdn.microsoft.com/Forums/office/en-US/e04c24e6-3057-4664-ad35-9bb5967d98e0/saving-embedded-picture-object-as-files?forum=worddev
    'https://social.msdn.microsoft.com/Forums/en-US/df63ed1d-94a7-4748-846b-aa9d26134141/how-do-i-savepicture-in-my-code?forum=isvvba
Next
End Sub
Sub filesystem_checkPathExists(path As String)
Dim fs As Object, x As String, s As Integer
If Right(path, 1) <> "\" Then path = path & "\"
Set fs = CreateObject("scripting.filesystemobject")
s = InStr(path, "\")
Do
    x = Mid(path, 1, InStr(s + 1, path, "\"))
    If x = "" Then Exit Do
    If fs.folderexists(x) = False Then fs.createfolder (x)
    s = InStr(s + 1, path, "\")
Loop
End Sub