如何提取学籍卡的内容和提取照片重命名

中和无忌

求助：提取学籍卡的内容到及照片，内容提取到EXCEL，照片用学籍号重命名

未忘初心

1. Sub Main()
   
2.    'Date:2019/2/27 正月廿三 Wednesday
   
3.    '标签:word导出图片
   
4.    '备注:
   
5.     Dim DiaFile As FileDialog, i As Integer, wordPath As String
   
6.     Dim arr2(1 To 3000, 1 To 14)
   
7.     Dim wordApp As Object, wdDoc As Object, Table As Object
   
8.     Dim myshape As Object, k As Long
   
9.     Set DiaFile = Application.FileDialog(msoFileDialogFilePicker)
   
10.     With DiaFile
    
11.         .AllowMultiSelect = False
    
12.         .Filters.Clear
    
13.         .InitialFileName = ThisWorkbook.path
    
14.         .Filters.Add "word Files", "*.doc*"
    
15.         .Title = "请选择Word 文件"
    
16.         If .Show() = -1 Then
    
17.             wordPath = .SelectedItems(1)
    
18.         End If
    
19.     End With
    
20. 
    
21.     If Len(wordPath) > 0 Then
    
22. 
    
23.         Set wordApp = CreateObject("Word.Application")
    
24. 
    
25.         GetObject(wordPath).Close 0
    
26. 
    
27.         Set wdDoc = wordApp.Documents.Open(wordPath)
    
28.         For i = 1 To wdDoc.Tables.Count
    
29.             '----------------处理表格-----------------------------
    
30.             Set Table = wdDoc.Tables(i)
    
31.             k = k + 1
    
