VBA 向Word插入图片

最新推荐文章于 2024-10-15 04:19:06 发布

laocooon523857886

最新推荐文章于 2024-10-15 04:19:06 发布

阅读量3.8k

点赞数 2

分类专栏： VB VBA 文章标签： python 开发语言

本文链接：https://blog.csdn.net/laocooon/article/details/126757610

版权

VB 同时被 2 个专栏收录

96 篇文章

订阅专栏

VBA

6 篇文章

订阅专栏

VBA 向Word插入图片

Private Sub Document_open()
   快捷键设置代码成功 "Fun1"
End Sub
Sub 快捷键设置代码成功(SubName As String)
    CustomizationContext = NormalTemplate '添加到模板里面
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKey1), _
    KeyCategory:=wdKeyCategoryMacro, Command:=SubName
End Sub

Sub Fun1()
UserForm1.Show
End Sub

'UserForm1
Option Explicit

Private Sub CheckBox1_Click()
    获取所有文件 (TextBox1.Text)
    If UBound(arrFiles) = 0 Then CheckBox1.Value = False
End Sub

Private Sub CheckBox2_Click()
    If CheckBox2.Value Then
        If cntFolders = 0 Then
            CheckBox2.Value = False
            Exit Sub
        End If
        Label2.Caption = 子目录选择及状态
    Else
        Label2.Caption = "全部都不选"
    End If
    Label2.Enabled = CheckBox2.Value
End Sub

Private Sub CommandButton1_Click()
    strRoot = 文件夹路径
    If strRoot = "" Then Exit Sub
    
    TextBox1.Text = strRoot
    '以下将当前目录下所有子目录加到动态数组中
    '统计子目录个数
    strRoot = TextBox1.Text
    Call 获取子目录
    If cntFolders > 0 Then
        子目录选择及状态 = "所有子目录"
        CheckBox2.Value = True
    Else
        子目录选择及状态 = "全部都不选"
        CheckBox2.Value = False
    End If
    获取所有文件 (TextBox1.Text)
    If UBound(arrFiles) = 0 Then
     CheckBox1.Value = False
    Else
    CheckBox1.Value = True
    End If
End Sub

Private Function 文件夹路径() As String
Dim strFolder As String
     '差异：msoFileDialogFolderPicker
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        .InitialFileName = strRoot
        If .Show Then
            strFolder = .SelectedItems(1)
        End If
    End With
    文件夹路径 = strFolder
End Function



Private Sub CommandButton2_Click()
Dim Column As Long
Dim Remarks As Long ' 0 1 2 无备注行  备注行只有数字   备注行只有文件名
Dim Clear As Long ' 1清空  0 文档尾直接插入
Dim 插空行 As Long '插了为1， 没插为0
Column = 2
Remarks = 0
Clear = 1

If OptionButton1 Then Column = 2
If OptionButton2 Then Column = 3

If OptionButton3 Then Remarks = 0
If OptionButton4 Then Remarks = 1
If OptionButton5 Then Remarks = 2
If OptionButton8 Then Remarks = 3

If OptionButton6 Then Clear = 1
If OptionButton7 Then Clear = 0 '尾部插图片 要先计算从第几行开始工作

 全局编号 = 0
 目录编号 = 0
If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
    MsgBox "文档已保护，此时不能改变内容"
    Exit Sub
End If
If TextBox1.Text = "" Then
    MsgBox "没有选择的具体内容"
    Exit Sub
End If
Application.ScreenUpdating = False

If Clear Then
'清空文档
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
End If
    
    If ActiveDocument.Tables.Count = 0 Then '没有表格先建立一个表格 减少后期代码量
                ActiveDocument.Tables.Add Range:=Selection.Range, numrows:=1, numcolumns:=Column, _
                defaulttablebehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
                ActiveDocument.Tables(1).PreferredWidth = 18.87 * 28.35 / 1.3
                       ActiveDocument.Tables(1).LeftPadding = 1
                插空行 = 1
                全局编号 = Column
    Else '重新计算全局编号 现有行数 X Column
    If Clear = 0 And Remarks = 0 Then
        全局编号 = ActiveDocument.Tables(1).Rows.Count * Column
    Else
    
    End If
