VBA读取图片文件名问题

落梅花

这是我多年前在网上得到的一段批量插入图片的VBA，插入图片后能自动画线，并在下一行自动给图片编号，效果如下图：

现在要求在显示“图片01、图片02……”的地方显示的是该图片原来的文件名称（只显示名称，不显示文件名的后缀和路径），求哪位大师帮忙修改一下，不胜感激！另，本人用的是WORD2010，希望2010版本下能正常使用。
=============================================

Sub 插入图片() ' ' 将选定图片插入到word文件的表格中，并自动编号，通过ConQtyInEachRow定义一行显示图片的数量
    Dim picOpenDialog As FileDialog, filePath As String, currentRow As Integer, TotalRow As Integer, CurrentColumns As Integer, TotalColumns As Integer, CurrentPic As Integer, totalPic As Integer, ConQtyInEachRow As Integer
    ConQtyInEachRow = 2 '通过这里修改一行显示的数量
    ConFileNameStr = "图片" '在这里修改产品编号后缀
   On Error Resume Next '忽略错误
  Set picOpenDialog = Application.FileDialog(msoFileDialogFilePicker)
    With picOpenDialog
    .Filters.Clear '清除所有文件筛选器中的项目
    .Filters.Add "JPG文件", "*.jpg", 1 '所有JPEG文件
    .Filters.Add "BMP文件", "*.bmp", 2 'BMP文件
    .Filters.Add "所有文件", "*.*", 3 '针对所有文件
    .AllowMultiSelect = True '允许多项选择
       If .Show = -1 Then
    totalPic = .SelectedItems.Count '行数
        If totalPic Mod ConQtyInEachRow = 0 Then '获得行数，注意行数在图片数量被ConQtyInEachRow整除的情况下
    TotalRow = Int((totalPic / ConQtyInEachRow)) * 2
    Else
    TotalRow = (Int(totalPic / ConQtyInEachRow) + 1) * 2
    End If
TotalColumns = ConQtyInEachRow '可以修改要求的列数
    Selection.Collapse Direction:=wdCollapseStart
    Set mytable = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=TotalRow, NumColumns:=TotalColumns, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitFixed) '建立表格,表格固定尺寸
    mytable.Style = "网格型"
    CurrentColumns = 0 '从第一列开始
    currentRow = 1 '从第 n一行开始
        For Each vrtSelectedItem In .SelectedItems
            filePath = vrtSelectedItem '当前文件名
            CurrentPic = CurrentPic + 1 '当前图片加1，用于编号
            If CurrentPic < 10 Then
            filenamestr = ConFileNameStr + "0" + CStr(CurrentPic)
            Else
            filenamestr = ConFileNameStr + CStr(CurrentPic)
            End If

            If CurrentColumns = ConQtyInEachRow Then '需要重启一行
            CurrentColumns = 1 '从第一列开始重新开始
            currentRow = currentRow + 2 '到下一行，注意要间隔一行
            Else
            CurrentColumns = CurrentColumns + 1
            End If

            '插入图片
            mytable.Cell(Row:=currentRow, Column:=CurrentColumns).Range.InlineShapes.AddPicture FileName:=filePath, LinkToFile:=False, SaveWithDocument:=True
            '下一行加入文件名
            mytable.Cell(Row:=currentRow + 1, Column:=CurrentColumns).Range.InsertAfter filenamestr

        Next vrtSelectedItem
    End If
    End With

End Sub

落梅花

感谢 zhanglei1371 原创并分享的代码！http://club.excelhome.net/thread-1048572-1-1.html
完美解决我整理图片中的难题！非常感谢！

anijoe123

MARK，学习

kaixin999

学习了，收藏！