Does anyone know a method to sort Visio pages alphabetically using VBA?
I looked to see if a method such as vzdVisioDocument.Pages.Sort exists, but found nothing in documentation or through internet searches.
Do I need to write my own sorting function using the Application.ActiveDocument.Pages.ItemU("Page Name").Index property? That seems to be the method suggested by recording a macro of the action.
So that wasn't as painful as expected. With vzdVisioDocument as an already defined Visio.Document:
' Make a collection of titles to iterate through
Dim colPageTitles As Collection
Set colPageTitles = New Collection
Dim intPageCounter As Integer
For intPageCounter = 1 To vzdVisioDocument.Pages.Count
colPageTitles.Add vzdVisioDocument.Pages.Item(intPageCounter).Name
Next intPageCounter
' For each title in the collection, iterate through pages and find the appropriate new index
Dim intPageIndex As Integer
Dim varPageTitle As Variant
For Each varPageTitle In colPageTitles
For intPageIndex = 1 To vzdVisioDocument.Pages.Count
' Check to see if the title comes before the index's current page title
If StrComp(varPageTitle, vzdVisioDocument.Pages.Item(intPageIndex).Name) < 0 Then
' If so, set the new page index
vzdVisioDocument.Pages.ItemU(varPageTitle).Index = intPageIndex
Exit For
End If
Next intPageIndex
Next varPageTitle
' Clean up
Set colPageTitles = Nothing
I mentioned this in another comment, but when I made some test pages, it was always shuffling the pages around when I ran it because I the way that this is implemented, I don't believe that Exit For should be in there.
I also swapped the comparison to StrCompare due to personal preference along with the order of the for loops.
Sub PageSort()
Dim titlesColl As Collection
Set titlesColl = New Collection
Dim i As Long
For i = 1 To ActiveDocument.Pages.Count
titlesColl.Add ActiveDocument.Pages.Item(i).Name
Next i
Dim title As Variant
For i = 1 To ActiveDocument.Pages.Count
For Each title In titlesColl
If StrComp(ActiveDocument.Pages.Item(i).Name, title, vbTextCompare) < 0 Then
ActiveDocument.Pages.Item(title).index = i
End If
Next title
Next i
Set titlesColl = Nothing
End Sub
Private Sub reorderPages()
Dim PageNameU() As String
Dim isBackgroundPage As Boolean
Dim vsoPage As Visio.Page
Dim vsoCellObj As Visio.Cell
'// Get All Pages
Dim i As Integer
For Each vsoPage In ActiveDocument.Pages
i = i + 1
ReDim Preserve PageNameU(i)
PageNameU(i) = vsoPage.NameU
Next vsoPage
For i = 1 To UBound(PageNameU)
Set vsoPage = vsoPages.ItemU(PageNameU(i))
Set vsoCellObj = vsoPage.PageSheet.Cells("UIVisibility")
isBackgroundPage = vsoPage.Background
'// Make foreground page to set page index
If isBackgroundPage = True Then
vsoCellObj.FormulaU = visUIVNormal
vsoPage.Background = False
End If
vsoPage.Index = NumNonAppSysPages + i
'// Set to background page
If isBackgroundPage = True Then
vsoCellObj.FormulaU = visUIVHidden
vsoPage.Background = True
End If
Next i
End Sub
Related
Can any one explain me to get the object entites count of the layer
using vba code acad
I think You should use SelectionSets
Public Sub SelsetByLayer()
Dim ss As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 8 ' DXF code of Layer property
For I = 0 To ThisDrawing.Layers.Count
' ThisDrawing.SelectionSets.Item(0).Delete
Set ss = ThisDrawing.SelectionSets.Add("test") ' You need to ensure if such selection set not exist yet .
FilterData(0) = ThisDrawing.Layers.Item(I).Name
ss.Select acSelectionSetAll, , , FilterType, FilterData
Next
End Sub
Further to the original answer, about using selection sets.
Here it is slightly modified:
Public Sub SelsetByLayer()
Dim ss As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 8 ' DXF code of Layer property
For I = 0 To ThisDrawing.Layers.Count
Set ss = CreateSelectionSet("test")
FilterData(0) = ThisDrawing.Layers.Item(I).Name
ss.Select acSelectionSetAll, , , FilterType, FilterData
Next
End Sub
Public Function CreateSelectionSet(SelName As String) As AcadSelectionSet
On Error Resume Next
' Create a new selection set
' Delete any existing selection set with the specified name
With ThisDrawing
Set CreateSelectionSet = .SelectionSets.Add(SelName)
If (Err.Number <> 0) Then
Err.Clear
.SelectionSets.Item(SelName).Delete
Set CreateSelectionSet = .SelectionSets.Add(SelName)
End If
End With
End Function
I have added in the missing method for managing the deletion of existing selection set.
ss.Count will have the number of entities found. But please bear in mind that you may have layers frozen off etc. in the drawing and I think these will be excluded from the totals.
Whenever i am trying to debug or run the program and if it encounters error, the VBE (Autocad) doesn't display the line where the error is, unlike in other IDEs, it used to come at that line and highlight with yellow color. Also, the scroll doesn't work. I know i should install plugins but i am unable to help myself.
Option Explicit
Sub Test()
'Declarations
'Opened Document
Dim acDocu As AcadDocument
Set acDocu = ThisDrawing.Application.ActiveDocument
'Select on screen
Dim acSelectionSet As AcadSelectionSet
Set acSelectionSet = ThisDrawing.SelectionSets.Add("SjjEffffT")
acSelectionSet.SelectOnScreen
'Manipulating in loops for finding group names having objects selected
Dim entity As AcadEntity
Dim entityhandle() As String
Dim Grp As AcadGroup
Dim groupname() As String
Dim i As Integer
i = 0
Dim j As Integer
j = 0
Dim temp As Integer
temp = 0
Dim GrpEnt As AcadEntity
Dim grpenthandle As String
Dim entity_count As Integer
'Dim entity_array As Variant
entity_count = acSelectionSet.Count
ReDim entityhandle(entity_count)
ReDim groupname(entity_count)
For Each entity In acSelectionSet
'entity_array = entity
entityhandle(i) = entity.Handle
For Each Grp In ThisDrawing.groups
For Each GrpEnt In Grp
grpenthandle = GrpEnt.Handle
If entityhandle(i) = grpenthandle Then
If temp = 0 Then
groupname(j) = Grp.Name
Debug.Print "Group in selection:" & groupname(j)
j = j + 1
End If
End If
temp = temp + 1
Next
temp = 0
Next
i = i + 1
Next
'Copying the objects and pasting into new drawing
Dim acDocto As AcadDocument
Dim file_name As String
'file_name = InputBox("Enter the file name along with full path and extension")
file_name = "D:\PI_Tool_files_3223\D00440023new.DWG"
Set acDocto = Documents.Open(file_name)
Dim acObject As AcadObject
Dim retvalue As Variant
retvalue = acDocu.CopyObjects(entityhandle, acDocto.ModelSpace)
acSelectionSet.Delete
End Sub
The code is written above. But i think the problem is with the add-in as i can't debug.
The VBA IDE is pretty old (1998) and it has limited debugging abilities. You should stop using this, it's an obsolete technology, not actively supported by Microsoft/Autodesk anymore.
For some errors, it is not able to locate the line where the error occurred, and you're left with obscure error codes and useless messages.
Have you tried setting a breakpoint at the first possible line? (Set acDocu = ThisDrawing.Application.ActiveDocument)
Then step through to see the offending object/property/method.
It doesn't always work.
Can you load the code into a module, instead of "ThisDrawing", then debug?
I'm getting a error mesage when I run this code.
Dim usf as object
If usfOKNAR01.Visible = True Then
k = 1
Set usf = VBA.UserForms(usfOKNAR01) 'here I'm getting the error
ElseIf usfOKNAR02.Visible = True Then
k = 2
Set usf = VBA.UserForms(usfOKNAR02) 'here I'm getting the error mesage
End If
I want to create a dynamic object control which is reffering to 2 Userforms called usfOKNAR01 and usfOKNAR02.
Depending which is visible the proper will be set and then used like this usf.Controls("txt" & k & "oknar13").Value in other part of my code.
I don't know where the issue can be?
Thank you for your help!
I have removed a part of my code and it seems to work but I don't know if this is the proper way to solve my issue.
Here the new code:
Dim usf as object
If usfOKNAR01.Visible = True Then
k = 1 Set
usf = usfOKNAR01
ElseIf usfOKNAR02.Visible = True Then
k = 2 Set
usf = usfOKNAR02
End If
You can't use the name or the class name as an index to VBA.UserForms - it only accepts Integer index arguments. If you don't know the integer index of the collection, you'll have to iterate over it:
Dim usf As Object
Dim found As Boolean
If usfOKNAR01.Visible = True Then
k = 1
Dim candidate As Object
For Each candidate In VBA.UserForms
If TypeOf candidate Is usfOKNAR01 Then
found = True
Exit For
End If
Next usf
If found Then Set usf = candidate
'...
Since you need to do this at least twice, I'd recommend extracting it to a function.
Note that if either of the forms is not loaded when your code runs, VBA will instantiate them when you test whether they are Visible.
I have been working with VBA in excel and recently began working with the Scripting.Dictionary object. I hadn't run across any major problems until today.
Basically I am trying to populate a listbox with the Key values of a dictionary, then add one more value to the listbox. This results in the value not only being added to the listbox, but also to the dictionary as a key. I have attempted to copy the values from the dict.keys() array to a completely separate array, but still have the same issue. I assume this is a byref problem but have yet to figure out a solution. If anyone has any ideas that would be awesome.
Private Sub Setup_settingLst()
'Set Settings listbox items
'On Error GoTo ErrorExit
Dim list_ary() As Variant
Dim tmp As Variant
Dim i As Integer
settingLst.Clear
settingLst.Value = "-Select Setting-"
i = 0
tmp = tmp_dict.Keys()
If tmp_dict.Count > 1 Then
ReDim list_ary(0 To tmp_dict.Count)
For i = 0 To UBound(tmp)
list_ary(i) = tmp(i)
Next i
list_ary(tmp_dict.Count) = "Back"
Else
ReDim list_ary(0 To tmp_dict.Count - 1)
For i = 0 To UBound(tmp)
list_ary(i) = tmp(i)
Next i
End If
settingLst.List = list_ary
Erase list_ary
Exit Sub
ErrorExit:
End Sub
This seems to work
Private Sub UserForm_Click()
Dim dcValues As Scripting.Dictionary
Me.ListBox1.Clear
Set dcValues = FillDictionary
Me.ListBox1.List = dcValues.Keys
Me.ListBox1.AddItem "Back"
End Sub
I am working on a project that joins two or more pp presentations into one new presentation.
The selection of the original pp presentations is in a webbased Lotus Notes xPage and after the submit, Lotusscript talkes to the OLE Powerpoint object.
Adding the slides into the new Presentation in the right order is no problem.
The problem is that after the adding the original connection with the slides Template(s) is lost.
To solve this I found the next codesnippet:
Sub joiner()
Dim sFileName As String
Dim oDonor As Variant
Dim otarget As Variant
Dim i As Integer
On Error GoTo errhandler
Set otarget = ActivePresentation
Do While sFileName <> ""
Set oDonor = Presentations.Open(Environ("USERPROFILE") & "\Desktop\joiner\" & sFileName, msoFalse)
For i = 1 To oDonor.Slides.Count
oDonor.Slides(i).Copy
With otarget.Slides.Paste(otarget.Slides.Count + 1)
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With
Next i
oDonor.Close
Set oDonor = Nothing
sFileName = Dir()
Loop
End Sub
I have to declare the presentations oDonor and oTarget as a Variant because lotusscript doesn't understand Dim oTarget As Presentation
This is probably the reason why the code returns a typemismatch error at:
.Design = oDonor.Slides(i).Design
My questions are:
Am I doing the join the right way or is there a better solution?
Is there a solution for the typemismatch error?
*ps: The result presentation doesn't have to be editable, so maybe it is not necessary to add templates.
Update 04-10-2012:
The next code solves the template problem.
What still is missing now is the background image used by some slides.
See: https://stackoverflow.com/questions/12731691/how-to-export-a-backgroundimage-of-a-slide-to-the-filesystem
Dim oDonor As Variant
Dim h As Integer
Dim thetmplt As Variant
Dim thetmpltname As String
Dim thetmpltnew As Variant
Dim thetmpltnamenew As String
Set oDonor = PPApplication.Presentations.Open(tempdirectory +
jobid+CStr(filenamearray (i)),False,False,False)
thetmplt = oDonor.TemplateName
Call oDonor.SaveAs(tempdirectory +jobid+CStr(i)+ thetmplt+".pot" ,5, -1)
For h = 1 To oDonor.Slides.Count
Dim oTargetSlide As Variant
oDonor.Slides(h).Copy
Set oTargetSlide = newPres.Slides.Paste()
Next
Dim theubound As Variant
theubound = oDonor.Slides.Count
ReDim thearray(1 To k + theubound) As Variant
For k = k To k + oDonor.Slides.Count-1
thearray(k) = k
Next
Call newPres.Slides.Range(thearray()).ApplyTemplate(tempdirectory +
jobid+CStr(i+thetmplt+".pot")
oDonor.Close
Set oDonor = Nothing
This is just a hunch, but try:
Dim oTargetSlide as Variant
Set oTargetSlide = otarget.Slides.Paste(otarget.Slides.Count + 1)(1)
With oTargetSlide
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With