Opgelost Connector wordt niet geplaatst

Dit topic is als opgelost gemarkeerd
K

KeBr

Gebruiker
Lid geworden
25 apr 2016
Berichten
164
Beste,

Ik heb onderstaande macro voor het plaatsen van een ElbowConnector. Echter de macro wordt wel uitgevoerd maar de connector wordt niet geplaatst.
In de bijlage heb ik een paar cellen geel gemarkeerd die ik met de inputbox selecteer.
Ook merk ik dat de begindatum altijd verder moet liggen dan de einddatum.
Waar gaat het hier fout?
Code: 
Sub Add_ConnectorElbow()
    Dim ws As Worksheet
    Dim Date1 As Shape
    Dim Date2 As Shape
    Dim Connector As Shape
    
    ' Set the active worksheet (you can adjust this as needed)
    Set ws = ActiveSheet
    
    ' Assuming Shape1 and Shape2 represent your existing shapes (you can adjust these references)
    For d1 = Application.InputBox("geef startdatum", Type:=1) + 2 To Application.InputBox("geef einddatum", Type:=1)
    
    r = Application.Match(d1, ActiveSheet.Rows(6), 0) 'zoek die dag op in de rij 6
                        If IsNumeric(r) Then 'gevonden
                             Set C = ActiveSheet.Cells(ActiveCell.Row, r)
                        If NewShp Is Nothing Then
    ' Add a straight connector between Shape1 and Shape2
    Set NewShp = ActiveSheet.ws.Shapes.AddConnector(msoConnectorElbow, 1, 1, 1, 1)
    
        End If
    End If
    Next
End Sub
 

Bijlagen

  • Test voor msoconnector.xlsm
    34,8 KB · Weergaven: 6
@kees

zolang ik in 'jouw' code dit zie:
Set ws = ActiveSheet
Set NewShp = ActiveSheet.ws.Shapes.AddConnector(msoConnectorElbow, 1, 1, 1, 1)

Lijkt het me tamelijk zinloos suggesties te geven.
Je zult je toch eerst moeten verdiepen in de basisbeginselen van VBA.

De betekenis van Shape in het Engels ontgaat je blijkbaar ook.
In 'jouw' code komen geen afbeeldingen voor.
Extra argument om met die basisbeginselen te beginnen.

Dat geldt natuurllijk ook voor al die gedeclareerde variabelen die in de code niet voorkomen.
 
Een elbow connector wordt in het algemeen gebruikt om items op verschillende rijen met elkaar te verbinden, in jouw opzet is daar geen sprake van. Ik weet niet waar je de code in je Worksheet_Change event vandaan hebt gehaald, maar de opmaak is vreselijk.
Begin hier eens mee:
Code: 
Sub Add_ConnectorElbow()
    Dim NewShp As Shape
    Dim C1 As Range, C2 As Range
    
    Set C1 = Application.InputBox("selecteer cel start", Type:=8)
    Set C2 = Application.InputBox("selecteer cel einde", Type:=8)
    ' elbowconnector van het midden van C1 naar het midden van C2
    Set NewShp = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, C1.Left + C1.Width / 2, C1.Top + C1.Height / 2, C2.Left + C2.Width / 2, C2.Top + C2.Height / 2)
    NewShp.Line.Weight = 2
End Sub
 
Beste AHulpje,

De Worksheet_Change event heb ik samengesteld uit een aantal subonderdelen die ik op internet heb gevonden. Deze ziet er inderdaad niet netjes uit, maar doet nu wel wat moet. Als het geheel klaar is wil ik een en nader gaan opschonen.
De code die jij hierboven aangeeft werkt in elk geval, alleen nu de vraag hoe krijg ik de connector gekoppeld aan de shapes. Nu staat deze gewoon in de datumvelden.
ik heb onderstaande al toegevoegd aan beide regels, maar dat werkt niet.
Code: 
r = Application.Match(C1, ActiveSheet.Rows(6), 0) 'zoek die dag op in de rij 6
                        If IsNumeric(r) Then 'gevonden
                             Set C1 = ActiveSheet.Cells(ActiveCell.Row, r)
 
