word如何設定圖片大小

misser wrote:
樓主，巨集我放進去囉(恕刪)

anson_830701 wrote:
有沒有辦法像之前有巨集1跟3那樣
可以有兩個快捷設定大小

anson_830701 wrote:
稍微把中間高度拉小就OK ，可能設定要改一下

anson_830701 wrote:
第一個範例目前是沒有動嗎?
還是第一個範例也有巨集了呢?

misser wrote:
不解？2張的部分，您(恕刪)

misser wrote:
不解？2張的部分，您(恕刪)

anson_830701 wrote:
原本-10改-20 之後左上要按儲存對吧?

anson_830701 wrote:
(我選兩張，格子會跑掉且沒看到選的照片)
《不知道是不適大小沒調好還要再調》

anson_830701 wrote:
目前遇到瓶頸
就是標題無法輸入

anson_830701 wrote:
https://youtu.be/MTWw0VX8tP8

misser wrote:
其實不用儲存，改了，(恕刪)

anson_830701 wrote:
目前遇到瓶頸
就是標題無法輸入

anson_830701 wrote:
再麻煩M大直接幫我改這個就好了
91頁的格子內能巨集

misser wrote:
[路燈相片-空白-2巨集沒滿格.zip，點擊下載]

Sub test()

    Dim Open_jpg As Object, Jpg_File As String, i As Integer, j As Integer, r  As Integer, c As Integer, n As Integer
    Dim Row_h As Integer, Col_w As Integer, Jpg_Sort(1 To 5, 1 To 2) As String, Inline_Shape As InlineShape, shp As Shape
    Dim AspectRatios As Single, Page_number As String, Max_Page As Integer, p As Integer
    
        
    Max_Page = 90
    Call clear_old_jpg(Max_Page)
    
    'Application.ScreenUpdating = False
    Page_number = InputBox("輸入要插入jpg的頁數1~" & Max_Page, "Page", 1)
    If Page_number = "" Then Exit Sub
    If CInt(Page_number) < 1 Or CInt(Page_number) > Max_Page Then Exit Sub
  
    MsgBox "照片只能選3張 or 4張，插入時等比例縮放置中", vbOKOnly
    
    For p = 1 To CInt(Page_number)
    
        Set Open_jpg = Application.FileDialog(FileDialogType:=msoFileDialogOpen)
