Opgelost VBA script werkt enkel in template edit mode, niet als normaal open

[Bjorkie]

beste specialisten,
ik heb een Excel template bestand, waar ik vele functies in heb, die quasi allemaal werken als ik in 'template edit' modus gestart heb.
(excel template bestand openen)
Maar, als ik op dit bestand gewoon dubbel klick, dan open ik een nieuw normaal bestand, dan is er steeds 1 script dat weigert om te werken.
heeft iemand enig idee?
al mijn andere scripts werken wel, enkel deze voegt de afbeeldingen niet in het document

'Import jpg images from created list

'   Declare variables
    Dim Afb_map As String
    Dim myarray As Variant
    Dim sShape As Shape
    Dim lRow As Long
    Dim lLoop As Long
'   Const Afb_map = ActiveWorkbook.Path & "\images\"
    Afb_map = ActiveWorkbook.Path & "\images\"
    
    myarray = WorksheetFunction.Transpose(Range("D3", Range("D" & Rows.Count).End(xlUp)).Value)
''    ActiveSheet.Protect False, False, False, False, False
    ' Check if myarray is an array
    If Not IsArray(myarray) Then Exit Sub
'    On Error Resume Next
    ' Loop through the array and insert images
    lRow = 3
    For lLoop = LBound(myarray) To UBound(myarray)
        ' Construct the full path to the image
        Dim imagePath As String
        imagePath = Afb_map & "\" & myarray(lLoop) & ".jpg"
        ' Check if the image file exists before adding it
        If Dir(imagePath) <> "" Then
            Set sShape = ActiveSheet.Shapes.AddPicture(imagePath, msoFalse, msoCTrue, _
                Cells(1, 1).Left + 15, Cells(lRow, 2).Top + 8, -1, -1)
            With sShape
                .LockAspectRatio = msoTrue
                .Height = 20
            End With
         lRow = lRow + 1
        End If
        Application.ScreenUpdating = True
'Protect with a password
        ThisWorkbook.Protect Password:="test"

    Next

 

[JEC.]

Je zegt dat er een nieuw bestand aangemaakt wordt?
Probeer dan eens ActiveWorkbook te vervangen door ThisWorkbook in je bovenstaande code.

 

[Bjorkie]

hoi, dit lost het spijtig genoeg niet op.
het bestand is een template. de bedoeling is dat als men er dubbel op klikt, er een nieuwe lege versie opengaat.
en enkel deze functie doet het niet.
als ik mijn origineel bestand 'open' (template bewerkings mode), dan werkt het script wel....
ik snap eigenlijk niet waar het verschil kan liggen.

 

[HSV]

Ik zie nergens in je code dat er een nieuw bestand wordt geopend/aangemaakt.

Wel zie ik een backslash in dit stukje,....

imagePath = Afb_map & "\" & myarray(lLoop) & ".jpg"

terwijl er aan het einde hiervan

Afb_map = ActiveWorkbook.Path & "\images\"

ook een backslash is geplaatst.
Dat zorgt bij:

imagePath = Afb_map & "\" & myarray(lLoop) & ".jpg"

voor een dubbele backslash.

imagePath = Afb_map & "\\" & myarray(lLoop) & ".jpg"

 

[snb]

Het belangrijkste aan de code , de naam, heb je niet geplaatst.
Bekend met gebeurteniscode ?

 

[Bjorkie]

@HSV: Het hoofdbestand is een 'Microsoft Exec Macro-Enabled Template'. dus bij dubbel-klik, gaat dit als zijnde een gewoon Macro-Enables document open. ik heb jouw aanpassingen uitgevoerd, maar geeft geen verschil.
nogmaals: als ik het bestand 'open' (geen dubbel klik), dan werkt het wel.
doe ik het open met dubbel-klik, dan is deze code de enige die faalt.

