По какой-либо причине этот код работает для некоторых изображений, а для других он просто выбрасывает изображение на рабочий лист в случайном месте, и я не могу понять, почему.Он также не может изменить соотношение сторон, когда несколько раз вытягивает его на листе.
Я пробовал варианты сохранения переменной изображения, но, похоже, ничего не работает.Расстраивающая часть - это случайность.В другом варианте кода (без цикла для отдельных изображений) код работал один день, а затем на следующий он больше не хочет изменять размер изображения.Я использую последнюю версию Excel (подписка 365).
Private Sub Workbook_Open()
Dim incomingloc As String
Dim incoming As Object
Dim nameplateloc As String
Dim nameplate As Object
Dim connection As Object
Dim connectionLoc As String
Dim dispicloc As String
Dim dispic As Object
Dim count As Integer
Dim count2 As Integer
Dim count3 As Integer
If Sheets("White Card").Range("AY1").Value = "X" Then 'Checks to See if the Incoming Picture & Nameplate Have Been Imported Before
If Sheets("Disassembly").Range("AY1").Value = "X" Then 'Checks to see if the Connection Diagram Has Been Imported Before
If Sheets("Motor Pictures").Range("F1").Value = "X" Then 'Checks to see if the Disassembly Pictures Have Been Imported Before
'Do Nothing All Pictures Have Been Imported
Else '3rd Main If Statement (Imports the Disassembly Pictures Once the Incoming & Connnection Diagram Have Been Imported)
count = 1
count2 = 1
count3 = 1
dispicloc = Sheets("White Card").Range("AY3") & "\" & count & ".jpg"
If Dir(dispicloc) <> "" Then
Result = MsgBox("Do You Want to Import the Disassembly Pictures", vbYesNo + vbQuestion)
If Result = vbYes Then
Do While Dir(dispicloc) <> ""
If count Mod 2 = 0 Then
Set dispic = Sheets("Motor Pictures").Pictures.Insert(dispicloc)
With dispic
'Resize the Picture
.ShapeRange.LockAspectRatio = msoFalse
.Left = Sheets("Motor Pictures").Range("D" & count2).Left
.Top = Sheets("Motor Pictures").Range("D" & count2).Top
.Width = Sheets("Motor Pictures").Range("D" & count2 & ":E" & count2).Width
.Height = Sheets("Motor Pictures").Range("D" & count2 & ":D" & count2 + 1).Height
.Placement = 1
.PrintObject = True
End With
count2 = count2 + 4
Else
Set dispic = Sheets("Motor Pictures").Pictures.Insert(dispicloc)
With dispic
'Resize the Picture
.ShapeRange.LockAspectRatio = msoFalse
.Left = Sheets("Motor Pictures").Range("A" & count3).Left
.Top = Sheets("Motor Pictures").Range("A" & count3).Top
.Width = Sheets("Motor Pictures").Range("A" & count3 & ":B" & count3).Width
.Height = Sheets("Motor Pictures").Range("A" & count3 & ":A" & count3 + 1).Height
.Placement = 1
.PrintObject = True
End With
count3 = count3 + 4
End If
count = count + 1
dispicloc = Sheets("White Card").Range("AY3") & "\" & count & ".jpg"
Loop
Sheets("Motor Pictures").Range("F1").Value = "X"
Else
MsgBox "You Can Add The Motor Pictures Later Using the Associated Button", vbInformation
End If
Else
'No Disassembly Pictures Found Do Nothing
End If
End If 'Third Main If Statement
Else '(Second Main If Statement) If the Incoming Pictures Have Been Imported but Not the Connection Diagram Proceed With a Prompt for Connection Diagram
End If 'Second Main If Statement
Else '(1st Main If Statement) If the Incoming Picture And Namplate Haven't Been Added Then Proceed With That Prompt to Import Them
End If '1st Main If Statement
End Sub