'                If Remarks = 0 Then
'                全局编号 = ActiveDocument.Tables(1).Rows.Count * Column
'                Else '求出目录编号个数 和全局编号个数
'
'                '全局编号 = ActiveDocument.Tables(1).Rows.Count * Column / 2
'                End If
    End If
    
'插入主函数 参数 Column,Remarks
If CheckBox1 Then
    InsertMainFunction Column, Remarks, strRoot
End If

'Label2 子目录三种情况
'全部都不选
'所有子目录
'部分子目录


'以下内容是根据参数插入了图片
Dim i As Long
Select Case Label2.Caption
Case "全部都不选"
    '直接无视，没有信息加入
Case "所有子目录"
    For i = 0 To cntFolders - 1
        InsertMainFunction Column, Remarks, strRoot & "\" & strFolders(i)
    Next
Case "部分子目录"
    For i = 0 To UserForm2.ListBox1.ListCount - 1
    
        If UserForm2.ListBox1.Selected(i) Then InsertMainFunction Column, Remarks, strRoot & "\" & UserForm2.ListBox1.List(i)
    Next
End Select


'以下内容根据情况配上数字编号 或 文字
If Remarks = 1 Then  '数字 或 文字
    全局编号 = -1
    If CheckBox1 Then
        InsertNumFunction Column, strRoot
    End If

    Select Case Label2.Caption
    Case "全部都不选"
        '直接无视，没有信息加入
    Case "所有子目录"
        For i = 0 To cntFolders - 1
            InsertNumFunction Column, strRoot & "\" & strFolders(i)
        Next
    Case "部分子目录"
        For i = 0 To UserForm2.ListBox1.ListCount - 1
            If UserForm2.ListBox1.Selected(i) Then InsertNumFunction Column, strRoot & "\" & UserForm2.ListBox1.List(i)
        Next
    End Select
End If


'以下内容根据情况配上数字编号 或 文字
If Remarks = 2 Then  '文字
    全局编号 = -1
    If CheckBox1 Then
        InsertStrFunction Column, strRoot
    End If

    Select Case Label2.Caption
    Case "全部都不选"
        '直接无视，没有信息加入
    Case "所有子目录"
        For i = 0 To cntFolders - 1
            InsertStrFunction Column, strRoot & "\" & strFolders(i)
        Next
    Case "部分子目录"
        For i = 0 To UserForm2.ListBox1.ListCount - 1
            If UserForm2.ListBox1.Selected(i) Then InsertStrFunction Column, strRoot & "\" & UserForm2.ListBox1.List(i)
        Next
    End Select
End If


If Remarks = 3 Then
    全局编号 = -1
    If CheckBox1 Then
        InsertAllFunction Column, strRoot
    End If

    Select Case Label2.Caption
    Case "全部都不选"
        '直接无视，没有信息加入
    Case "所有子目录"
        For i = 0 To cntFolders - 1
            InsertAllFunction Column, strRoot & "\" & strFolders(i)
        Next
    Case "部分子目录"
        For i = 0 To UserForm2.ListBox1.ListCount - 1
            If UserForm2.ListBox1.Selected(i) Then InsertAllFunction Column, strRoot & "\" & UserForm2.ListBox1.List(i)
        Next
    End Select
End If

If Remarks Then '将目录名插入适当位置
    全局编号 = 1
    If CheckBox1 Then
        InsertFoldersFunction Column, strRoot
    End If

    Select Case Label2.Caption
    Case "全部都不选"
        '直接无视，没有信息加入
    Case "所有子目录"
        For i = 0 To cntFolders - 1
            InsertFoldersFunction Column, strRoot & "\" & strFolders(i)
        Next
    Case "部分子目录"
        For i = 0 To UserForm2.ListBox1.ListCount - 1
            If UserForm2.ListBox1.Selected(i) Then InsertFoldersFunction Column, strRoot & "\" & UserForm2.ListBox1.List(i)
        Next
    End Select
End If
' 如果是新插入 第一行进行删除
   If 插空行 Then ActiveDocument.Tables(1).Rows(1).Delete
Me.Hide
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton3_Click()
Me.Hide
End Sub

Private Sub Frame1_Click()

