Hallo nochmals

Bis anhin konnte mir leider noch niemand helfen. Ich habe nun versucht, das selber zu machen. Allerdings scheitere ich an der Auswahl meherer Dateien. Im momentanen Zustand wir nur 1 Datei namens "adjust.svg" imortiert u. verkleinert. Hat mir jemand einen Tipp, wie ich das Script anweisen kann mit allen Dateien im SVG Ordner auf diese Weise zu verfahren? Hier das Script, wie es momentan aussieht:

Sub Icons2Visio()

'

' Mehrere SVGs importieren

'

 

    Dim UndoScopeID1 As Long

    UndoScopeID1 = Application.BeginUndoScope("Importieren")

    Application.ActiveWindow.Page.Import "C:\Users\rnb\Pictures\ Icons_SVG\adjust.svg"

    Application.EndUndoScope UndoScopeID1, True

 

    Dim UndoScopeID2 As Long

    UndoScopeID2 = Application.BeginUndoScope("Füllbereichseigenschaften")

    Application.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(255,255,255))"

    Application.ActiveWindow.Page.Shapes.ItemFromID(1).Shapes.ItemFromID(2).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(255,255,255))"

    Application.EndUndoScope UndoScopeID2, True

 

    Application.ActiveWindow.SetViewRect -11.777778, 18.527778, 37.861111, 21.333333

 

    Application.ActiveWindow.SetViewRect -31.166667, 33.277778, 75.722222, 42.666667

 

    Dim UndoScopeID3 As Long

    UndoScopeID3 = Application.BeginUndoScope("Objektgröße ändern")

    Application.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = "91.604166666667 p"

    Application.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = "-12.479166666667 p"

    Application.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "1.2083333333333 p"

    Application.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "1.2083333333333 p"

    Application.EndUndoScope UndoScopeID3, True

 

    Dim UndoScopeID4 As Long

    UndoScopeID4 = Application.BeginUndoScope("Auf Schablone ablegen")

    ActiveWindow.DeselectAll

    ActiveWindow.Select Application.ActiveWindow.Page.Shapes.ItemFromID(1), visSelect

    Dim vsoSelection1 As Visio.Selection

    Set vsoSelection1 = ActiveWindow.Selection

    Dim vsoDoc1 As Visio.Document

    Set vsoDoc1 = Application.Documents.Item("Schablone5.vss")

    vsoDoc1.Drop vsoSelection1, 0#, 0#

    vsoSelection1.Delete

    Application.EndUndoScope UndoScopeID4, True

 

End Sub

Vielen Dank für eure Hilfe.

Beste Grüsse

rnb