none
Excel VB 7.1 help with code RRS feed

  • Question

  • I have this code which works great in excel for adding pictures. The issue(s) I need help with is
    1. If I cancel the macro I get runtime error 13.
    2. The picture files if moved I lose the link. That I understand but wanted to embed after inserting.
    3. After going down inserting 15 pictures x 2 or 30 pics, it leaves 18 empty rows and insert more pictures.

    Thanks in advance for the help.

    Sub pic()
    Dim fileNameList
    Dim fileNum As Integer
    Dim ProcessFile
    x = 0
    Dim row
    Dim column

    row = 3
    column = 1
    fileNameList = Application.GetOpenFilename("Text Files (*.jpg), *.jpg", , , , True)
    Worksheets("Pictures").Cells(3, 1).Select
    For fileNum = 1 To UBound(fileNameList)
    ActiveSheet.Pictures.Insert(fileNameList(fileNum)).Select

    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 183
    Selection.ShapeRange.Width = 245
    Selection.ShapeRange.IncrementLeft 19.5
    Selection.ShapeRange.IncrementTop 13.5
    If x = 1 Then
    row = row + 18
    column = 1
    Worksheets("Pictures").Cells(row, column).Select
    x = 0
    Else
    column = 11
    Worksheets("Pictures").Cells(row, column).Select
    x = 1
    End If

    Next fileNum





    End Sub

    Tuesday, November 4, 2014 5:38 PM

Answers

  • Here you go:

    Sub pic()
        Dim fileNameList
        Dim fileNum As Long
        Dim row As Long
        Dim column As Long
        Dim x As Boolean
        x = False
        row = 3
        column = 1
        fileNameList = Application.GetOpenFilename _
            (FileFilter:="Text Files (*.jpg), *.jpg", MultiSelect:=True)
        ' Get out if no file selected.
        If VarType(fileNameList) = vbBoolean Then
            MsgBox "No files selected!", vbInformation
            Exit Sub
        End If
        Application.ScreenUpdating = False
        For fileNum = 1 To UBound(fileNameList)
            With ActiveSheet.Shapes.AddPicture(Filename:=fileNameList(fileNum), _
                    LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                    Left:=Cells(row, column).Left, Top:=Cells(row, column).Top, _
                    Width:=245, Height:=183)
                .LockAspectRatio = msoFalse
                .IncrementLeft Increment:=19.5
                .IncrementTop Increment:=13.5
            End With
            If x Then
                row = row + 18
                ' Go down 18 extra rows
                If row Mod 288 = 273 Then
                    row = row + 18
                End If
                column = 1
            Else
                column = 11
            End If
            x = Not x
        Next fileNum
        Application.ScreenUpdating = True
    End Sub

    Note that the code doesn't select the cells or shapes; that is more efficient.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, November 4, 2014 6:12 PM

All replies

  • Here you go:

    Sub pic()
        Dim fileNameList
        Dim fileNum As Long
        Dim row As Long
        Dim column As Long
        Dim x As Boolean
        x = False
        row = 3
        column = 1
        fileNameList = Application.GetOpenFilename _
            (FileFilter:="Text Files (*.jpg), *.jpg", MultiSelect:=True)
        ' Get out if no file selected.
        If VarType(fileNameList) = vbBoolean Then
            MsgBox "No files selected!", vbInformation
            Exit Sub
        End If
        Application.ScreenUpdating = False
        For fileNum = 1 To UBound(fileNameList)
            With ActiveSheet.Shapes.AddPicture(Filename:=fileNameList(fileNum), _
                    LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                    Left:=Cells(row, column).Left, Top:=Cells(row, column).Top, _
                    Width:=245, Height:=183)
                .LockAspectRatio = msoFalse
                .IncrementLeft Increment:=19.5
                .IncrementTop Increment:=13.5
            End With
            If x Then
                row = row + 18
                ' Go down 18 extra rows
                If row Mod 288 = 273 Then
                    row = row + 18
                End If
                column = 1
            Else
                column = 11
            End If
            x = Not x
        Next fileNum
        Application.ScreenUpdating = True
    End Sub

    Note that the code doesn't select the cells or shapes; that is more efficient.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, November 4, 2014 6:12 PM
  • Thanks, this work.  I changed to 17 extra rows since have to start at the 18th.  Works great after that change.  Since now unbound and addpicture the excel size is larger.

    Thanks again.

    Works.

    Brian

    Tuesday, November 4, 2014 6:48 PM