32.             arr2(i, 1) = Replace(Table.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")        '姓名
    
33.             arr2(i, 2) = Replace(Table.Cell(2, 4).Range.Text, Chr(13) & Chr(7), "")        '性别
    
34.             arr2(i, 3) = Replace(Table.Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")        '学籍号
    
35.             arr2(i, 4) = Replace(Table.Cell(3, 6).Range.Text, Chr(13) & Chr(7), "")        '出生日期
    
36.             arr2(i, 5) = "'" & Replace(Table.Cell(4, 4).Range.Text, Chr(13) & Chr(7), "")        'sfz
    
37.             arr2(i, 6) = Replace(Table.Cell(5, 2).Range.Text, Chr(13) & Chr(7), "")        '所在学校
    
38.             arr2(i, 7) = Replace(Table.Cell(6, 6).Range.Text, Chr(13) & Chr(7), "")        '所在学校
    
39.             arr2(i, 8) = Replace(Table.Cell(7, 2).Range.Text, Chr(13) & Chr(7), "")        '所在学校
    
40.             arr2(i, 9) = Replace(Table.Cell(10, 2).Tables(1).Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
    
41.             arr2(i, 10) = Replace(Table.Cell(10, 2).Tables(1).Cell(2, 3).Range.Text, Chr(13) & Chr(7), "")
    
42.             arr2(i, 11) = Replace(Table.Cell(10, 2).Tables(1).Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")
    
43.             arr2(i, 12) = Replace(Table.Cell(10, 2).Tables(1).Cell(3, 3).Range.Text, Chr(13) & Chr(7), "")
    
44.             arr2(i, 13) = Replace(Table.Cell(13, 1).Range.Text, Chr(13) & Chr(7), "")        '学籍变动时间
    
45.             arr2(i, 14) = Replace(Table.Cell(13, 2).Range.Text, Chr(13) & Chr(7), "")        '学籍变动情况
    
46.             Set Table = Nothing
    
47.             '----------------处理图片-----------------------------
    
48.             Set myshape = wdDoc.InlineShapes(i)
    
49.             If myshape.Type = 3 Then
    
50.                 myshape.Select
    
51.                 Set myshape = myshape.ConvertToShape
    
52.                 With myshape
    
53.                     .ScaleHeight 1, True, msoScaleFromMiddle
    
54.                     .ScaleWidth 1, True, msoScaleFromMiddle
    
55.                 End With
    
56. 
    
57.                 wdDoc.ActiveWindow.Selection.Copy
    
58.                 With Sheet1.ChartObjects.Add(0, 0, myshape.Width, myshape.Height).Chart
    
59.                     .Paste
    
60.                     .Export wdDoc.path & "\提取后重命名的照片" & arr2(i, 3) & ".jpg"
    
61.                     .Parent.Delete
    
62.                 End With
    
63.                 '还原
    
64.                 Set myshape = myshape.ConvertToInlineShape
    
65.                 With myshape
    
66.                     .Height = 83.9
    
67.                     .Width = 54.15
    
68.                 End With
    
69.             End If
    
70.         Next
    
71.         wdDoc.Close 0
    
72.         wordApp.Quit
    
73.         Set wdDoc = Nothing
    
74.         Set wordApp = Nothing
    
75.         If k > 0 Then
    
76.             Sheet1.Range("A2").Resize(k, 14) = arr2
    
77.             MsgBox "完成"
    
78.         End If
    
79.     End If
    
80. End Sub

复制代码

未忘初心

看看是不是这样 O(∩_∩)O


1.rar (67.52 KB, 下载次数: 126)

2019-2-27 14:22 上传

点击文件名下载附件

ione_fox

1. Sub Mian()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. Application.EnableEvents = False
   
5. Application.StatusBar = True
   
6. Dim Path$, File$, WordApp, Dic, Br(1 To 10000, 1 To 14)
   
7.     Path = ThisWorkbook.Path & ""
   
8.     File = Dir(Path & "学生学籍卡.doc*")
   
9.     Set Dic = Data()
   
10.     Set WordApp = CreateObject("Word.Application")
    
11.     WordApp.Visible = False
    
12.     Dim Table, Doc, RKey, Ckey, K&, KK&, eTable
    
13. 
    
14.     '=遍历Word的table
    
15.     Set Doc = WordApp.Documents.Open(Path & File)
    
16.     For Each Table In Doc.Tables
    
17.     K = K + 1
    
18.         With Table
    
19.          Set eTable = Table.cell(10, 2).Tables(1)
    
20.          Br(K, 9) = Replace(eTable.cell(2, 2).Range.Text, "", "")
    
21.          Br(K, 10) = Replace(eTable.cell(2, 3).Range.Text, "", "")
    
22.          Br(K, 11) = Replace(eTable.cell(3, 2).Range.Text, "", "")
    
23.          Br(K, 12) = Replace(eTable.cell(3, 3).Range.Text, "", "")
    
24.         KK = 0
    
25.             For Each RKey In Dic.keys
    
26.                 For Each Ckey In Dic(RKey).keys
    
27.                 KK = KK + 1
    
28.                     Br(K, KK) = Replace(.cell(RKey, Ckey).Range.Text, "", "")
    
29.                     If KK = 8 Then KK = KK + 4
    
30.                 Next
    
31.             Next
    
32.         End With
    
33.         Doc.InlineShapes(I).Copy
    
34.     Next
    
35.     Doc.Close
    
36.     WordApp.Visible = True
    
37.     WordApp.Quit
    
38.     Set WordApp = Nothing
    
39.     Range("a2").Resize(K, 14) = Br
    
40.     MsgBox "读取数据成功"
    
41.     Application.StatusBar = False
    
42.     Application.EnableEvents = True
    
43.     Application.ScreenUpdating = True
    
44.     Application.DisplayAlerts = True
    
45. End Sub
    
46. 
    
47. 
    
48. Private Function Data()
    
49. Dim Ar, Dic, I&, J&
    
50.     Ar = Sheets("取数规则").Range("a1").CurrentRegion
    
51.     Set Dic = CreateObject("Scripting.Dictionary")
    
52.     For I = 2 To UBound(Ar)
    
53.     Set Dic(Ar(I, 1)) = CreateObject("Scripting.Dictionary")
    
54.         For J = 2 To UBound(Ar, 2)
    
55.             If Ar(I, J) <> "" Then
    
56.                 Dic(Ar(I, 1))(Ar(I, J)) = True
    
57.             End If
    
58.         Next J
    
59.     Next
    
60.     Set Data = Dic
    
61. End Function
    

复制代码

ione_fox

发现个小问题 ：
With Sheet1.ChartObjects.Add(0, 0, myshape.Width, myshape.Height).Chart
                     .Parent.Select'16版测试不过
                    .Paste
                    .Export wdDoc.path & "\提取后重命名的照片" & arr2(i, 3) & ".jpg"
                    .Parent.Delete
                End With

dyzx

未忘初心 发表于 2019-2-27 14:18
看看是不是这样 O(∩_∩)O

老师：非常好用，无问题

中和无忌

二楼大神，谢谢，正是我想要的结果

amzxfgh9632

提取的图片是白板，难道是我版本的问题？

中和无忌

呵，我点开图片查看也是白板，还请大神完善下

未忘初心

中和无忌 发表于 2019-2-27 17:52
呵，我点开图片查看也是白板，还请大神完善下

你的什么版本呢