Save model from drawing - vba

I have VBA code to issue drawings. It allows properties of the model to be changed, issue, date of issue etc.
The idea is to open the drawing, update issue, date, etc. (save as pdf and dwg). It works, properties changed, and saves the correct view.
The property changes are not saved to the model, unless I open the model and force a save, hence when I reopen the drawing/model they revert to the old.
How can I force a save of the model, even if it is not open?
See last few lines for my attempt:
Sub WriteModelProperties(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2)
Dim element As Integer
Dim boolstatus As Boolean
Dim ctrl As MSForms.Control
Dim fieldName As String
Dim fieldType As Integer
Dim fieldValue As String
For element = 0 To 25
fieldName = propertiesValue(0, element)
Select Case propertiesValue(1, element)
Case "Text": fieldType = 30
Case "Date": fieldType = 64
End Select
Set ctrl = UserForm1.Controls(propertiesValue(2, element)) 'to make a compact code
Select Case propertiesValue(3, element)
Case "Caption": fieldValue = ctrl.Caption
Case "Value": fieldValue = ctrl.Value
End Select
Debug.Print fieldValue
boolstatus = swCustProp.Add3(fieldName, fieldType, fieldValue, swCustomPropertyDeleteAndAdd)
Next element
swModel.Rebuild (swRebuildAll)
swModel.EditRebuild3 ' Update model properties
swModel.ViewZoomtofit2
boolstatus = swModel.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
End Sub

Sorry ... tad bit of egg on my face ... it didnt work had to split parts and assemblies :(
This appears to work ... my apologies if its an insult to vba.
You only need to open the drawing, not the part or assembly :) Sorry couldn't resist.
Option Explicit
Public swApp As SldWorks.SldWorks
Public swModDoc As SldWorks.ModelDoc2
Dim swView As SldWorks.View
Dim swPart As PartDoc
Dim swAss As AssemblyDoc
Dim boolstatus As Boolean
Dim lErrors As Long 'Varaible to collect Errors
Dim lWarnings As Long 'Varaible to collect Errors
Sub main()
Set swApp = Application.SldWorks
Set swModDoc = swApp.ActiveDoc
Set swView = swModDoc.GetFirstView
Set swView = swView.GetNextView
If swView.ReferencedDocument.GetType = 1 Then
Set swPart = swView.ReferencedDocument
boolstatus = swPart.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
ElseIf swView.ReferencedDocument.GetType = 2 Then
Set swAss = swView.ReferencedDocument
boolstatus = swAss.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
End If
End Sub

Related

Macro to export Solidworks Part to dxf

I want to export my part as dxf as part of a macro. I tried recording it, but when I execute the recording it runs into erroors (see below). Thus I took it to the internet and tried the answer provided to this question
"Macro for Saving Solidworks part configurations as dxf files",
but it doesn't seem to work for me either.
I have tried exporting to other formats, such as step, xt and stl, which all work flawlessly. The macro for dxf export though executes without any errors, but it also does not export/save anything.
Trying to use this with Solidworks2017
I have also tried to record my own macro but it stops at:
Set myView = Part.CreateDrawViewFromModelView3(Part, "*Oben", 0, 0, 0)
with the errormsg:
Runtime error '438': object does not support this property or method.
here the recorded macro in full:
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Dim COSMOSWORKSObj As Object
Dim CWAddinCallBackObj As Object
Set CWAddinCallBackObj = swApp.GetAddInObject("CosmosWorks.CosmosWorks")
Set COSMOSWORKSObj = CWAddinCallBackObj.COSMOSWORKS
Dim FilePath As String
Dim PathSize As Long
Dim PathNoExtention As String
Dim NewFilePath As String
FilePath = Part.GetPathName
PathSize = Strings.Len(FilePath)
PathNoExtention = Strings.Left(FilePath, PathSize - 6)
NewFilePath = PathNoExtention & "dxf"
' Save As
longstatus = Part.SaveAs3(NewFilePath, 0, 0)
' Redraw
Part.GraphicsRedraw2
Set Part = swApp.ActiveDoc
Dim myModelView As Object
Set myModelView = Part.ActiveView
myModelView.FrameLeft = 0
myModelView.FrameTop = 22
Set myModelView = Part.ActiveView
myModelView.FrameState = swWindowState_e.swWindowMaximized
Set Part = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2017\templates\Zeichnung.drwdot", 0, 0, 0)
swApp.ActivateDoc2 "Zeichnung5 - Blatt1", False, longstatus
Set Part = swApp.ActiveDoc
Set Part = swApp.ActiveDoc
Set myModelView = Part.ActiveView
myModelView.FrameLeft = 0
myModelView.FrameTop = 0
Set myModelView = Part.ActiveView
myModelView.FrameState = swWindowState_e.swWindowMaximized
swApp.ActivateDoc2 FilePath, False, longstatus
Set Part = swApp.ActiveDoc
Dim myView As Object
Set myView = Part.CreateDrawViewFromModelView3(Part, "*Oben", 0, 0, 0)
Set myView = Part.CreateDrawViewFromModelView3(Part, "*Normal auf", 0, 0, 0)
Part.ClearSelection2 True
Part.ClearSelection2 True
End Sub
Exporting to DXF (or DWG) is different to saving other formats from SolidWorks as you have found out. It's typically used to export flat patterns of sheet metal components.
ExportToDWG2 (IPartDoc) is the API method you need to call to export to either of these two formats. As per the docs it allows you to:
Saves various aspects of a part (sheet metal, faces, loops, and annotation views) to one or more DXF/DWG files'
As such how you use this call will vary based on what you want to export.
Sheet Metal
If you are exporting sheet metal, as per the example you linked, then you will output a flat pattern. However if you try to export sheet metal with a model that does not contain any sheet metal features then the result will be that the call returns false and nothing is output.
The following would be suitable for a sheet metal part:
Dim success As Boolean
success = swPart.ExportToDWG2(dxfFilePath, modelFilePath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Nothing, False, False, sheetMetalOptions, Nothing)
There is no enum in SolidWorks for the sheet metal options but here's one you could use:
Enum SheetMetalOptions_e
None = 0
Geometry = 1
HiddenEdges = 2
BendLines = 4
Sketches = 8
CoplanarFaces = 16
LibraryFeatures = 32
FormingTools = 64
BoundingBox = 2048
End Enum
Usage would be as follows:
' Export geometry, hidden edges and bend lines
Dim sheetMetalOptions As SheetMetalOptions_e
sheetMetalOptions = Geometry Or HiddenEdges Or BendLines
A full macro may look like the below:
Enum SheetMetalOptions_e
None = 0
Geometry = 1
HiddenEdges = 2
BendLines = 4
Sketches = 8
CoplanarFaces = 16
LibraryFeatures = 32
FormingTools = 64
BoundingBox = 2048
End Enum
Sub Main()
' Connect to SolidWorks
Dim swApp As SldWorks.SldWorks
Set swApp = Application.SldWorks
' Connect to the active model
Dim swModel As ModelDoc2
Set swModel = swApp.ActiveDoc
' Validate a model is open
If swModel Is Nothing Then
swApp.SendMsgToUser2 "Open a part to run this macro", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
' Validate the open model is a part document
If swModel.GetType <> swDocumentTypes_e.swDocPART Then
swApp.SendMsgToUser2 "This macro only runs on part documents", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
Dim swPart As PartDoc
Set swPart = swModel
' Build the new file path
Dim filePath As String
Dim pathSize As Long
Dim pathNoExtention As String
Dim newFilePath As String
filePath = swModel.GetPathName 'WARNING: this will be an empty string if the part document has not been saved
pathSize = Strings.Len(filePath)
pathNoExtention = Strings.Left(filePath, pathSize - 6) 'WARNING: this assumes the file extension is 6 characters (sldprt)
newFilePath = pathNoExtention & "dxf"
' Define sheet metal information to export
Dim sheetMetalOptions As SheetMetalOptions_e
sheetMetalOptions = Geometry Or HiddenEdges Or BendLines
' Export the DXF
Dim success As Boolean
success = swPart.ExportToDWG2(newFilePath, filePath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Nothing, False, False, 0, Nothing)
' Report success or failure to the user
If success Then
swApp.SendMsgToUser2 "The DXF was exported successfully", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
Else
swApp.SendMsgToUser2 "Failed to export the DXF", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
End If
End Sub
Faces, Loops or Annotation Views
If your part does not contain sheet metal features then you will have to use one of the alternative export actions: Selected Faces or Loops or Annotation Views.
Annotation Views is supposed to let you pass in an array of view names (such as *Front or *Current) but in my experience it does not work reliably and I am aware that there are some SPRs open against this in SolidWorks.
Selected Faces or Loops requires you to pre-select a face or loop prior to calling ExportToDWG2, so you would have to write some code to determine which faces or loop you want to use and select it, then call ExportToDWG2 with the action parameter set to swExportToDWG_e.swExportToDWG_ExportSelectedFacesOrLoops.

Saving all parts in an assembly as STEP with custom properties. How to solve run-time error 91?