hier de volledige code. enkel het laatste deel doet zijn werk niet correct.
wel als je de 'template' opent (rechtse knop - openen)
niet als je template dubbel-klikt (

Sub Generate_EquipmList()
'Unprotect workbook with a password
    ThisWorkbook.Unprotect Password:="test"
Application.ScreenUpdating = False
'Clear current equipment list
    Worksheets("Equipment List").Range("A3:D100").Select
    Selection.Clear
    Dim Pic As Object
    For Each Pic In Worksheets("Equipment List").Pictures
    Pic.Delete
    Next Pic
'**************************************************************************************
'Camera List Page
'Copy short Camera List to Equipment page where quantity is equal or higher then 0
    Worksheets("Camera list").Range("$AW$5:$AY$244").EntireColumn.Hidden = False
    Worksheets("Camera List").Range("$AW$5:$AY$244").AutoFilter
    Worksheets("Camera List").Range("$AW$5:$AX$244").AutoFilter Field:=2, Criteria1:=">0", _
    Operator:=xlAnd
    'copy filtered data
    Worksheets("Camera List").Range("$AW$5:$AY$244").Copy
    'Start at first empty line on Equipment page and copy camera list
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B" & lMaxRows + 1).Select
    Application.CutCopyMode = False
    Worksheets("Camera List").Range("$AW$5:$AY$244").AutoFilter
    Worksheets("Camera list").Range("$AW$5:$AY$244").EntireColumn.Hidden = True
'*******************************************************************************************
'Recorder Page
    Worksheets("recorders").Range("$BA:$BF").EntireColumn.Hidden = False
    'Create Hardware list and copy item to Equipment list, to last empty line
    'Make filter on Hardware and select all where quant is >=1
    Worksheets("Recorders").Range("$A$32:$C$60").AutoFilter
    Worksheets("Recorders").Range("$A$30:$C$60").AutoFilter Field:=2, Criteria1:=">=1", _
        Operator:=xlAnd
    'Copy filtered data from colum A to first empty line in Equipment list sheet
    Worksheets("Recorders").Range("$A$33:$A$60").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
'    'Copy filtered data from colum H to first empty line in Equipment list sheet
    Worksheets("Recorders").Range("$C$33:$C$60").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "D").End(xlUp).Row
    Range("D" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    'Copy filtered data from colum G to first empty line in Equipment list sheet
    Worksheets("Recorders").Range("$B$33:$B$60").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
    Range("C" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
'    Worksheets("Recorders").Range("A32:H32").AutoFilter
'********************************************************************************************
'Accesories page
    ' Clear_Short Accesories list
    Worksheets("Accesories list").Range("G5:I75").ClearContents
    'Generate Short Accesories list
    'Filter accesories list where quanity is not 0 and copy to Accesories list
    Worksheets("Accesories list").Range("B4:D4").AutoFilter
    Worksheets("Accesories list").Range("$B$4:$D$75").AutoFilter Field:=2, Criteria1:=">0", _
        Operator:=xlAnd
    'Copy filtered data from colum B to first empty line in Equipment list sheet
    Worksheets("Accesories list").Range("B5:B75").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
'
'Copy filtered data from colum A to first empty line in Equipment list sheet
    Worksheets("Accesories list").Range("C5:C75").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
    Range("C" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
'
'Copy filtered data from colum A to first empty line in Equipment list sheet
    Worksheets("Accesories list").Range("D5:D75").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "D").End(xlUp).Row
    Range("D" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
'
    Worksheets("Accesories list").Range("B4:D4").AutoFilter
'
'********************************************************************************************
'Collect used Switches
    'Execute filter for used switches
    Worksheets("Switch").Range("A379:C400").AutoFilter
    Worksheets("Switch").Range("$A$380:$C$380").AutoFilter Field:=2, Criteria1:=">0", _
        Operator:=xlAnd
    'Copy filtered data From colum A to Equipment page
    Worksheets("Switch").Range("A380:A400").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    'Copy filtered data From colum B to Equipment page
    Worksheets("Switch").Range("B380:B400").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
    Range("C" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    'Copy filtered data From colum C to Equipment page
    Worksheets("Switch").Range("C380:C400").Copy
    Worksheets("Equipment list").Select
    lMaxRows = Cells(Rows.Count, "D").End(xlUp).Row
    Range("D" & lMaxRows + 1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    Columns("C:D").HorizontalAlignment = xlCenter
    Columns("A").HorizontalAlignment = xlCenter
    Columns("A:D").VerticalAlignment = xlCenter
    Worksheets("switch").Range("A379:C400").AutoFilter
'    select Cel A1 with cursor
   ActiveSheet.Range("A1").Select
'********************************************************************************************
'Import jpg images from created list

'   Declare variables
    Dim Afb_map As String
    Dim myarray As Variant
    Dim sShape As Shape
    Dim lRow As Long
    Dim lLoop As Long
'   Const Afb_map = ActiveWorkbook.Path & "\images\"
    Afb_map = ActiveWorkbook.Path & "\images\"
    
    myarray = WorksheetFunction.Transpose(Range("D3", Range("D" & Rows.Count).End(xlUp)).Value)
''    ActiveSheet.Protect False, False, False, False, False
    ' Check if myarray is an array
    If Not IsArray(myarray) Then Exit Sub
'    On Error Resume Next
    ' Loop through the array and insert images
    lRow = 3
    For lLoop = LBound(myarray) To UBound(myarray)
        ' Construct the full path to the image
        Dim imagePath As String
        imagePath = Afb_map & "" & myarray(lLoop) & ".jpg"
        ' Check if the image file exists before adding it
        If Dir(imagePath) <> "" Then
            Set sShape = ActiveSheet.Shapes.AddPicture(imagePath, msoFalse, msoCTrue, _
                Cells(1, 1).Left + 15, Cells(lRow, 2).Top + 8, -1, -1)
            With sShape
                .LockAspectRatio = msoTrue
                .Height = 20
            End With
         lRow = lRow + 1
        End If
        Application.ScreenUpdating = True
'Protect with a password
        ThisWorkbook.Protect Password:="test"
    Next
'    For lLoop = LBound(myarray) To UBound(myarray)
'        Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
'                Cells(1, 1).Left + 15, Cells(lRow, 2).Top + 8, -1, -1)
'                With sShape
'                    LockAspectRatio = msoTrue
'                    .Height = 20
'                End With

'    Next lLoop
' select Cel A1 on Equipment page with cursor
'    Worksheets("Equipment list").Range("A1").Select


End Sub

'new')

 

[Bjorkie]

Het belangrijkste aan de code , de naam, heb je niet geplaatst.
Bekend met gebeurteniscode ?

@snb:
ik heb maar enkel het 'gedeeltelijk-werkende ' deel van de code aangegeven.
is inmiddels ook volledig gepost, maar het issue zit hem in de staart

 

[jkpieterse]

Een template dat je opent via verkenner (of via Bestand, Nieuw en dan een keuze uit de templates maken) is nog nooit opgeslagen en heeft dus een leeg pad. Dus ThisWorkbook.Path is een lege string. Daar kan je helemaal niets tegen doen omdat Excel in tegenstelling tot Word geen relaties tussen een bestand en een template onderhoudt. Excel heeft dus geen enkel idee waar het oorspronkelijke template zich bevindt. Een workaround is om geen template te gebruiken maar een read-only bestand te gebruiken als "template". Je kunt er ook voor kiezen het pad hard-coded in het template op te nemen. Moet je er wel aan denken dit bij te werken als je het template ooit verplaatst.

 

[snb]

Een verkennerklik op een template creëert een nieuw bestand, gebaseerd op het template met dezelfde naam als het template, maar zonder enige extensie of fileformat of pad, zoals jkp al aangaf.
Een macro in het nieuwe bestand start je met de gebeurtenissen Workbook_open of Workbook_activate.

Ik zie overigens weinig aktiviteiten in je macro die niet als resultaat al onderdeel van het sjabloon kunnen zijn: een sjabloon kan al alle afbeeldingen bevatten die je er nu met VBA in gaat zetten.

En vermijd in VBA natuurlijk 'select' en 'Activate'.

 

[Bjorkie]

Een template dat je opent via verkenner (of via Bestand, Nieuw en dan een keuze uit de templates maken) is nog nooit opgeslagen en heeft dus een leeg pad. Dus ThisWorkbook.Path is een lege string. Daar kan je helemaal niets tegen doen omdat Excel in tegenstelling tot Word geen relaties tussen een bestand en een template onderhoudt. Excel heeft dus geen enkel idee waar het oorspronkelijke template zich bevindt. Een workaround is om geen template te gebruiken maar een read-only bestand te gebruiken als "template". Je kunt er ook voor kiezen het pad hard-coded in het template op te nemen. Moet je er wel aan denken dit bij te werken als je het template ooit verplaatst.

dus, als ik mijn 'template' bestand Bewerk, dan werkt het wel, maar als ik door dubbelklik van verkenner 'open' (nieuwe versie maak), dan werkt de functie 'WorkbookPath' niet, aangezien het nieuwe bestand nog niet opgeslagen geweest is...
ok, moet ik even een andere manier vinden... alvast allemaal zeer hartelijk bedankt voor jullie opmerkingen... top!

 

[snb]

Application.defaultfilepath

 

[Bjorkie]

beste allen,
ik denk dat ik het probleem gevonden het. Als ik mijn bestand en de map met afbeeldingen 'lokaal' op de PC staan heb, werkt de import van de images. Maar mijn voige map was in principe een 'One-Drive' gesynchroniseerde map. ik vermoed dat het daar fout gelopen is. net alles gecopieerd op lakale folder c:\temp, en daar werkt het perfect.
alles van harte bedankt voor jullie input.