End Sub

Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Label2.Font.Underline = False
    Label2.Font.Bold = False
End Sub

Private Sub Label2_Click()
    '处理集合中，想要和不想要的内容 一个新的界面
    
    If TextBox1.Text = "" Then
        MsgBox "根目录信息并不存在，无法处理子目录", vbOKOnly, "提示信息"
        Exit Sub
    End If
    UserForm2.Caption = strRoot & " 目录下子目录的选择 共计(" & cntFolders & ")个文件"
    UserForm2.Left = UserForm1.Left + UserForm1.Width
    UserForm2.Top = UserForm1.Top
    
    UserForm2.ListBox1.Clear
    Dim i As Long
    For i = 0 To cntFolders - 1
        UserForm2.ListBox1.AddItem strFolders(i)
    Next
    UserForm2.Label1.Caption = UserForm2.ListBox1.ListCount & "个文件被选中"
    UserForm2.Show
End Sub

Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Label2.Font.Underline = True
    Label2.Font.Bold = True
End Sub


Private Sub UserForm_Initialize()
    strRoot = "H:\2022\VBA\"   '"d:\"
    子目录选择及状态 = "全部都不选"
    If cntFolders = 0 Then
    CheckBox2.Value = False
    End If
End Sub
Sub DelBlank()


Dim i As Paragraph, n As Long
Application.ScreenUpdating = False
For Each i In ActiveDocument.Paragraphs
If Len(i.Range) = 1 Then
i.Range.Deleten = n + 1
End If
Next
Application.ScreenUpdating = True
End Sub

'UserForm2
Option Explicit

Private Sub CommandButton1_Click()
    Me.Hide
End Sub

Private Sub CommandButton2_Click()
Dim i As Long
For i = 0 To cntFolders - 1
    UserForm2.ListBox1.Selected(i) = True
Next
End Sub

Private Sub ListBox1_Change()
  Dim cnt As Long
  Dim i As Long
  cnt = 0
  For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) Then cnt = cnt + 1
  Next
  If cnt = cntFolders Then
    子目录选择及状态 = "所有子目录"
  Else
    子目录选择及状态 = "部分子目录"
  End If
  
  
  If cnt = 0 Then
    UserForm1.CheckBox2.Value = False
  Else
    UserForm1.CheckBox2.Value = True
    UserForm1.Label2.Caption = 子目录选择及状态
  End If
  
  Label1.Caption = cnt & "个文件被选中"
End Sub

'模块1
Option Explicit
Public arrFiles() As String  '动态数组某目录下所有jpg文件名称

Public strRoot As String '根目录
Public strFolders() As String '动态数组子目录名称
Public cntFolders As Long '子目录实际个数
Public 子目录选择及状态 As String
Public 全局编号 As Long
Public 目录编号 As Long

