批量插入图片到word表格中.

xyz444excel

代码的功能是
功能是.
自动根据输入的列数 CL
和filedialog 选择的图片数量导入如图的格式.
图片 自适应page宽度.


上下两个表格里面是.加上和不加上箭头指示的那句代码的区别.
有大婶知道原因吗...


以下是代码...

1. Option Explicit
   
2. 
   
3. Sub AddPic()
   
4. Dim CL, I&, Fn, ST&, RL&, SI
   
5. Dim W As Double, WW As Double
   
6. If Selection.Information(wdWithInTable) = True Then '在表格中则退出
   
7.     MsgBox "请选择非表格区域.", vbCritical + vbOKOnly, "警告..."
   
8.     Exit Sub
   
9. End If
   
10. 
    
11. CL = InputBox("请输入插入图片的列数.", "输入...")
    
12. If Not VBA.IsNumeric(CL) Then
    
13.     If CL = "" Then Exit Sub
    
14.     MsgBox "必须输入数字.", vbCritical + vbOKOnly, "警告..."
    
15.     Exit Sub
    
16. End If
    
17. 
    
18. If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
    
19.     Selection.TypeParagraph '在文末添加一空段
    
20. Else
    
21.     Selection.EndKey
    
22. End If
    
23. 
    
24. With ActiveDocument.PageSetup
    
25.     W = (.PageWidth - .LeftMargin - .RightMargin) / CL
    
26. End With
    
27. 
    
28. Application.ScreenUpdating = False
    
29. With Application.FileDialog(msoFileDialogFilePicker)    '选择文件
    
30.     .InitialView = msoFileDialogViewList
    
31.     .Filters.Add "图片文件", "*.jpg,*.png,*.bmp", 1
    
32.     .AllowMultiSelect = True
    
33.     If .Show = -1 Then
    
34.     ST = .SelectedItems.Count
    
35.         If ST Mod CL = 0 Then
    
36.             RL = (ST \ CL) * 2
    
37.         Else
    
38.             RL = ((ST \ CL) + 1) * 2
    
39.         End If
    
40.         Set SI = .SelectedItems
    
41.         Dim R&, C&, K&
    
42.         With ActiveDocument.Tables.Add(Selection.Range, RL, CL, 1, 1)    '新建表格
    
43.             .Borders.Enable = True
    
44.                 For Each Fn In SI
    
45.                     K = K + 1
    
46.                     R = (K - 1) \ CL + 1    '现在行
    
47.                     C = (K - 1) Mod CL + 1      '现在列
    
48.                     .Cell(R * 2 - 1, C).Select
    
49.                     Selection.Delete            '加这么奇葩的语句...暂时处理
    
50.                     With Selection.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
    
51.                         WW = .Width
    
52.                         .Width = W
    
53.                         .Height = .Height * (W / WW)
    
54.                     End With
    
55.                     .Cell(R * 2, C).Select
    
56.                     Selection.Text = Basename(Fn)
    
57.                 Next Fn
    
58.         End With
    
59.     End If
    
60. End With
    
61. Selection.EndKey
    
62. Application.ScreenUpdating = True
    
63. MsgBox "ok", vbInformation + vbOKOnly, "提示..."
    
64. End Sub
    
65. 
    
66. Function Basename(FullPath) '取得文件名
    
67. Dim x, y
    
68. Dim tmpstring
    
69. tmpstring = FullPath
    
70. x = Len(FullPath)
    
71. For y = x To 1 Step -1
    
72.     If Mid(FullPath, y, 1) = "" Or _
    
73.         Mid(FullPath, y, 1) = ":" Or _
    
74.         Mid(FullPath, y, 1) = "/" Then
    
75.         tmpstring = Mid(FullPath, y + 1)
    
76.         Exit For
    
77.     End If
    
78. Next
    
79. Basename = Left(tmpstring, Len(tmpstring) - 4)
    
80. End Function
    

复制代码