Aan welke shapes in welke rijen wil je de elbow connector koppelen?
 
Beste AHulpje,

Dat is juist het probleem. Het moet op elke rij mogelijk zijn om te koppelen op basis van de datum in kolommen E en F. Hiervoor heb ik dus juist de Inputbox toegevoegd.
 
Nog een kleine aanvulling.
de connector wordt alleen bij msoShapeLeftRightArrow toegepast.
 
Het is mij nog niet duidelijk. Wordt het een handmatige actie waarbij je een datum uit kolom E en een datum uit kolom F selecteert, ieder uit een andere rij (rij1 en rij2) waarna een elbow connector geplaatst wordt van cel(rij1,datumkolom1) naar cel(rij2, datumkolom2)?

Of alleen bij msoShapeLeftRightArrow , dus direct na
Code: 
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, DtRng.Left, DtRng.Top + 3, DtRng.Width, DtRng.Height - 6)
?
 
Het wordt inderdaad een handmatige actie, wel met een commandbutton, de gebruikers moeten dus aangeven welke shapes zij gelinkt willen hebben. Hierbij is het zo dat bij een datum uit datumkolom1 (E kolom) de connector altijd aan de linkerzijde van de shape moet komen en uit datumkolom2 (kolom F) altijd aan de rechterzijde.
Op de bijlage heb ik ze voor de duidelijkheid even handmatig ingevoegd. Paarse (van datumkolom 2 naar datumkolom 1 en groene van datumkolom1 naar datumkolom 1. (van 2 naar 2 komt nooit voor.

Hopelijk is het zo duidelijker.
 

Bijlagen

  • Test voor msoconnector.xlsm
    34,8 KB · Weergaven: 1
Zo?
 

Bijlagen

  • Test voor msoconnector AH.xlsm
    37,4 KB · Weergaven: 3
Beste AHulpje,

Bedankt voor je reactie. In de basis voldoet deze code. Echter als ik 2 regels uit datumkolom1 wil koppelen gaat het nog fout.
Ik ga eerst zelf even kijken of ik het opgelost krijg.
 
Beste AHulpje,

Ik heb het nu voor elkaar zodat het werkt voor mij. Heb er wel 2 code voor moeten maken. Ik vraag mij echter af of de code niet eenvoudiger kan met b.v. Select Case.
Code: 
Sub Add_ElbowConnector_R_L()
    Dim NewShp As Shape
    Dim rng1 As Range, rng2 As Range
    
    Set rng1 = Application.InputBox("Selecteer een datum in kolom F", Type:=8)
    r1 = rng1.Row
    d1 = CDbl(rng1)
    k1 = Application.Match(d1, ActiveSheet.Rows(6), 0) 'zoek de datum op in rij 6
    
    Set rng2 = Application.InputBox("Selecteer een datum in kolom E", Type:=8)
    r2 = rng2.Row
    d2 = CDbl(rng2)
    k2 = Application.Match(d2, ActiveSheet.Rows(6), 0) 'zoek de datum op in rij 6
    
    Set C1 = Cells(r1, k1)
    Set C2 = Cells(r2, k2)
    ' elbowconnector van de rechterkant van C1 naar de linkerkant van C2 msoConnectorStraight
    Set NewShp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, C1.Left + C1.Width + 0, C1.Top + C1.Height / 2, C1.Left + 15.5, C1.Top + C1.Height + 2 / 2)
    NewShp.Line.Weight = 1
    Set NewShp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, C2.Left - 15.5 + C2.Width + 0, C2.Top + C2.Height / 2, C2.Left - 7.5, C2.Top + C2.Height / 2)
    NewShp.Line.Weight = 1
    
    Set NewShp = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, C1.Left + C1.Width, C1.Top + 6 + C1.Height / 2, C2.Left - 7.5, C2.Top + C2.Height / 2)
    NewShp.Line.Weight = 1
    NewShp.Select
    Selection.ShapeRange.Adjustments.Item(1) = 1
  