retry:
        With Open_jpg
            .AllowMultiSelect = True
            .Filters.Add "照片", "*.jpg", 1
             If .Show = -1 And .SelectedItems.Count = 3 Or .SelectedItems.Count = 4 Then
            
                 For i = 1 To .SelectedItems.Count
                    Jpg_Sort(i, 1) = .SelectedItems(i)
                    Jpg_Sort(i, 2) = Shooting_Date(Jpg_Sort(i, 1), .InitialFileName, 12)
                 Next i
            
                '拍照日期排序
                '刪掉以下9行，可取消排序
                For i = 1 To .SelectedItems.Count - 1
                    For j = i + 1 To .SelectedItems.Count
                        If Jpg_Sort(i, 2) > Jpg_Sort(j, 2) Then
                            Jpg_Sort(5, 1) = Jpg_Sort(i, 1): Jpg_Sort(5, 2) = Jpg_Sort(i, 2)
                            Jpg_Sort(i, 1) = Jpg_Sort(j, 1): Jpg_Sort(i, 2) = Jpg_Sort(j, 2)
                            Jpg_Sort(j, 1) = Jpg_Sort(5, 1): Jpg_Sort(j, 2) = Jpg_Sort(5, 2)
                        End If
                    Next j
                Next i
            
                'AddPicture
                If .SelectedItems.Count = 4 And ActiveDocument.Tables(p).Rows(2).Cells.Count = 2 Then
                    ActiveDocument.Tables(p).Cell(2, 2).Split 1, 2
                    '插入2張jpg時，不要中間格線
                    ActiveDocument.Tables(p).Cell(2, 2).Borders(wdBorderRight).LineStyle = wdLineStyleNone
                Else
                    If .SelectedItems.Count = 3 And ActiveDocument.Tables(p).Rows(2).Cells.Count = 3 Then ActiveDocument.Tables(p).Cell(2, 2).Merge mergeto:=ActiveDocument.Tables(p).Cell(2, 3)
                End If
                
                n = 0
                For r = 1 To 3
                    For i = 2 To ActiveDocument.Tables(p).Rows(r).Cells.Count
                        n = n + 1
                        Row_h = ActiveDocument.Tables(p).Cell(r, i).Height
                        Col_w = ActiveDocument.Tables(p).Cell(r, i).Width
                    
                        Set Inline_Shape = ActiveDocument.Tables(p).Cell(r, i).Range.InlineShapes.AddPicture(FileName:=Jpg_Sort(n, 1), LinkToFile:=False, SaveWithDocument:=True)
                        With Inline_Shape
                        
                            AspectRatios = .Width / .Height
                            If .Height > Row_h Or .Width > Col_w Then
                                .Height = Row_h - 20
                                .Width = .Height * AspectRatios
                            End If
                            
                            'center test
                            .Select
                            Set shp = .ConvertToShape
                            With shp
                                .LockAnchor = True
                                .LockAspectRatio = msoTrue
                                .Top = (Row_h - .Height) / 2
                                .Left = wdShapeCenter
                            End With
                        
                        End With
                    Next i
                Next r
            Else
                If .SelectedItems.Count = 0 Then
                    Set Open_jpg = Nothing
                    'Application.ScreenUpdating = True
                    Exit Sub
                Else
                    MsgBox "只能選3張 or 4張", vbOKOnly
                    GoTo retry
                End If
            End If
        End With
        
    Next p
        
    'Application.ScreenUpdating = True
    Set Open_jpg = Nothing
    Set Inline_Shape = Nothing
    Set shp = Nothing


End Sub


Function Shooting_Date(JpgFile_name As String, JpgFile_path, n As Integer) 'n=12

    Dim Shell_Obj, Jpg_Folder, Jpg_Item
 
    Set Shell_Obj = CreateObject("Shell.Application")
    Set Jpg_Folder = Shell_Obj.Namespace(JpgFile_path)
    Set Jpg_Item = Jpg_Folder.ParseName(Replace(JpgFile_name, JpgFile_path, ""))
    
    If Not Jpg_Item Is Nothing Then
        Shooting_Date = Jpg_Folder.GetDetailsOf(Jpg_Item, n)
        'Debug.Print Shooting_Date
        '刪除不可見unicode字元
        Shooting_Date = Replace(Shooting_Date, ChrW(8206), "")
        Shooting_Date = Replace(Shooting_Date, ChrW(8207), "")
    End If
    
    If Shooting_Date = "" Then Shooting_Date = FileDateTime(JpgFile_name)
    '如果照片沒拍攝日期，就改用修改日期代替
    Debug.Print Shooting_Date

    Set Shell_Obj = Nothing
    Set Jpg_Folder = Nothing
    Set Jpg_Item = Nothing

End Function


Sub clear_old_jpg(Page_number As Integer)
'使用逐格刪除，避免舊版word來不及處理、refresh
    Dim r As Integer, i As Integer, p As Integer
    Application.ScreenUpdating = False
    On Error Resume Next
    For p = 1 To Page_number
        For r = 1 To 3
            For i = 2 To ActiveDocument.Tables(p).Rows(r).Cells.Count
                If ActiveDocument.Tables(p).Cell(r, i).Range.ShapeRange.Count > 0 Then
                    ActiveDocument.Tables(p).Cell(r, i).Range.ShapeRange.Delete
                End If
            Next i
        Next r
    Next p
    Application.ScreenUpdating = True
    Application.ScreenRefresh
End Sub

snare wrote:
這個版本，讓您玩看看(恕刪)