ShapeID ShapeNumber X Y 0 1 0 0 1 1 1 0 2 1 1 1 3 1 0 1 4 1 0 0 5 2 5 5 6 2 6 5 7 2 6 6 8 2 5 6 9 2 5 5 |
Public Sub Lines2rectangle()
Dim vsoSide1 As Visio.Shape
Dim vsoSide2 As Visio.Shape
Dim vsoSide3 As Visio.Shape
Dim vsoSide4 As Visio.Shape
Dim vsoRect1 As Shape
'Need to import the line endpoints from Excel
'Constructing rectangle could use DrawRectangle, which only requires the diagonal pair of points.
'Draw the four lines:
Set vsoSide1 = ActivePage.DrawLine(0, 0, 1, 0)
Set vsoSide2 = ActivePage.DrawLine(1, 0, 1, 1)
Set vsoSide3 = ActivePage.DrawLine(1, 1, 0, 1)
Set vsoSide4 = ActivePage.DrawLine(0, 0, 0, 0)
'Create rectangle shape:
ActiveWindow.DeselectAll
ActiveWindow.Select vsoSide1, visSelect
ActiveWindow.Select vsoSide2, visSelect
ActiveWindow.Select vsoSide3, visSelect
ActiveWindow.Select vsoSide4, visSelect
ActiveWindow.Selection.Join 'Closed shape created; still selected at this point
'Open shapesheet and populate:
ActiveWindow.Selection.PrimaryItem.OpenSheetWindow
ActiveWindow.Shape.CellsSRC(visSectionFirstComponent, 0, 0).FormulaU = 0
ActiveWindow.Shape.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(255,192,0))"
ActiveWindow.Shape.CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEME(""FillColor""),THEME(""FillColor2""))))"
ActiveWindow.Shape.CellsSRC(visSectionObject, visRowFill, visFillPattern).FormulaU = "1"
ActiveWindow.Close
ActiveWindow.DeselectAll
End Sub
Dim xp1 As Double
Dim xp2 As Double
Dim xp3 As Double
Dim xp4 As Double
Dim yp1 As Double
Dim yp2 As Double
Dim yp3 As Double
Dim yp4 As Double
Public Sub Lines2rectangle()
Dim vsoSide1 As Visio.Shape
Dim vsoSide2 As Visio.Shape
Dim vsoSide3 As Visio.Shape
Dim vsoSide4 As Visio.Shape
Dim vsoRect1 As Shape
'Need to import the line endpoints from Excel
'Could be done using drawrectangle, then you just need the diagonal pair of points.
Call ExcelImport
'Draw the four lines:
Set vsoSide1 = ActivePage.DrawLine(xp1, yp1, xp2, yp2)
Set vsoSide2 = ActivePage.DrawLine(xp2, yp2, xp3, yp3)
Set vsoSide3 = ActivePage.DrawLine(xp3, yp3, xp4, yp4)
Set vsoSide4 = ActivePage.DrawLine(xp4, yp4, xp1, yp1)
'Create rectangle shape:
ActiveWindow.DeselectAll
ActiveWindow.Select vsoSide1, visSelect
ActiveWindow.Select vsoSide2, visSelect
ActiveWindow.Select vsoSide3, visSelect
ActiveWindow.Select vsoSide4, visSelect
ActiveWindow.Selection.Join 'Closed shape created
'Open shapesheet and populate:
ActiveWindow.Selection.PrimaryItem.OpenSheetWindow
ActiveWindow.Shape.CellsSRC(visSectionFirstComponent, 0, 0).FormulaU = 0
ActiveWindow.Shape.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(255,192,0))"
ActiveWindow.Shape.CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEME(""FillColor""),THEME(""FillColor2""))))"
ActiveWindow.Shape.CellsSRC(visSectionObject, visRowFill, visFillPattern).FormulaU = "1"
ActiveWindow.Close 'Close the shapesheet
ActiveWindow.DeselectAll 'Deselect shape, ready to make more.
End Sub
Private Sub ExcelImport()
' ******************************************************************************************
Dim xlApp As Object 'Use this for late binding. Method2 can use either and establishes either early or late binding.
Dim myExBook As excel.Workbook 'use a variable for each function. Allows each to be released at end of program. This releases all aspects of Excel. Supposed to be a good thing.
Dim myExSheet As excel.Worksheet 'variable for Excel Sheet
Dim myCellVal As String
Set xlApp = CreateObject("Excel.Application") 'use this with early or late binding
Set myExBook = xlApp.Workbooks.Open("D:\MyTemporary\MyLineData.xlsx")
Set myExSheet = myExBook.Worksheets("Sheet1") 'Need to explicitly use this call to allow repeated code executions without error. Without it, VBA assigns its own references. Bad 2nd time thru
xlApp.Visible = False
xlApp.ScreenUpdating = False 'Prevents screen from updating during execution. Set to "True" later to get a screen refresh
'Get Excel data. This could be parameterized, put into a loop.
xp1 = myExSheet.Cells(2, 3)
yp1 = myExSheet.Cells(2, 4)
xp2 = myExSheet.Cells(3, 3)
yp2 = myExSheet.Cells(3, 4)
xp3 = myExSheet.Cells(4, 3)
yp3 = myExSheet.Cells(4, 4)
xp4 = myExSheet.Cells(5, 3)
yp4 = myExSheet.Cells(5, 4)
xp5 = myExSheet.Cells(6, 3)
yp5 = myExSheet.Cells(6, 4)
' TIDY UP AND END
xlApp.ScreenUpdating = True
Set myExSheet = Nothing 'Release worksheet
Set myExBook = Nothing 'Release workbook
Set xlApp = Nothing 'Release Excel application
End Sub