End Sub
Sub Add_ElbowConnector_L_L()
    Dim NewShp As Shape
    Dim rng1 As Range, rng2 As Range
    
    Set rng1 = Application.InputBox("Selecteer een datum in kolom F", Type:=8)
    r1 = rng1.Row
    d1 = CDbl(rng1)
    k1 = Application.Match(d1, ActiveSheet.Rows(6), 0) 'zoek de datum op in rij 6
    
    Set rng2 = Application.InputBox("Selecteer een datum in kolom E", Type:=8)
    r2 = rng2.Row
    d2 = CDbl(rng2)
    k2 = Application.Match(d2, ActiveSheet.Rows(6), 0) 'zoek de datum op in rij 6
    
    Set C1 = Cells(r1, k1)
    Set C2 = Cells(r2, k2)
    ' elbowconnector van de rechterkant van C1 naar de linkerkant van C2 msoConnectorStraight
    Set NewShp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, C1.Left - 15.5 + C1.Width + 0, C1.Top + C1.Height / 2, C1.Left - 7.5, C1.Top + C1.Height / 2)
    NewShp.Line.Weight = 1
    Set NewShp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, C2.Left - 15.5 + C2.Width + 0, C2.Top + C2.Height / 2, C2.Left - 7.5, C2.Top + C2.Height / 2)
    NewShp.Line.Weight = 1
    
    Set NewShp = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, C1.Left - 15.5 + C1.Width, C1.Top + C1.Height / 2, C2.Left - 7.5, C2.Top + C2.Height / 2)
    NewShp.Line.Weight = 1
    NewShp.Select
    Selection.ShapeRange.Adjustments.Item(1) = 1
  
End Sub
 

Bijlagen

  • Test voor msoconnector AH.xlsm
    31,6 KB · Weergaven: 3
C2.Width=15,75, dus je zou
C2.Left - 15.5 + C2.Width + 0
prima kunnen vervangen door
C2.Left

C1.Height = 12, dus je zou
C1.Top + 6 + C1.Height / 2
prima kunnen vervangen door
C1.Top + C1.Height

En ik neem aan dat je hiermee
C1.Top + C1.Height + 2 / 2
eigenlijk dit bedoelt:
C1.Top + C1.Height / 2

en ergens nul bij optellen heeft ook niet zoveel zin.

In bijgaande versie is er één Sub Add_Elbowconnector(RL) die met verschillende actuele parameters wordt aangeroepen.
 

Bijlagen

  • Test voor msoconnector AH 2.xlsm
    37,9 KB · Weergaven: 4
Beste AHulpje,

Bedankt voor je reactie. deze versie doet precies wat ik verwacht.

Heb ik nog een aanvullende vraag, Ik heb via Google al veel macro's gezien om Shapes te verwijderen. echter om alleen de Shapes van deze macro te verwijderen (msoConnectorStraight en msoConnectorElbow) kan ik niet vinden. Ik wil ze dan allemaal gelijk verwijderen.
 
Geef je connectors allemaal een naam, eventueel met een volgnummer (en ja, meerdere connectors mogen dezelfde naam hebben):
Code: 
NewShp.Name = "MijnConnector"
Dan kun je alle connectors met de naam "MijnConnector" verwijderen, bijvoorbeeld zo:
Code: 
Sub VerwijderConnectors()
    For Each shp In ActiveSheet.Shapes
        Debug.Print shp.Name
        If Left(shp.Name, 13) = "MijnConnector" Then shp.Delete
    Next
End Sub
 
Je moet ingelogd zijn om te kunnen reageren. Log in | Registreer
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan