Announcement

Collapse
No announcement yet.

Importing Pictures From Directory Unaligning The Further It Loops

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Importing Pictures From Directory Unaligning The Further It Loops



    Hi all,

    I have a piece of code that imports pictures from my directory in columns of 10 by X rows. For every row imported it seems to shift down by a pixel, overtime this starts to notice if I was to run it for a 1000 row, it would be shifted further down than what it should be.

    Now I canít for the life of me understand why as Iím not sure how to skip loop iterations through F8 to understand what itís doing. Hereís the following code:
    Code:
     Sub Box()      Dim oNewPic As Shape     Dim shpShape As Shape     Dim rngPicPosition As Range     Dim rngRange As Range     Dim x As Long     Dim iStartColumn As Long     Dim iStartRow As Long     Dim i As Long     Dim j As Long      '   Speed up processing     sbar ("Please wait ... importing pictures")     Call TurnOff      '   Delete existing data, including pictures (Shapes)     For Each shpShape In template.Shapes         shpShape.Delete     Next     With template         mylr = .Range("A1").SpecialCells(xlCellTypeLastCell).Row         mylc = .Range("A1").SpecialCells(xlCellTypeLastCell).Column         If mylr > 4 Then             Set rngRange = .Range(.Cells(2, 2), .Cells(mylr, mylc))             rngRange.ClearContents             Call NoBorders(rngRange)             rngRange.EntireRow.Delete         End If     End With      '   Insert Pictures     i = 1     j = 0     With data              mylr = LR(, .Name, "A")                  For x = 4 To mylr                      sbar ("Please wait ... importing picture " & i & " of " & mylr - 3)             iStartColumn = MyColLong(CStr(.Cells(x, 16).Value))                          If iStartRow <> .Cells(x, 18) Then                 iStartRow = .Cells(x, 18)                 Worksheets(template.Name).Cells(iStartRow, 1).RowHeight = 118.75             End If                          Set rngPicPosition = Worksheets(template.Name).Cells(iStartRow, iStartColumn)                          If FileExists(sFolder & .Cells(x, 10) & ".jpg") = False Then                              j = j + 1               If FileExists(lFolder & .Cells(x, 10) & ".png") = False Then                              Dim PNF As Worksheet, LR1 As Long                 Set PNF = ThisWorkbook.Sheets("Pictures Not Found DIR")                 LR1 = PNF.Cells(PNF.Rows.Count, "A").End(xlUp).Row + 1                                  If Application.WorksheetFunction.CountIf(PNF.Range("A2:A" & LR1), .Cells(x, 10)) > 0 Then                                  Else                                   PNF.Range("A" & LR1) = .Cells(x, 10)                                   End If               Else                 j = j - 1                                 Set oNewPic = Sheets(template.Name).Shapes.AddPicture(Filename:=lFolder & .Cells(x, 10) & ".png", _                                                                       linktofile:=msoFalse, _                                                                       savewithdocument:=msoCTrue, _                                                                       Left:=rngPicPosition.Left, _                                                                       Top:=rngPicPosition.Top, _                                                                       Width:=-1, Height:=-1)                 With oNewPic                     .Height = 100.629933                     .Width = 92.6929242                     .IncrementLeft 26.1                     .IncrementTop 8.7                     .LockAspectRatio = msoTrue                     .Rotation = 0                 End With                                                 End If                     rngPicPosition.Offset(1, 0) = .Cells(x, 10)                 rngPicPosition.Offset(2, 0) = .Cells(x, 11)                 rngPicPosition.Offset(1, 1) = .Cells(x, 14)                 rngPicPosition.Offset(0, -1) = .Cells(x, 5)                 rngPicPosition.Offset(3, 0) = .Cells(x, 13)                 rngPicPosition.Offset(3, 0).NumberFormat = "0"                 rngPicPosition.Offset(3, 1) = .Cells(x, 12)                 rngPicPosition.Offset(3, 1).NumberFormat = "$#,##0.00"                 If .Cells(x, 14) <> "" Then rngPicPosition.Offset(2, 1) = .Cells(x, 24)                 rngPicPosition.Offset(2, 1).NumberFormat = "0.0"                                                       Set rngRange = rngPicPosition.Resize(5, 2)                 Call MyLineStyle(rngRange)             Else                 Set oNewPic = Sheets(template.Name).Shapes.AddPicture(Filename:=sFolder & .Cells(x, 10) & ".jpg", _                                                                       linktofile:=msoFalse, _                                                                       savewithdocument:=msoCTrue, _                                                                       Left:=rngPicPosition.Left, _                                                                       Top:=rngPicPosition.Top, _                                                                       Width:=-1, Height:=-1)                 With oNewPic                     .Height = 100.629933                     .Width = 92.6929242                     .IncrementLeft 26.1                     .IncrementTop 8.7                     .LockAspectRatio = msoTrue                     .Rotation = 0                 End With                                  rngPicPosition.Offset(1, 0) = .Cells(x, 10)                 rngPicPosition.Offset(2, 0) = .Cells(x, 11)                 rngPicPosition.Offset(3, 0) = .Cells(x, 13)                 rngPicPosition.Offset(3, 0).NumberFormat = "0"                 rngPicPosition.Offset(1, 1) = .Cells(x, 14)                 rngPicPosition.Offset(0, -1) = .Cells(x, 5)                 rngPicPosition.Offset(3, 1) = .Cells(x, 12)                 rngPicPosition.Offset(3, 1).NumberFormat = "$#,##0.00"                 If .Cells(x, 14) <> "" Then rngPicPosition.Offset(2, 1) = .Cells(x, 24)                 rngPicPosition.Offset(2, 1).NumberFormat = "0.0"                                  Set rngRange = rngPicPosition.Resize(5, 2)                 Call MyLineStyle(rngRange)             End If             i = i + 1         Next x     End With       Set oNewPic = Nothing     Set rngPicPosition = Nothing     Set shpShape = Nothing     Set rngRange = Nothing          Call TurnOn          Call MergeCells          Call PrintArea          Call WidthHeight          mymsg = MsgBox(mylr - 3 & " Pictures have been processed, " & j & " of those were not found in the library.", vbOKOnly + vbInformation, "Information")   End Sub
    If you need further help with what itís pulling from in different sheets then Iíll be able to help tomorrow.

    Sorry not sure why it's coded horizontal lol! I used [ code ][ / code ] is this not the correct way/.

  • #2


    crossposted: https://www.excelforum.com/excel-pro...-it-loops.html

    Cross-posting is when you post the same question in other forums on the web. The last thing you want to do is waste people's time working on an issue you have already resolved elsewhere. We prefer that you not cross-post at all, but if you do (and it's unlikely to go unnoticed), you MUST provide a link (copy the url from the address bar in your browser) to the cross-post.

    Read this link: https://www.excelguru.ca/content.php?184
    Alan

    Did you debug your code first? http://www.cpearson.com/excel/DebuggingVBA.aspx
    FORUM RULES----->http://www.ozgrid.com/forum/announcement.php?f=8

    If someone has helped you, say "thank you" by clicking on the Like Button.

    Comment

    Working...
    X