reac

LoadByPicture

Sep 3rd, 2019
108
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub LoadByPicture()
  2.  
  3. Const ROW_FIRST = 2
  4. Const COL_ID = 1
  5. Const COL_LOADED = 2
  6. Const COL_BARCODE = 3
  7.  
  8. Dim pictname As String
  9. Dim pictpath As String
  10. Dim pictext As String
  11.  
  12. Dim pastehere As Range
  13. Dim pasterow As Long
  14. Dim i As Long
  15. Dim lastrow As Long
  16.  
  17. Dim pict As Picture
  18. Dim pictloaded As Boolean
  19.  
  20.     On Error Resume Next
  21.  
  22.     pictpath = "D:\Dev\AGC\barcodes\barcode_"
  23.     pictext = ".png"
  24.    
  25.     lastrow = Worksheets("Data").Range("A1").CurrentRegion.Rows.Count
  26.     For i = ROW_FIRST To lastrow
  27.    
  28.         Set pastehere = Cells(i, COL_BARCODE)
  29.         pasterow = pastehere.Row
  30.         Cells(pasterow, COL_BARCODE).Select
  31.         pictname = Cells(i, COL_ID)
  32.        
  33.         '/// Check to see if any of the pictures in the current sheet
  34.        '/// have the same position as the cell in the current row,
  35.        '/// if they do, we already have a barcode loaded.
  36.        pictloaded = False
  37.         For Each pict In ActiveSheet.Pictures
  38.             If pict.TopLeftCell = Cells(i, COL_BARCODE) Then
  39.                 pictloaded = True
  40.                 Exit For
  41.             End If
  42.         Next
  43.        
  44.         If Not pictloaded Then
  45.        
  46.            ActiveSheet.Pictures.Insert(pictpath & pictname & pictext).Select
  47.            With Selection
  48.                .Left = Cells(pasterow, COL_BARCODE).Left
  49.                .Top = Cells(pasterow, COL_BARCODE).Top
  50.                .ShapeRange.LockAspectRatio = msoTrue
  51.                .ShapeRange.Height = 80#
  52.                .ShapeRange.Width = 80#
  53.                .ShapeRange.Rotation = 0#
  54.            End With
  55.            
  56.         End If
  57.        
  58.     Next
  59.  
  60. End Sub
RAW Paste Data