VBA 插入图片

chunyu.wu

于 2024-07-22 14:00:47 发布

阅读量538

点赞数 6

分类专栏： VBA 文章标签： VBA

本文链接：https://blog.csdn.net/wuchunyu002/article/details/140607890

版权

VBA 专栏收录该内容

64 篇文章 3 订阅

订阅专栏

1. 引用方式

Pictures.Insert是引用图片的路径，图片不随文件一起保存，当引用路径下的图片被删除后，文件中的图片就会显示空。

2. 非引用方式

Shapes.AddPicture的方式，图片会随文件一起被保存，而非引用图片路径。

语法：
Shapes.AddPicture( Filename , LinkToFile , SaveWithDocument , Left , Top , Width , Height )

3. 代码

Option Explicit

'------------------------------
' 引用方式：圖片是路徑
'------------------------------
Sub sbInsertPicture()
    Dim strPath As String
    Dim strFile As String
    Dim ws As Worksheet
    
    '既存Sheetを削除
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "カタログ" And ws.Visible = True Then ws.Delete
    Next
    Application.DisplayAlerts = True
    
    
    'イメージを読み込む
    strPath = ThisWorkbook.path & "\"
    strFile = Dir(strPath & "*.jpg")
    While Len(strFile) > 0
        ActiveWindow.DisplayGridlines = False
        Sheets.Add after:=Sheets(ActiveSheet.Name)
        ActiveSheet.Name = strFile
        ActiveSheet.Range("B3").Select
        ActiveSheet.Pictures.Insert(strPath & strFile).Select
        strFile = Dir
    Wend
    
    '一番のシートを選択
    Sheets("カタログ").Select
    ActiveSheet.Range("A1").Select
    
End Sub

'------------------------------
' 非引用方式：圖片隨文件保存
'------------------------------
Sub sbAddPicture()
    Dim ws As Worksheet
    Dim strPath As String, strFile As String
    
    '既存Sheetを削除
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "カタログ" And ws.Visible = True Then ws.Delete
    Next
    Application.DisplayAlerts = True
    
    'イメージを読み込む
    strPath = ThisWorkbook.path & "\"
    strFile = Dir(strPath & "*.jpg")
    While Len(strFile) > 0
        ActiveWindow.DisplayGridlines = False
        Sheets.Add after:=Sheets(ActiveSheet.Name)
        ActiveSheet.Name = strFile
        ActiveSheet.Shapes.AddPicture(strPath & strFile, True, True, Range("B3").Left, Range("B3").Top, -1, -1).Placement = xlMoveAndSize
        
        strFile = Dir
    Wend
    
    '一番のシートを選択
    Sheets("カタログ").Select
    ActiveSheet.Range("A1").Select
    
End Sub

'------------------------------
' 建立目录
'------------------------------
Sub sbCatalog()
    Dim i As Integer
    Dim ws As Worksheet
    Dim strShtName As String

    i = 2
    
    Columns(1).ClearContents
    Columns(2).ClearContents
    
    For Each ws In Worksheets
        If ws.Visible = xlSheetVisible Then
            strShtName = ws.Name
            If strShtName <> ActiveSheet.Name Then
                'カタログ作成
                i = i + 1
                ActiveSheet.Cells(i, 1) = i - 2
                ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 2), Address:="", SubAddress:="'" & strShtName & "'!A1", TextToDisplay:="◆" & strShtName

                'カタログに戻る
                If ws.Range("A1") = vbNullString Or ws.Range("A1") = "カタログに戻る" Then
                    ws.Hyperlinks.Add anchor:=ws.Cells(1, 1), Address:="", SubAddress:="'" & ActiveSheet.Name & "'!A1", TextToDisplay:="カタログに戻る"
                    ws.Range("A1").Font.Size = 16
                    ws.Range("A1").Font.Bold = True
                End If
            End If
        End If
    Next ws

End Sub