Public Function 提取根目录名(path As String) As String
    Dim tmp
    tmp = Split(path, "\")
    提取根目录名 = tmp(UBound(tmp))
End Function

Public Function 获取子目录()
    Dim fso As Object, objFolder As Object, objSubFolder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(strRoot)
    
    cntFolders = 0
    ReDim strFolders(0)
    
    For Each objSubFolder In objFolder.SubFolders
        strFolders(cntFolders) = objSubFolder.Name
        ReDim Preserve strFolders(UBound(strFolders) + 1)
        cntFolders = cntFolders + 1
    Next
    Call Sort
End Function
Sub 获取所有文件(strFolder As String)
Dim fso As Object, objFolder As Object, objSubFolder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(strFolder)
    
    Dim objFile As Object ' File
    Dim lngFileCnt As Long
    ReDim arrFiles(0)
    lngFileCnt = 0
    For Each objFile In objFolder.Files
       
       Dim tmp
       tmp = Split(objFile.Name, ".")
       If tmp(UBound(tmp)) = "jpg" Then
            arrFiles(lngFileCnt) = objFile.Name
            lngFileCnt = lngFileCnt + 1
            ReDim Preserve arrFiles(lngFileCnt)
        End If
    Next objFile
    Sort1
End Sub
'排序 先分析转为数值进行排序，相等再进行字符比较
Sub Sort1()
Dim i, j
If UBound(arrFiles) < 1 Then Exit Sub
For i = 0 To UBound(arrFiles) - 2
    For j = 0 To UBound(arrFiles) - 2 - i
        If Val(arrFiles(j)) <> 0 And Val(arrFiles(j + 1)) <> 0 Then
            If Val(arrFiles(j)) > Val(arrFiles(j + 1)) <> 0 Then Swap arrFiles(j), arrFiles(j + 1)
        Else
            If arrFiles(j) > arrFiles(j + 1) <> 0 Then Swap arrFiles(j), arrFiles(j + 1)
        End If

Next j, i
End Sub
Sub GetAllFiles(ByVal objFolder As Object)
Dim objFile As Object ' File
Dim objSubFolder As Object ' Folder
Dim arrFiles()
Dim lngFileCnt As Long
Dim i As Long
ReDim arrFiles(1 To 1000)
lngFileCnt = 0
For Each objFile In objFolder.Files
lngFileCnt = lngFileCnt + 1
If lngFileCnt > UBound(arrFiles) Then ReDim Preserve arrFiles(1 To lngFileCnt + 1000)
lngSeqNo = lngSeqNo + 1
' arrFiles(lngFileCnt) = objFile.Path
ActiveSheet.Cells(lngSeqNo, 1).Value = objFile.path
Next objFile

If objFolder.SubFolders.Count = 0 Then Exit Sub

For Each objSubFolder In objFolder.SubFolders
GetAllFiles objSubFolder
Next
End Sub

'交换
Sub Swap(s1 As String, s2 As String)
Dim tmp As String
    tmp = s1: s1 = s2: s2 = tmp
End Sub
'排序 先分析转为数值进行排序，相等再进行字符比较
Sub Sort()
Dim i, j
If UBound(strFolders) < 1 Then Exit Sub
For i = 0 To cntFolders - 2
    For j = 0 To cntFolders - 2 - i
        If Val(strFolders(j)) <> 0 And Val(strFolders(j + 1)) <> 0 Then
            If Val(strFolders(j)) > Val(strFolders(j + 1)) <> 0 Then Swap strFolders(j), strFolders(j + 1)
        Else
            If strFolders(j) > strFolders(j + 1) <> 0 Then Swap strFolders(j), strFolders(j + 1)
        End If

Next j, i
End Sub


'插入指定 行 列 目录
Public Sub InsertMainFunction(Column As Long, Remarks As Long, FolderPath As String)
    Dim i, j, k
Dim Lines As Long
Dim shp As InlineShape
Dim strTmp As String
If Remarks = 0 Then Lines = 1 Else Lines = 2
'根据路径获取所有.jpg
'插入对应位置


    获取所有文件 FolderPath
    '先插入图片
        k = 0
    If Remarks = 0 Then '只有图片的方式插入的图片集中，中间没有空白格
        Do While (k < UBound(arrFiles))

                If 全局编号 Mod Column = 0 Then
                    ActiveDocument.Tables(1).Select
                    Selection.InsertRowsBelow 1
                End If
                
                i = 全局编号 Mod Column
                ActiveDocument.Tables(1).Cell(全局编号 / Column + 1, i + 1).Range.Select '选择第一行第一列
                Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                全局编号 = 全局编号 + 1
                'Selection.TypeText Text:=arrFiles(k)
                
                strTmp = FolderPath & "\" & arrFiles(k)
                Set shp = Selection.Range.InlineShapes.AddPicture(FileName:=strTmp)
                If Column = 2 Then
                    shp.Height = 6.7 * 28.35
                    shp.Width = 8.1 * 28.35
                End If
                If Column = 3 Then
                    shp.Height = 4.5 * 28.35
                    shp.Width = 4.8 * 28.35
                End If
                k = k + 1
        Loop
        
        Else '有说明的图片的，以文件夹为单位处理
        
            Do While (k < UBound(arrFiles))
                
                    ActiveDocument.Tables(1).Select
                    Selection.InsertRowsBelow 1
                    
                    For i = 1 To Column
                        全局编号 = 全局编号 + 1
                        ActiveDocument.Tables(1).Cell(全局编号 / Column + 1, i).Range.Select
                        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                        strTmp = FolderPath & "\" & arrFiles(k)
                        
                        Set shp = Selection.Range.InlineShapes.AddPicture(FileName:=strTmp)
                        If Column = 2 Then
                            shp.Height = 6.7 * 28.35
                            shp.Width = 8.1 * 28.35
                        End If
                        If Column = 3 Then
                            shp.Height = 4.5 * 28.35
                            shp.Width = 4.8 * 28.35
                        End If
                        k = k + 1
                        If k >= UBound(arrFiles) Then Exit For
                    Next
                    If k >= UBound(arrFiles) Then 全局编号 = 全局编号 + (Column - i)
            Loop
        
    End If
    
End Sub
'插入数字
Public Sub InsertNumFunction(Column As Long, FolderPath As String)
Dim i, j, k

Dim Lines As Long
    获取所有文件 FolderPath
        k = 0
        
            Do While (k < UBound(arrFiles))
                    '定位到1 3 5 7行，插入
                     全局编号 = 全局编号 + 2
                     If j + 1 > ActiveDocument.Tables(1).Rows.Count Then Exit Do
                    ActiveDocument.Tables(1).Rows(全局编号 + 1).Select
                    Selection.InsertRowsBelow 1
                    
                    For i = 1 To Column
                        ActiveDocument.Tables(1).Cell(全局编号 + 2, i).Range.Text = "" & (k + 1)
                        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                        k = k + 1
                        If k >= UBound(arrFiles) Then Exit For
                    Next
            Loop
End Sub

'插入汉字
Public Sub InsertStrFunction(Column As Long, FolderPath As String)
Dim tmp
Dim i, j, k
Dim Lines As Long
    获取所有文件 FolderPath
        k = 0
        
            Do While (k < UBound(arrFiles))
                    '定位到1 3 5 7行，插入
                     全局编号 = 全局编号 + 2
                     If j + 1 > ActiveDocument.Tables(1).Rows.Count Then Exit Do
                    ActiveDocument.Tables(1).Rows(全局编号 + 1).Select
                    Selection.InsertRowsBelow 1
                    
                    For i = 1 To Column
                    tmp = Split(arrFiles(k), ".jpg")
                        ActiveDocument.Tables(1).Cell(全局编号 + 2, i).Range.Text = "" & tmp(0)
                        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                        k = k + 1
                        If k >= UBound(arrFiles) Then Exit For
                    Next
            Loop
End Sub


'插入 编号+汉字
Public Sub InsertAllFunction(Column As Long, FolderPath As String)
Dim tmp
Dim i, j, k
Dim Lines As Long
    获取所有文件 FolderPath
        k = 0
        
            Do While (k < UBound(arrFiles))
                    '定位到1 3 5 7行，插入
                     全局编号 = 全局编号 + 2
                     If j + 1 > ActiveDocument.Tables(1).Rows.Count Then Exit Do
                    ActiveDocument.Tables(1).Rows(全局编号 + 1).Select
                    Selection.InsertRowsBelow 1
                    
                    For i = 1 To Column
                    tmp = Split(arrFiles(k), ".jpg")
                        ActiveDocument.Tables(1).Cell(全局编号 + 2, i).Range.Text = "" & (k + 1) & "_" & tmp(0)
                        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                        k = k + 1
                        If k >= UBound(arrFiles) Then Exit For
                    Next
            Loop
End Sub


Public Sub InsertFoldersFunction(Column As Long, FolderPath As String)
Dim tmp
Dim i, j, k
Dim Lines As Long
    获取所有文件 FolderPath
    ActiveDocument.Tables(1).Rows(全局编号).Select
    Selection.InsertRowsBelow 1
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    ActiveDocument.Tables(1).Cell(全局编号 + 1, i).Range.Text = "--" & 提取根目录名(FolderPath) & "--"
    With ActiveDocument.Tables(1)
        ActiveDocument.Range(.Cell(全局编号 + 1, 1).Range.Start, .Cell(全局编号 + 1, Column).Range.End).Cells.Merge
    End With
    
    If UBound(arrFiles) Mod Column <> 0 Then
        全局编号 = 全局编号 + (UBound(arrFiles) / Column + 1) * 2
        Else
        全局编号 = 全局编号 + 1 + (UBound(arrFiles) / Column) * 2
    End If
End Sub