I'm trying to write a macro with VBA in Solidworks that will go through all the sub assemblies and save every part as STEP-file where the name is determined by a custom property. I don't have a lot of programming experience as I'm an mechanical engineer but I try to automate some processes from time to time. Most of this code I got from others and I tried to tweak it to my situation. I do understand most of what is happening though.
The problem I'm having is that I keep getting a
91 runtime error
When I go to debugging Solidworks tells me the problem is in the line name = swPart.GetTitle. At first it said "name = nothing". I tried looking for the problem and when i added Set swApp = Application.SldWorks to the sub I still got the error but now name is always something.
Dim swApp As SldWorks.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim retVal As Boolean
Dim errors As Long, warnings As Long
Dim revision As String
Dim vaultPath As String
Dim name As String
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swAssy = swApp.ActiveDoc
Set swConf = swAssy.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent3(True)
vaultPath = "C:\Users\Engineering\Desktop\test\" 'set folder for vault (change this later)
TraverseComponent swRootComp, 1, vaultPath
End Sub
Sub TraverseComponent(swComp As SldWorks.Component2, nLevel As Long, vaultPath As String)
Dim vChilds As Variant, vChild As Variant
Dim swChildComp As SldWorks.Component2
Dim MyString As String
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Set swApp = Application.SldWorks
vChilds = swComp.GetChildren
For Each vChild In vChilds
Set swChildComp = vChild
Dim FileName As String
FileName = swChildComp.GetPathName
FileName = Left(FileName, InStr(FileName, ".") - 1)
FileName = Right(FileName, Len(FileName) - InStrRev(FileName, "\"))
Debug.Print "Part Name : " & FileName
MyString = FileName
Dim ActiveConfig As String
ActiveConfig = swChildComp.ReferencedConfiguration
Debug.Print "Configuration: " & ActiveConfig
FileName = swChildComp.GetPathName
If UCase(Right(FileName, 6)) = "SLDPRT" Then
'MsgBox ("part found")
Dim swPart As SldWorks.ModelDoc2
Set swPart = swApp.OpenDoc6(swChildComp.GetPathName, 1, 0, "", longstatus, longwarnings)
'Dim name As String 'I tried adding this but it made no difference
name = swPart.GetTitle 'get the title of the active document
'chop the extension off if present
If Right(name, 7) = ".SLDPRT" Or Right(name, 7) = ".SLDasm" Then
name = Left(name, Len(name) - 7)
End If
Set swCustPropMgr = swPart.Extension.CustomPropertyManager("") 'get properties
revision = swCustPropMgr.Get("Revision") 'get revision
retVal = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swStepAP, 214) 'change the step file options
'save with revision if present
If revision = "" Or revision = Null Then
retVal = swPart.Extension.SaveAs(vaultPath & name & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
Else
retVal = swPart.Extension.SaveAs(vaultPath & name & " - Rev " & revision & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
End If
swApp.CloseDoc swPart.GetTitle
End If
Debug.Print
TraverseComponent swChildComp, nLevel + 1, vaultPath
Next
End Sub
A suppressed component is not the only reason why you could get a "nothing" after calling OpenDoc. This happens e.g. if the component is loaded lightweight or is otherwise not fully loaded. Then you are also not able to get the ModelDoc (PartDoc) data of a component object.
To prevent this completely you could execute the next lines only if the swPart variable is not nothing.
If (Not swPart Is Nothing) Then
name = swPart.GetTitle 'get the title of the active document
...
End If
Additionally I can say you don't necessarily need to use OpenDoc/CloseDoc because the component is already loaded into memory when the assembly is loaded. Therefore it is enough to call GetModelDoc2 of the child component. But in the end it has the same behaviour and will return nothing if the component is not fully loaded.
set swPart = swChildcomp.GetModelDoc2()

Program closes before if statement (CATIA VBA)

I am trying to implement a minimum boundary box subroutine inside my macro. Subroutine ends before going into if statement. Can you help me find the solution?
Option Explicit
Sub bounding()
Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument
Dim part1 As Part
Set part1 = partDocument1.Part
Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory
Dim hybridBodies1 As HybridBodies
Set hybridBodies1 = part1.HybridBodies
Dim hybridBody1 As hybridbody
Set hybridBody1 = hybridBodies1.Item(cevap)
Dim hybridShapes1 As HybridShapes
Set hybridShapes1 = hybridBody1.HybridShapes
Dim axisSystems1 As AxisSystems
Set axisSystems1 = part1.AxisSystems
Dim axisSystem1 As AxisSystem
Set axisSystem1 = part1.FindObjectByName("axissys")
Dim direction As Long
If extindex Mod 2 = 1 Then
direction = 1
Else
direction = 0
End If
Dim reference1 As Reference
MsgBox CStr(extindex)
Select Case extindex
Case 1, 2
Set reference1 = axisSystem1.XAxisDirection
MsgBox CStr(extindex) + "1ve2"
Case 3, 4
Set reference1 = axisSystem1.YAxisDirection
MsgBox CStr(extindex) + "3ve4"
Case Else
Set reference1 = axisSystem1.YAxisDirection
MsgBox CStr(extindex) + "5ve6"
End Select
Debug.Print ("exit if check")
Dim hybridShapeDirection1 As HybridShapeDirection
Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirection(reference1)
Dim bodies1 As Bodies
Set bodies1 = part1.Bodies
Dim body1 As Body
Set body1 = bodies1.Item("PartBody")
Dim reference2 As Reference
Set reference2 = part1.CreateReferenceFromObject(body1)
Dim hybridShapeExtremum1 As HybridShapeExtremum
Set hybridShapeExtremum1 = hybridShapeFactory1.AddNewExtremum(reference2,
hybridShapeDirection1, 0)
part1.Update
hybridBody1.AppendHybridShape hybridShapeExtremum1
part1.InWorkObject = hybridShapeExtremum1
hybridShapeExtremum1.Name = "ext1" + CStr(extindex)
part1.Update
End Sub
All variables on the program are checked and they work. I don't understand what is happening an why it doesnt work. I even checked all variables. Program should go inside if statement but it doesnt
The AxisSystem properties XAxisDirection, YAxisDirection, and ZAxisDirection refer to the references from which the axis system was defined.
You can use these properties to edit the AxisSystem object itself but they are not "output" Reference objects which should be used to construct downstream geometry.
You can pull the vectors components using the GetXAxis, GetYAxis, and GetZAxis methods (which will always contain values) and then use HybridShapeFactory.AddDirectionFromCoord() method to create the direction for the extremum.
...
MsgBox CStr(extindex)
Dim vect(2)
Dim vAxis As Variant
Set vAxis = axisSystem1
Select Case extindex
Case 1, 2
vAxis.GetXAxis vect
Case 3, 4
vAxis.GetYAxis vect
Case Else
vAxis.GetYAxis vect
End Select
Dim hybridShapeDirection1 As HybridShapeDirection
Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirectionByCoord(vect(0), vect(1), vect(2))
...

Visual Basic CInt error

I am trying to make a function that looks at an image, and return the X pixel value.
When i run the code, it throws an error on the Int1=CInt(Xdim) line, saying "Type Mismatch (10080)"
If i hard-code the value i am testing into Xdim, it works fine.
Function ImgXDim(filename As String) As Integer ' Finds the X dimension in pixels of a loaded image
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim ImgSize As String
Dim Int1 As Integer
Dim Xdim As String
Dim strarray() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(MacroDir & "\PICS\")
Set objFile = objFolder.ParseName(filename)
ImgSize = objFile.ExtendedProperty("Dimensions") ' Returns string of "700 x 923"
strarray = Split(ImgSize, " x ") ' Split into 2 strings of "700" and "923"
Xdim = CStr(strarray(0)) ' Force Xdim to be a string of "700"
Int1 = CInt(Xdim) ' Convert Xdim to an integer
ImgXDim = Int1 ' Return Integer
End Function
First check if value can be converted to an integer:
If IsNumeric(Trim(Xdim)) then
Int1 = CInt(Xdim)
else
'for debug purposes
MsgBox ("XDim non-numeric or empty")
End If
Ok, i couldnt find what character was causing the issue, so i used this loop of code to pull out only numbers, and it seems to work.
For X = 1 To Len(Xdim)
If IsNumeric(Mid(Xdim, X, 1)) = True Then
holder = holder & Mid(Xdim, X, 1)
End If
Next X
Here the WIA version:
Function ImgXDim(filename As String) As Long
Dim imgWIA as New WIA.ImageFile 'Early Binding needs a reference to Windows Image Aquisition Library in VBA-Ide->Tools->References
'Dim imgWIA as Object 'Late Bound Version
'Set imgWIA = CreateObject("WIA.ImageFile")
imgWIA.LoadFile MacroDir & "\PICS\" & filename
ImgXDim = imgWIA.Width ' use .Height for height
End Function
As you see, just three lines of code and returns a long, not a string that needs parsing.
Useful functions for resize, rotate and more.
Also useful if you want to display Tiffs in a picture control (page by page) and more.

A practical example of evenly distributing n lists into a single list

I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question: Good algorithm for combining items from N lists into one with balanced distribution?.
I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created. Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there. Thanks!
Sub WeaveSort()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double
Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1
For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row
If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If
dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0
For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i
End Sub
Great question! I would take an object oritentated approach. Also I didn;t think it was clear what the logic was so here is my answer. Two classes and one normal module. Save these separately with the filenames ListManager.cls, List.cls, tstListManager.bas
So the ListManager.cls is this
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ListManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mdic As Object
Public Sub Initialise(ByVal vLists As Variant)
Set mdic = VBA.CreateObject("Scripting.Dictionary")
Dim vListLoop As Variant
For Each vListLoop In vLists
Dim oList As List
Set oList = New List
oList.Initialise vListLoop, ""
mdic.Add mdic.Count, oList
Next
End Sub
Public Function WeaveSort() As Variant
Dim dicReturn As Object
Set dicReturn = VBA.CreateObject("Scripting.Dictionary")
Dim oNextList As List
Set oNextList = Me.WhichListHasLeastProgress
While oNextList.PercentageDone <= 1
Dim vListItem As Variant
vListItem = oNextList.GetListItem
dicReturn.Add dicReturn.Count, vListItem
oNextList.MoveNext
Set oNextList = Me.WhichListHasLeastProgress
Wend
Dim vItems As Variant
vItems = dicReturn.Items
'I don't like this bit
ReDim vRet(1 To dicReturn.Count, 1 To 1)
Dim lLoop As Long
For lLoop = 0 To dicReturn.Count - 1
vRet(lLoop + 1, 1) = vItems(lLoop)
Next lLoop
WeaveSort = vRet
End Function
Public Function WhichListHasLeastProgress() As List
Dim vKeyLoop As Variant
Dim oListLoop As List
Dim oLeastProgress As List
For Each vKeyLoop In mdic.keys
Set oListLoop = mdic.Item(vKeyLoop)
If oLeastProgress Is Nothing Then
'nothing to compare yet
Set oLeastProgress = oListLoop
Else
If oListLoop.PercentageDone < oLeastProgress.PercentageDone Then
'definitely take this new candidate
Set oLeastProgress = oListLoop
ElseIf oListLoop.PercentageDone = oLeastProgress.PercentageDone And oListLoop.Size > oListLoop.Size Then
'close thing, both showing equal progress but we should give it to the one with the bigger "queue"
Set oLeastProgress = oListLoop
Else
'no swap
End If
End If
Next
'return the answer
Set WhichListHasLeastProgress = oLeastProgress
End Function
and the List.cls file is
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mvList As Variant
Private mlCount As Long
Private mlCursor As Long
Private mvName As Variant
Public Function Initialise(ByRef vList As Variant, ByVal vName As Variant)
Debug.Assert TypeName(vList(1, 1)) <> "" ' this will break unless you specify a 2d array
Debug.Assert LBound(vList, 1) = 1 ' this ensure you got it from a sheet
mvList = vList
mlCount = UBound(mvList)
mlCursor = 1
mvName = vName
End Function
Public Function GetListItem()
GetListItem = mvList(mlCursor, 1)
End Function
Public Function Name() As Variant
Name = mvName
End Function
Public Function MoveNext() As Boolean
mlCursor = mlCursor + 1
MoveNext = (mlCursor < mlCount)
End Function
Public Function Size() As Long
Size = mlCount
End Function
Public Function PercentageDone() As Double
PercentageDone = mlCursor / mlCount
End Function
The last file is this tstListManager.bas
Attribute VB_Name = "tstListManager"
Option Explicit
Sub test()
Dim oListMan As ListManager
Set oListMan = New ListManager
Dim vLists As Variant
vLists = VBA.Array(ThisWorkbook.Sheets("Source").Range("A1:A3").Value2, _
ThisWorkbook.Sheets("Source").Range("B1:B2").Value2, _
ThisWorkbook.Sheets("Source").Range("C1:C5").Value2)
oListMan.Initialise vLists
Dim vSorted As Variant
vSorted = oListMan.WeaveSort
Dim lTotal As Long
ThisWorkbook.Sheets("Dest").Range("A1").Resize(UBound(vSorted, 1)).Value2 = vSorted
End Sub
Finally, the test data was in A1:A3 B1:B2 C1:C5
You should note I have abstracted away any Excel reading/writing logic and the pure weavesort logic is not cluttered.
Feel free to reject outright. Object orientation can be quite controversial and we think differently. :)