Importer billeder fra URL-problemer

Jeg har brugt et VBA-script til at importere billeder til en celle baseret på en URL. Det fungerer godt, men billedet forsvinder, hvis jeg sletter eller ændrer linket. Med Kutools billedimport, er billedet indsat i cellen som et permanent billede?

Jeg har til hensigt at e-maile Excel-regnearket til en person, der ikke vil have adgang til min lokale harddisk. Det betyder, at billederne forsvinder.

Her er den VBA, jeg bruger i øjeblikket: Jeg har også problemer med at kopiere og indsætte i Word ved hjælp af denne VBA. Jeg kan kun kopiere og indsætte omkring ti billeder i Word, hvilket tager tid, hvis man har mange billeder.

Sub AddImageToRight()
Dim OrigSelection As Range
Indstil OrigSelection = Selection
For hver celle i udvalgt
ThisPath = cell.Value
HoldHøjre = celle.Offset(0, 1).Værdi
celle.Offset(0, 1).Slet
Err.Clear
On Error Resume Next
celle.Offset(0, 1).Vælg
Selection.InsertPictureInCell (ThisPath)
Hvis Err.Number <> 0 Så Selection.Value = HoldRight
Næste celle
OrigSelection.Select
End Sub

~~~~~~~~~~~~~~~~~~~~~~

Denne erstattede URL'en med et billede, men jeg havde stadig et problem med at kopiere og indsætte det i Word. Plus jeg mistede min URL i cellen, som blev erstattet med et billede.

Sub ReplacePathWithImage()
Dim OrigSelection As Range
Indstil OrigSelection = Selection
For hver celle i udvalgt
ThisPath = cell.Value
celle.Ryd
Err.Clear
On Error Resume Next
celle. Vælg
Selection.InsertPictureInCell (ThisPath)
Hvis Err.Number <> 0 Så cell.Value = ThisPath
Næste celle
OrigSelection.Select
End Sub


~~~~~~~~~~~~~~~~~~~~~

Her er hvad jeg brugte tidligere, men billedet ville ikke indsætte sig selv i cellen. Jeg måtte manuelt klikke på hvert billede for at indsætte det i den celle, jeg ønskede. Det var tæt på, men det var en smerte. Dette er et problem, hvis du har over 200 billeder flydende i Excel, som skal matches til en celle til venstre.

Sub ImportPicturesFromColumn()
Dim ws As Arbejdsark
Dim picturePath As String
Dim billede som billede
Dim picWidth As Double
Dim picHeight As Double
Dim maxWidth As Double
Dim maxHøjde Som Dobbelt
Dim aspektforhold som dobbelt
Dæmp celle som område
Dæmp startCell As Range
Dæmp targetCell As Range

' Indstil regnearket til "CA-ExcelExport"
Indstil ws = ThisWorkbook.Sheets("CA-ExcelExport")

' Indstil den maksimale bredde og højde for billedet
maxWidth = 420 ' Indstil til din ønskede maks. bredde
maxHeight = 420 ' Indstil til din ønskede max højde

' Indstil startcellen for listen over billedstier
Set startCell = ws.Range("K4") ' Begynd at læse stier fra celle K4

' Gå gennem hver celle i kolonnen, indtil der findes en tom celle
For hver celle i ws.Range(startCell, ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp))
billedsti = celle.Value

' Stop behandlingen, hvis der stødes på en tom celle
Hvis picturePath = "" Så
Afslut til
End If

' Tilføj billedet til arbejdsarket
Set pic = ws.Pictures.Insert(picturePath)

' Få billedets originale mål
picWidth = pic.Width
picHeight = pic.Højde

' Beregn billedformatet
aspektRatio = picWidth / picHeight

' Juster billedstørrelsen for at bevare billedformatet
Hvis picWidth > maxWidth Eller picHeight > maxHeight Så
Hvis (maxWidth / maxHeight) > aspektforhold derefter
picHeight = maxHeight
picWidth = maxHeight * aspectRatio
Else
picWidth = maxWidth
picHeight = maxWidth / aspectRatio
End If
End If

' Indstil de nye dimensioner
pic.Width = picWidth
pic.Height = picHeight

' Bestem målcellen for billedet
Set targetCell = ws.Cells(cell.Row, "Q") ' Placer billedet i kolonne H, samme række som filstien

' Placer billedet i målcellen
pic.Top = targetCell.Top
pic.Left = targetCell.Left

' Du kan eventuelt ændre størrelsen på cellen, så den passer til billedet
targetCell.RowHeight = Application.Max(targetCell.RowHeight, pic.Height)
targetCell.ColumnWidth = Application.Max(targetCell.ColumnWidth, pic.Width / 5.7) ' Juster kolonnebredden
Næste celle
End Sub