同名学生相片重命名问题

szqhb

偶得一提取学籍卡信息的文档，详见https://club.excelhome.net/thread-1462783-3-1.html。
在测试时发现同名学生的相片如果用名字命名相片，只能够提取到最后一个学生的相片（即提取的相片重命名时会覆盖前面的），帮忙修改一下代码。如让第2个起的重名学生在姓名后面加上学籍号或者该生在Word里的序号i。

修改后的代码如下（附件中的代码请自行更换）：

Sub Main()
   'Date:2019/2/27 正月廿三 Wednesday
   '标签:word导出图片,word表格数据写到excel
   '备注1:测试过程中会出现word被锁定无法编辑 导致无法打开被选择的word文件 进程删除WINWORD.exe*32 再打开word文件
   '备注2:同上 正在等待其他某个应用程序以完成对象链接与嵌入操作
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim DiaFile As FileDialog, I As Integer, wordPath As String
    Dim arr2(1 To 3000, 1 To 14)
    Dim WordApp As Object, wdDoc As Object, Table As Object
    Dim myshape As Object, K As Long
    Set DiaFile = Application.FileDialog(msoFileDialogFilePicker)
    With DiaFile
        .AllowMultiSelect = False
        .Filters.Clear
        .InitialFileName = ThisWorkbook.Path
        .Filters.Add "word Files", "*.doc*"
        .Title = "请选择Word 文件"
        If .Show() = -1 Then
            wordPath = .SelectedItems(1)
        End If
    End With

    If Len(wordPath) > 0 Then
        Application.ScreenUpdating = False
        Set WordApp = CreateObject("Word.Application")

        Set wdDoc = WordApp.Documents.Open(wordPath)
        For I = 1 To wdDoc.Tables.Count
            '----------------处理表格-----------------------------
            Set Table = wdDoc.Tables(I)
            K = K + 1
            arr2(I, 1) = Replace(Table.cell(2, 2).Range.Text, Chr(13) & Chr(7), "")        '姓名
            arr2(I, 2) = Replace(Table.cell(2, 4).Range.Text, Chr(13) & Chr(7), "")        '性别
            arr2(I, 3) = Replace(Table.cell(3, 2).Range.Text, Chr(13) & Chr(7), "")        '学籍号
            arr2(I, 4) = Replace(Table.cell(3, 6).Range.Text, Chr(13) & Chr(7), "")        '出生日期
            arr2(I, 5) = "'" & Replace(Table.cell(4, 4).Range.Text, Chr(13) & Chr(7), "")        'sfz
            arr2(I, 6) = Replace(Table.cell(5, 2).Range.Text, Chr(13) & Chr(7), "")        '所在学校
            arr2(I, 7) = Replace(Table.cell(6, 6).Range.Text, Chr(13) & Chr(7), "")        '所在学校
            arr2(I, 8) = Replace(Table.cell(7, 2).Range.Text, Chr(13) & Chr(7), "")        '所在学校
            arr2(I, 9) = Replace(Table.cell(10, 2).Tables(1).cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
            arr2(I, 10) = Replace(Table.cell(10, 2).Tables(1).cell(2, 3).Range.Text, Chr(13) & Chr(7), "")
            arr2(I, 11) = Replace(Table.cell(10, 2).Tables(1).cell(3, 2).Range.Text, Chr(13) & Chr(7), "")
            arr2(I, 12) = Replace(Table.cell(10, 2).Tables(1).cell(3, 3).Range.Text, Chr(13) & Chr(7), "")
            arr2(I, 13) = Replace(Table.cell(13, 1).Range.Text, Chr(13) & Chr(7), "")        '学籍变动时间
            arr2(I, 14) = Replace(Table.cell(13, 2).Range.Text, Chr(13) & Chr(7), "")        '学籍变动情况
            Set Table = Nothing
            '----------------处理图片-----------------------------
            Set myshape = wdDoc.InlineShapes(I)
            If myshape.Type = 3 Then
                myshape.Select
                Set myshape = myshape.ConvertToShape
                With myshape
                    .ScaleHeight 1, True, msoScaleFromMiddle
                    .ScaleWidth 1, True, msoScaleFromMiddle
                End With

                wdDoc.ActiveWindow.Selection.Copy
                With Worksheets("Sheet1").ChartObjects.Add(0, 0, myshape.Width, myshape.Height).Chart
                    .Parent.Select
                    .Paste
                   ' .Export wdDoc.Path & "\提取后重命名的照片\" & arr2(I, 3) & ".jpg" '相片以学籍号命名
                  
                   ' .Export wdDoc.Path & "\提取后重命名的照片\" & arr2(I, 1) & arr2(I, 3) & ".jpg" '相片以姓名和学籍号命名
                   If Not fso.FileExists(wdDoc.Path & "\提取后重命名的照片\" & arr2(I, 1) & ".jpg") Then '判断，如果图片文件夹不存在同名图片，则以学生姓名命名
                        .Export wdDoc.Path & "\提取后重命名的照片\" & arr2(I, 1) & ".jpg"  '相片以学生名字命名
                   Else '如果图片文件夹存在同名图片，则以学生姓名及学籍号命名以示区分
                     .Export wdDoc.Path & "\提取后重命名的照片\" & arr2(I, 1) & arr2(I, 3) & ".jpg" '以学生姓名及学籍号命名
                   End If
                       .Parent.Delete
                End With
                '还原
                Set myshape = myshape.ConvertToInlineShape
               End If
        Next
        wdDoc.Close 0
        WordApp.Quit
        Set wdDoc = Nothing
        Set WordApp = Nothing
        If K > 0 Then
            Sheet1.Range("A2").Resize(K, 14) = arr2
            MsgBox "操作完成。感谢Excehome技术论坛的“未忘初心“和 “ione_fox“大师！"
        End If
    End If
    Application.ScreenUpdating = True
    Set fso = Nothing
End Sub

yylucke

用姓名加学籍号命名照片即可

szqhb

yylucke 发表于 2023-4-6 12:09
用姓名加学籍号命名照片即可

谢谢你的关心！