excel - Excel VBA：图片的神秘移位

Question

我正在创建成员列表并使用以下代码添加成员照片。该代码可用于添加照片，但照片的位置有时会无缘无故地移动。照片应该被添加到每条记录的左上角。当它不起作用时，照片会逐渐向下移动并最终进入下一个记录（见截图）。我已经记录了照片的顶部位置（p.top），并将未移动的位置与正在移动的位置进行比较。我发现它们是相同的。换句话说，向下移动的照片的顶部位置与不移动的照片的顶部位置相同。如果顶部位置相同，照片不应该出现在同一位置而不是移动吗？

Sub add_PHOTO()
'add photo to file
 Dim p As Shape
Dim record_num As Long
'    Dim LOGO_Path_Prefix As String
Const PHOTO_Path_Prefix1 = "D:\test1\"
Const PHOTO_Path_Prefix2 = "D:\test2\"
Const LOGO_Path_Prefix = "D:\test3\"
Dim Actual_PHOTO_Path As String  'the actual string used for the path of the photo
Dim Total_Record_Num As Long
Const Photo_Width = 161
Const Photo_Height = 190
Const vOffset = 2.5 
Const hOffset = 2   

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Total_Record_Num = Workbooks("test.xlsx").Sheets("Sheet1").Range("B65536").End(xlUp).Row

ThisWorkbook.Sheets("Sheet1").Pictures.Delete
For Each p In ThisWorkbook.Sheets("Sheet1").Shapes
    p.Delete
Next

'Total_Record_Num = Workbooks("test.xlsx").Sheets("Sheet1").Range("B65536").End(xlUp).Row

With ThisWorkbook.Sheets("Sheet1")

    On Error Resume Next

    For record_num = 0 To Total_Record_Num Step 1
        'insert photo
        'check if photo exists
        If Len(.Range("C" & record_num * Rows_Per_Record + 1)) <> 0 Then
            
            'find the path for the photo
            If Len(Dir(PHOTO_Path_Prefix1 & .Range("C" & record_num * Rows_Per_Record + 1) & ".png", vbNormal)) <> 0 Then
                Actual_PHOTO_Path = PHOTO_Path_Prefix1
            ElseIf Len(Dir(PHOTO_Path_Prefix2 & .Range("C" & record_num * Rows_Per_Record + 1) & ".png", vbNormal)) <> 0 Then
                Actual_PHOTO_Path = PHOTO_Path_Prefix2
            End If
        
            Set p = .Shapes.AddPicture(Filename:=Actual_PHOTO_Path & .Range("C" & record_num * Rows_Per_Record + 1) _
                & ".png", LinkToFile:=False, SaveWithDocument:=True, Left:=.Cells(record_num * Rows_Per_Record + 6, 1).Left + hOffset, _
                Top:=.Cells(record_num * Rows_Per_Record + 1, 1).Top + vOffset, Width:=Photo_Width, Height:=Photo_Height)

' record position of photos

            Workbooks("test.xlsx").Sheets("Sheet2").Cells(record_num + 1, 1) = record_num + 1
            Workbooks("test.xlsx").Sheets("Sheet2").Cells(record_num + 1, 2) = .Cells(record_num + 1, 1).Address
            Workbooks("test.xlsx").Sheets("Sheet2").Cells(record_num + 1, 3) = .Cells(record_num * Rows_Per_Record + 1, 1).Top + vOffset
            Workbooks("test.xlsx").Sheets("Sheet2").Cells(record_num + 1, 4) = p.Top
            Workbooks("test.xlsx").Sheets("Sheet2").Cells(record_num + 1, 5) = .Range("C" & record_num * Rows_Per_Record + 1).Text
            Set p = Nothing 

snipped

照片没有移动 ================== 照片移动

标签： excelvba