Visual Studio macro to collapse custom nodes - visual-studio

If I were to have something like:
namespace SomeNameSpace
{
#region Usings
using System.Collections.Generic;
using System.Security;
#endregion
/// <summary> Implements a dictionary with several keys. </summary>
/// <typeparam name="Value"> What type of elements we will be storing in the dictionary</typeparam>
public class MultiKeyDic<Value>
{
/// <summary> a very long summary that can be
/// collapsed and expanded. </summary>
public int SomeInt {get;set;}
public void someMethod()
{
}
}
}
How can I create a macro that will find all the places that can be expandable (Nodes). If I would like to collapse all the nodes I will have to collapse the nodes in the order of someMethod(), summary of SomeInt , class MultiKeyDic, summary of class MultiKeyDic, #region Usings and finally namespace.
I know the command ctrl+M+O collapses everything, but I do not want to collapse everything. For example I might not want to collapse the comments. If I collapse everything and then expand the comments that expands the parent node too.
So far I have created this macro that will find most of the nodes:
Sub VisitAllNodes()
Dim i As Integer
Dim fileCM As FileCodeModel
Dim elts As EnvDTE.CodeElements
Dim elt As EnvDTE.CodeElement
fileCM = DTE.ActiveDocument.ProjectItem.FileCodeModel
elts = fileCM.CodeElements
For i = 1 To elts.Count
elt = elts.Item(i)
CollapseE(elt, elts, i)
Next
End Sub
'' Helper to OutlineCode. Recursively outlines members of elt.
''
Sub CollapseE(ByVal elt As EnvDTE.CodeElement, ByVal elts As EnvDTE.CodeElements, ByVal loc As Integer)
Dim epStart As EnvDTE.EditPoint
Dim epEnd As EnvDTE.EditPoint
epStart = elt.GetStartPoint(vsCMPart.vsCMPartWholeWithAttributes).CreateEditPoint()
epEnd = elt.GetEndPoint(vsCMPart.vsCMPartWholeWithAttributes).CreateEditPoint() ' Copy it because we move it later.
epStart.EndOfLine()
If ((elt.IsCodeType()) And (elt.Kind <> EnvDTE.vsCMElement.vsCMElementDelegate)) Then
Dim i As Integer
Dim mems As EnvDTE.CodeElements
mems = elt.Members
For i = 1 To mems.Count
Dim temp As EnvDTE.CodeElement = mems.Item(i)
Dim t As String = [Enum].GetName(GetType(EnvDTE.vsCMElement), temp.Kind)
MsgBox("Found member (" & t & ") at line# " & temp.StartPoint.Line)
CollapseE(mems.Item(i), mems, i)
Next
ElseIf (elt.Kind = EnvDTE.vsCMElement.vsCMElementNamespace) Then
Dim i As Integer
Dim mems As EnvDTE.CodeElements
mems = elt.Members
For i = 1 To mems.Count
Dim temp As EnvDTE.CodeElement = mems.Item(i)
Dim t As String = [Enum].GetName(GetType(EnvDTE.vsCMElement), temp.Kind)
MsgBox("Found member (" & t & ") at line# " & temp.StartPoint.Line)
CollapseE(mems.Item(i), mems, i)
Next
End If
'Return
' collapse the element
If (epStart.LessThan(epEnd)) Then
loc = loc + 1
If (loc <= elts.Count) Then
epEnd.MoveToPoint(elts.Item(loc).GetStartPoint(vsCMPart.vsCMPartHeader))
epEnd.LineUp()
epEnd.EndOfLine()
End If
epStart.OutlineSection(epEnd)
End If
End Sub
It looks more complicated than what it is. Run it on any document and it will display all the properties, classes, enums, etc., but for some reason it does not find the comments nor regions.

the first Function IncludeMember is used to determine what type of members to exclude. for example in this example I do not collapse namespaces and using directives:
' filter some mebers. for example using statemets cannot be collapsed so exclude them.
Function IncludeMember(ByVal member As EnvDTE.CodeElement)
If member.Kind = vsCMElement.vsCMElementIDLImport Then
Return False
ElseIf member.Kind = vsCMElement.vsCMElementNamespace Then
Return False ' I do not want to colapse enums
End If
Return True
End Function
Sub CollapseNodes()
' activate working window
DTE.Windows.Item(DTE.ActiveDocument.Name).Activate()
' expand everything to start
Try
DTE.ExecuteCommand("Edit.StopOutlining")
Catch
End Try
Try
DTE.ExecuteCommand("Edit.StartAutomaticOutlining")
Catch
End Try
' get text of document and replace all new lines with \r\n
Dim objTextDoc As TextDocument
Dim objEditPt As EnvDTE.EditPoint
Dim text As String
' Get a handle to the new document and create an EditPoint.
objTextDoc = DTE.ActiveDocument.Object("TextDocument")
objEditPt = objTextDoc.StartPoint.CreateEditPoint
' Get all Text of active document
text = objEditPt.GetText(objTextDoc.EndPoint)
text = System.Text.RegularExpressions.Regex.Replace( _
text, _
"(\r\n?|\n\r?)", ChrW(13) & ChrW(10) _
)
' add new line to text so that lines of visual studio match with index of array
Dim lines As String() = System.Text.RegularExpressions.Regex.Split(vbCrLf & text, vbCrLf)
' list where whe will place all colapsable items
Dim targetLines As New System.Collections.Generic.List(Of Integer)
' regex that we will use to check if a line contains a #region
Dim reg As New System.Text.RegularExpressions.Regex(" *#region( |$)")
Dim i As Integer
For i = 1 To lines.Length - 1
If reg.Match(lines(i)).Success Then
targetLines.Add(i)
End If
Next
Dim fileCM As FileCodeModel
Dim elts As EnvDTE.CodeElements
Dim elt As EnvDTE.CodeElement
Dim projectItem = DTE.ActiveDocument.ProjectItem
Dim temp = projectItem.Collection.Count
Dim b = DirectCast(DirectCast(projectItem.Document, EnvDTE.Document).ActiveWindow, EnvDTE.Window).ContextAttributes
fileCM = projectItem.FileCodeModel
elts = fileCM.CodeElements
For i = 1 To elts.Count
elt = elts.Item(i)
CollapseE(elt, elts, i, targetLines)
Next
' now that we have the lines that we will plan to collapse sort them. it is important to go in order
targetLines.Sort()
ActivateWorkingWindow()
' go in reverse order so that we can collapse nested regions
For i = targetLines.Count - 1 To 0 Step -1
DTE.ExecuteCommand("Edit.Goto", targetLines(i))
DTE.ExecuteCommand("Edit.ToggleOutliningExpansion")
Next
End Sub
'' Helper to OutlineCode. Recursively outlines members of elt.
''
Sub CollapseE(ByVal elt As EnvDTE.CodeElement, ByVal elts As EnvDTE.CodeElements, ByVal loc As Integer, ByRef targetLines As System.Collections.Generic.List(Of Integer))
Dim epStart As EnvDTE.EditPoint
Dim epEnd As EnvDTE.EditPoint
epStart = elt.GetStartPoint(vsCMPart.vsCMPartWholeWithAttributes).CreateEditPoint()
epEnd = elt.GetEndPoint(vsCMPart.vsCMPartWholeWithAttributes).CreateEditPoint() ' Copy it because we move it later.
epStart.EndOfLine()
If ((elt.IsCodeType()) And (elt.Kind <> EnvDTE.vsCMElement.vsCMElementDelegate) Or elt.Kind = EnvDTE.vsCMElement.vsCMElementNamespace) Then
Dim i As Integer
Dim mems As EnvDTE.CodeElements
mems = elt.Members
For i = 1 To mems.Count
CollapseE(mems.Item(i), mems, i, targetLines)
Next
End If
If (epStart.LessThan(epEnd)) Then
If IncludeMember(elt) Then
targetLines.Add(epStart.Line)
End If
End If
End Sub

Related

How can run the following code on multiple Excel sheets?

I have a code which I would like to use on multiple sheets, except one sheet. But applying the code to alle sheets is also fine.
Here is the code that I would like to adjust. I am have currently applied it to Excel 2011 in OS X , but I would like to use it for Excel 2010 in Windows.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim the_selection As String
Dim month_in_review As String
the_selection = Sheet1.Range("A1")
Dim Rep As Integer
For Rep = 2 To 379
the_column = GetColumnLetter_ByInteger(Rep)
month_in_review = Sheet1.Range(the_column & "1")
If the_selection = month_in_review Then
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = False
Else
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = True
End If
Next Rep
End If
End Sub
In the module I have the following code:
Public Function GetColumnLetter_ByInteger(what_number As Integer) As String
GetColumnLetter_ByInteger = ""
MyColumn_Integer = what_number
If MyColumn_Ineger <= 26 Then
column_letter = ChrW(64 + MyColumn_Integer)
End If
If MyColumn_Integer > 26 Then
column_letter = ChrW(Int((MyColumn_Integer - 1) / 26) + 64) & ChrW(((MyColumn_Integer - 1) Mod 26) + 65)
End If
GetColumnLetter_ByInteger = column_letter
End Function
If you're asking for one sheet to detect the change in cell "A1" and then to hide/unhide columns on multiple sheets then the prior answers to your question will serve you nicely.
If, on the other hand, you're asking to detect a change in cell "A1" on any sheet and then to hide/unhide columns on just the changed sheet, then the code below will work for you. It accesses the Workbook_SheetChanged event at Workbook level.
A few points about your code:
You can reference cells using their integer or address values with the .Cell property, so Sheet1.Cells(1, 1) is the same as Sheet1.Cells(1, "A"). The same applies to the .Columns property. So there's no real need to convert your integer values to a string. See #Florent B's answer for a good example of this.
Wherever possible, minimise looping sheet interactions as these are very time-consuming. So rather than loop through the columns and hide/unhide each one individually, you could assign them to ranges within your loop and then hide/unhide the ranges all in one go at the end of your loop. If you must interact with the sheet on each iteration of your loop, then set the Application.ScreenUpdating property to false before the start of your loop. There's an example of this property in the sample code below.
Put this in your Workbook module:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Const TARGET_ADDRESS As String = "A1"
Dim cell As Range
Dim hiddenCols As Range
Dim unhiddenCols As Range
Dim selectedMonth As String
Dim monthInReview As String
Dim c As Integer
'Ignore event if not a target worksheet
If Sh.Name = "Not Wanted" Then Exit Sub
'Ignore event if not in target range
Set cell = Target.Cells(1)
If cell.Address(False, False) <> TARGET_ADDRESS Then Exit Sub
'Criteria met, so handle event
selectedMonth = CStr(cell.Value)
For c = 2 To 379
Set cell = Sh.Cells(1, c)
monthInReview = CStr(cell.Value)
'Add cell to hidden or unhidden ranges
If monthInReview = selectedMonth Then
If unhiddenCols Is Nothing Then
Set unhiddenCols = cell
Else
Set unhiddenCols = Union(unhiddenCols, cell)
End If
Else
If hiddenCols Is Nothing Then
Set hiddenCols = cell
Else
Set hiddenCols = Union(hiddenCols, cell)
End If
End If
Next
'Hide and unhide the cells
Application.ScreenUpdating = False 'not really needed here but given as example
If Not unhiddenCols Is Nothing Then
unhiddenCols.EntireColumn.Hidden = False
End If
If Not hiddenCols Is Nothing Then
hiddenCols.EntireColumn.Hidden = True
End If
Application.ScreenUpdating = True
End Sub
You can use a for each loop to loop through all the Worksheets, and check the worksheet name if it should be skipped. Then apply your code onto the sheet selected.
Something like:
Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Skip Sheet" Then
Dim the_selection As String
Dim month_in_review As String
the_selection = ws.Range("A1")
Dim Rep As Integer
For Rep = 2 To 379
the_column = GetColumnLetter_ByInteger(Rep)
month_in_review = ws.Range(the_column & "1")
If the_selection = month_in_review Then
ws.Range(the_column & ":" & the_column).EntireColumn.Hidden = False
Else
ws.Range(the_column & ":" & the_column).EntireColumn.Hidden = True
End If
Next Rep
End If
Next ws
End If
End Sub
I wasn't entirely sure what you wished to achieve, so i put ws in the place of Sheet1.
This example will show/hide the columns in all the other sheets if the first cell of the column match/differ with the cell A1 of the sheet where this code is placed:
Private Sub Worksheet_Change(ByVal Target As Range)
' exit if not cell A1
If Target.row <> 1 Or Target.column <> 1 Then Exit Sub
Dim sheet As Worksheet
Dim the_selection As String
Dim month_in_review As String
Dim column As Integer
the_selection = Target.Value
' iterate all the sheets
For Each sheet In ThisWorkbook.Worksheets
' skip this sheet
If Not sheet Is Me Then
' iterate the columns
For column = 2 To 379
' get the first cell of the column
month_in_review = sheet.Cells(1, column).Value
' hide or show the column if it's a match or not
sheet.Columns(column).Hidden = month_in_review <> the_selection
Next
End If
Next
End Sub

Iterate through a treeview in VB6

I have a treeview control on the form which looks like:
I want to iterate the treeview and write the contents of the treeview to ini file. So the ini file for the given tree would look like:
[EnvironmentSystem]
UpdateRate=50.0
InclinationAngle=20.7
Latitude=34.0
[Reflection]
NumReflectionLevel=5
NumSunLightLevel=5
NumWeatherLevel=3
TextureNameFormat=Reflection%01d%01d%02d.tga
[CloudsClear]
MaxClouds=48
MaxCloudParticles=51
3DCloudMaterial=CloudMaterial
3DCloudHorizontalSize=1400.0
3DCloudVerticalSize=600.0
3DCloudSizeDeviation=0.6
3DCloudParticleDensity=2.4
ParticleSize=300.0
ParticleSizeDeviation=0.3
MinBaseAltitude=400.0
MaxBaseAltitude=2450.0
UseBottomRow=TRUE
Here is the code that I have written:
Private Sub TvSaveToIniBtn_Click()
Dim nodx As Node
Dim i As Long
Dim sectionCount As Integer
sectionCount = TreeView1.Nodes(1).Children
Set nodx = TreeView1.Nodes(1).Child.FirstSibling
For i = 1 To sectionCount
SaveNodesToIni (nodx.Text)
Set nodx = nodx.Next
Next
End Sub
Sub SaveNodesToIni(sName As Variant)
Dim tvn As Node
Set tvn = TreeView1.Nodes(sName)
Dim chil As Integer
Dim a As Integer
Dim ret As Integer
Dim keyValuePair() As String
Dim nElements As Integer
chil = tvn.Children: If chil = 0 Then Exit Sub ' if no children the exit
Set tvn = tvn.Child.FirstSibling
For a = 1 To chil
keyValuePair = Split(tvn.Text, "=")
nElements = UBound(keyValuePair) - LBound(keyValuePair) + 1
If nElements > 0 Then
ret = WritePrivateProfileString(sName, keyValuePair(0), keyValuePair(1), "C:\\MyPrograms\\config.ini")
End If
Set tvn = tvn.Next
Next
End Sub
It is not giving the correct output, it gets stuck at the second section of reflection and is not able to read the third one. Something wrong with the code.

Sorting the TimeZoneCollection list

Issue definition
I use the OpenNetCF TimeZoneCollection class to display in a ComboBox all the available time zones.
Dim tzc As New TimeZoneCollection
Dim TheIndex As Integer
Dim MyTimeZoneInfo As New TimeZoneInformation
DateTimeHelper.GetTimeZoneInformation(MyTimeZoneInfo)
tzc.Initialize()
For Each tzi As TimeZoneInformation In tzc
TheIndex = ComboBox1.Items.Add(tzi)
If tzi.StandardName = MyTimeZoneInfo.StandardName Then
ComboBox1.SelectedIndex = TheIndex
End If
Next
But they are not sorted:
How could I sort the list?
Alphabetical order is fine, time shift order is better.
Replicate this issue on your side (need VS and a CE device)
Create an empty Smart Device project (Visual Basic)
Download OpenNetCF Community Edition (free)
Add OpenNETCF.WindowsCE.dll as Reference (right click on the project -> Add Reference)
Open Form1, add a combobox, and paste code below:
Imports OpenNETCF.WindowsCE
Public Class Form1
Private Sub Form1_Activated(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Activated
Dim tzc As New TimeZoneCollection
Dim TheIndex As Integer
Dim MyTimeZoneInfo As New TimeZoneInformation
DateTimeHelper.GetTimeZoneInformation(MyTimeZoneInfo)
tzc.Initialize()
For Each tzi As TimeZoneInformation In tzc
TheIndex = ComboBox1.Items.Add(tzi)
If tzi.StandardName = MyTimeZoneInfo.StandardName Then
ComboBox1.SelectedIndex = TheIndex
End If
Next
End Sub
End Class
I realize my problem was a bit easy to solve. So, I found a simple way, in using the built-in Sort() method of the ArrayList.
what I do:
copy the DisplayName in an ArrayList of String
Sort it
Use it to re-index the collection of TimeZoneInformation.
My code:
Dim tzc As New TimeZoneCollection ' the raw collection'
Dim ar_s As New ArrayList() ' the array used to sort alphabetically the DisplayName'
Dim tzc_s As New TimeZoneCollection ' the sorted collection'
Dim TheIndex As Integer
Dim MyTimeZoneInfo As New TimeZoneInformation
DateTimeHelper.GetTimeZoneInformation(MyTimeZoneInfo)
tzc.Initialize()
' copy the display name in an array to sort them'
For Each tzi As TimeZoneInformation In tzc
ar_s.Add(tzi.DisplayName)
Next
ar_s.Sort()
' populated tzc_s, a sorted collection of TimeZoneInformation'
For i As Integer = 0 To ar_s.Count - 1
For Each tzi As TimeZoneInformation In tzc
If ar_s(i) = tzi.DisplayName Then
tzc_s.Add(tzi)
Continue For
End If
Next
Next
' Bind the sorted ArrayList to the ComboBox'
For Each tzi As TimeZoneInformation In tzc_s
TheIndex = ComboBox1.Items.Add(tzi)
If tzi.StandardName = MyTimeZoneInfo.StandardName Then
ComboBox1.SelectedIndex = TheIndex
End If
Next
I would subclass the TimeZoneCollection and add a Sort method as you alreday found but more or less implement by hand. I was not bale to verify the following as I do not have a compact framework here:
In the subclassed TimeZoneCollection add a sort method and a IComparable class. Within that class you can define whatever sort order you wich (by names, by GMT-offset...):
...
public class myTimeZoneCollection:TimeZoneCollection{
...
public class myTZIComparer : IComparer {
// return -1 for a is before b
// return +1 for a is after b
// return 0 if a is same order as b
int IComparer.Compare( Object a, Object b ) {
{
TZData c1=(TZData)a;
TZData c2=(TZData)b;
if (c1.GMTOffset > c2.GMTOffset)
return -1;//1; //this will result in reverse offset order
if (c1.GMTOffset < c2.GMTOffset)
return 1;//-1;
else
return 0;
}
}
...
public void sort(){
// Sorts the values of the ArrayList using the reverse case-insensitive comparer.
IComparer myComparer = new myTZIComparer();
this.Sort( myComparer );
}
...
}
And yes, I am sorry, this is in C# but must be do also in VB.
And, use the sorted my TimeZoneCollection to add the elements to the combobox. There is no additional work needed to get the list into the combobox in a custom sort order. Just do foreach and add.
Here is the promised full VB solution with the OpenNetCF fix:
myTimeZoneCollection.vb:
Option Strict On
Option Explicit On
Imports OpenNETCF.WindowsCE
Public Class myTimeZoneCollection
Inherits TimeZoneCollection
Dim tzc As New TimeZoneCollection
Public Sub New()
End Sub
Overloads Function Initialize() As TimeZoneCollection
tzc.Initialize()
Dim myComparer = New myTZIComparer()
tzc.Sort(myComparer)
Return tzc
End Function
Shared Function getOffsetFromDisplayName(ByVal tzi As TimeZoneInformation) As Integer
' known forms
' GMT = no offset
' GMT+6 = 6 hours offset
' GMT-12 = -6 hours offset
' GMT+4:30 = 4 hours and 30 minutes offset
' GMT-4:30 = - 4 hours and 30 minutes offset
' all these end with a space! followed by the name of the time zone
'System.Diagnostics.Debug.WriteLine("getOffsetFromDisplayName: tzi=" & tzi.ToString())
'extract offset
If (tzi.DisplayName = "GMT") Then
Return 0
End If
Dim subStr As String
subStr = tzi.DisplayName.Substring(0, tzi.DisplayName.IndexOf(" "c)) 'GMT+x or GMT-x or GMT+x:yy or GMT-x:yy
If (subStr = "GMT") Then
Return 0
End If
subStr = subStr.Substring(3) 'cut GMT from begin
'now check if this is with a minute value
Dim hoursOffset, minutesOffset, idxOfColon, idxM As Integer : idxOfColon = 0 : idxM = 0
idxOfColon = subStr.IndexOf(":"c)
If (idxOfColon = -1) Then 'no : found
hoursOffset = System.Int32.Parse(subStr)
minutesOffset = hoursOffset * 60
Else
Dim sH, sM As String
sH = subStr.Substring(0, subStr.Length - idxOfColon - 1)
sM = subStr.Substring(idxOfColon + 1)
hoursOffset = System.Int32.Parse(sH)
minutesOffset = System.Int32.Parse(sM)
If (hoursOffset > 0) Then
minutesOffset = minutesOffset + hoursOffset * 60
Else
minutesOffset = hoursOffset * 60 - minutesOffset
End If
End If
Return minutesOffset
End Function
Class myTZIComparer
Implements IComparer
'// return -1 for a is before b
'// return +1 for a is after b
'// return 0 if a is same order as b
Public Function Compare(ByVal a As Object, ByVal b As Object) As Integer Implements IComparer.Compare
Dim c1 As TimeZoneInformation = CType(a, TimeZoneInformation)
Dim c2 As TimeZoneInformation = CType(b, TimeZoneInformation)
Dim offset1, offset2 As Integer
offset1 = getOffsetFromDisplayName(c1)
offset2 = getOffsetFromDisplayName(c2)
If (offset1 > offset2) Then
Return -1 '//1; //this will result in reverse offset order
ElseIf (offset1 < offset2) Then
Return 1 '//-1;
Else 'offsets equal, sort by name
If (c1.DisplayName < c2.DisplayName) Then
Return -1
ElseIf (c1.DisplayName > c2.DisplayName) Then
Return 1
Else
Return 0
End If
End If
End Function
End Class
End Class
By changing or adding another myTZIComparer you can define the order of the entries.
The OpenNetCF code is wrong for the new timezone names
' GMT+4:30 = 4 hours and 30 minutes offset
' GMT-4:30 = - 4 hours and 30 minutes offset
as it does only look for full hour offsets. So I needed to develop a new 'parser' to get the bias data.
In your code with the listbox:
Public Sub fillList()
ComboBox1.Items.Clear()
Dim tzc As New TimeZoneCollection
Dim TheIndex As Integer
Dim MyTimeZoneInfo As New TimeZoneInformation
DateTimeHelper.GetTimeZoneInformation(MyTimeZoneInfo)
tzc.Initialize()
For Each tzi As TimeZoneInformation In tzc
TheIndex = ComboBox1.Items.Add(tzi)
If tzi.StandardName = MyTimeZoneInfo.StandardName Then
ComboBox1.SelectedIndex = TheIndex
End If
Next
End Sub
The above fills the list in the order the items are.
Public Sub fillListGMT()
ComboBox1.Items.Clear()
Dim tzc As New myTimeZoneCollection 'subclassed one
Dim TheIndex As Integer
Dim MyTimeZoneInfo As New TimeZoneInformation
DateTimeHelper.GetTimeZoneInformation(MyTimeZoneInfo)
Dim tzc1 As New TimeZoneCollection
tzc1.Clear()
tzc1 = tzc.Initialize()
For Each tzi As TimeZoneInformation In tzc1
TheIndex = ComboBox1.Items.Add(tzi)
If tzi.StandardName = MyTimeZoneInfo.StandardName Then
ComboBox1.SelectedIndex = TheIndex
End If
Next
End Sub
The code above fills the list ordered by GMT offset.
This answer is based on #Josef's idea (written in C#), and translated to VB.
This is the customized class:
Public Class myTimeZoneCollection
Inherits TimeZoneCollection
Public Class myTZIComparer
Implements IComparer
' return -1 for a is before b
' return +1 for a is after b
' return 0 if a is same order as b '
Public Function Compare(ByVal a As Object, ByVal b As Object) As Integer _
Implements IComparer.Compare
Dim c1 As TimeZoneInformation = CType(a, TimeZoneInformation)
Dim c2 As TimeZoneInformation = CType(b, TimeZoneInformation)
If (c1.Bias > c2.Bias) Then
Return -1 ' 1; //this will result in reverse offset order'
End If
If (c1.Bias < c2.Bias) Then
Return 1 ' -1;'
Else ' sort by name '
If (c1.DisplayName < c2.DisplayName) Then
Return -1
End If
If (c1.DisplayName > c2.DisplayName) Then
Return 1
Else
Return 0
End If
End If
End Function
End Class
Public Sub MySort()
' Sorts the values of the ArrayList using the specific sort Comparer (by Bias)'
Dim myComparer As IComparer = New myTZIComparer()
Me.Sort(myComparer)
End Sub
End Class
And this is the usage in the form
Private Sub Form1_Activated(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Activated
Dim tzc As New myTimeZoneCollection ' this is the customized class
Dim TheIndex As Integer ' this index is used to select the activated time zone of the system
Dim MyTimeZoneInfo As New TimeZoneInformation
DateTimeHelper.GetTimeZoneInformation(MyTimeZoneInfo)
tzc.Initialize()
tzc.MySort()
' Clear the item list otherwise it is increased at each Activated event.. '
ComboBox1.Items.Clear()
For Each tzi As TimeZoneInformation In tzc
TheIndex = ComboBox1.Items.Add(tzi)
If tzi.StandardName = MyTimeZoneInfo.StandardName Then
ComboBox1.SelectedIndex = TheIndex
End If
Next
End Sub
I validated this code on a device, it works fine.

MS Visual Basic how to sort 1 array and return index for second array?

the language I am looking is MS Visual Basic.
How can I sort an array and change other arrays accordingly (using an index?)
I was searching, but couldnt find any stuff on that. Any help is greatly appreciated!!!
e.g. Sort array BirthArray and change the order of Array1 and ID accordingly?
Array1 = 'John', 'Christina','Mary', 'frediric', 'Johnny','billy','mariah'
BirthArray = 1998, 1923, 1983,1982,1924,1923,1954
ID = 12312321, 1231231209, 123123, 234324, 23423, 2234234,932423
Dim Array() As String
Dim BirthArray() As Integer
Dim ID() As Integer
Thanks a lot!
You should make a class to hold the values, put a collection of the classes into a List, then sort the the list using a lambda expression:
Public Class Info
Public Property Name As String
Public Property BirthYear As Integer
Public Property ID As Integer
Public Sub New()
End Sub
Public Sub New(sName As String, wBirthYear As Integer, wID As Integer)
Me.New
Me.Name = sName
Me.BirthYear = wBirthYear
Me.ID = wID
End Sub
End Class
Public Sub DoSort()
Dim cRecords As New System.Generic.List(Of Info)
cRecords.Add(New Info('John', 1998, 12312321)
' ToDo: Add more records
cRecords.Sort(
Function (ByVal oItem1 As Info, ByVal oItem2 As Info)
Return oItem2.BirthYear.CompareTo(oItem1.BirthYear)
End Function)
End Sub
The proposed soluton below (based on your VBA tag).
creates a 2D array from 3 single arrays (as suggested by Jesse)
uses Redim Preserve to add a fourth dataset "NewData" to a 2D array "ArrayMaster"
creates a temporary worksheet, dumps "ArrayMaster" to it, sorts by "Newdata" (ascending order) to create a sorted array, "ArrayMaster2"
deletes the working sheet
Excel is very efficient at sorting, so this method provided an easy and quick way for a sort (or multi level sort)
You could use a bubble sort technique if Excel wasn't available for the sheet dump/sort
Option Base 1
Sub ComboArray()
Dim ws As Worksheet
Dim Array1()
Dim Birthday()
Dim ID()
Dim NewData()
Dim ArrayMaster()
Dim ArrayMaster2()
Dim lngRow As Long
Dim lngCalc As Long
Dim lngCheck As Long
Birthday = Array(1998, 1923, 1983, 1982, 1924, 1923, 1954)
Array1 = Array("John", "Christina", "Mary", "frediric", "Johnny", "billy", "mariah")
ID = Array(12312321, 1231231209, 123123, 234324, 23423, 2234234, 932423)
ReDim ArrayMaster(1 To UBound(Array1, 1), 1 To 3)
'Create 2D MasterArray
For lngRow = 1 To UBound(Array1, 1)
ArrayMaster(lngRow, 1) = Array1(lngRow)
ArrayMaster(lngRow, 2) = Birthday(lngRow)
ArrayMaster(lngRow, 3) = ID(lngRow)
Next
NewData = Array(1, 3, 5, 7, 2, 4, 6)
'Check if new field is longer than overall array
If UBound(NewData, 1) > UBound(ArrayMaster, 1) Then
lngCheck = MsgBox("New field exceeds current array size, proceeding will drop off excess records" & vbNewLine & "(Press Cancel to end code)", vbOKCancel, "Do you want to proceed?")
If lngCheck = vbCancel Then Exit Sub
End If
'Add NewData field
ReDim Preserve ArrayMaster(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2) + 1)
For lngRow = 1 To UBound(NewData, 1)
ArrayMaster(lngRow, UBound(ArrayMaster, 2)) = NewData(lngRow)
Next
With Application
.ScreenUpdating = False
.DisplayAlerts = False
lngCalc = .Calculation
End With
'Create working sheet, dump MasterArray and sort by Newdata (position 4 = cell D1)
Set ws = Worksheets.Add
ws.[a1].Resize(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2)).Value2 = ArrayMaster
ws.UsedRange.Sort ws.[d1], xlAscending
'Create our sorted array MasterArray2, now with NewData(1,2,3,4,5,6,7)
ArrayMaster2 = ws.[a1].Resize(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2)).Value2
ws.Delete
'cleanup working sheet
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = lngCalc
End With
End Sub

Treeview Excel 2007 programatically select check boxes

I have a TreeView in excel 2007 with checkboxes.
I want the checkboxes to be all selected when the tree is populated
I want that when I select/unselect a parent node of the list, all its children are selected/unselected
Here is the code I have written so far:
Private Sub UserForm_Initialize()
'Set control defaults
With Me
.CommandButton1.Caption = "Close"
.Label1 = vbNullString
.ZonesTree.LineStyle = tvwRootLines
End With
'Populate the Treeview
Call TreeView_Populate
End Sub
Private Sub TreeView_Populate()
Dim wbBook As Workbook
Dim wsZones As Worksheet
Dim rngZones As Range
Dim rngCinemas As Range
Dim lngRows As Long
Set wbBook = ThisWorkbook
Set wsZones = wbBook.Worksheets("Cinemas")
'lngRows = wsZones.Range("A65536").End(xlUp).row
lngRows = wsZones.UsedRange.Rows.Count
Set rngZones = wsZones.Range("A1:A" & lngRows)
Dim rngBC As Range
Set rngBC = wsZones.Range("B1:C" & lngRows)
Dim rCell As Range
Dim lastCreatedKey As String
Dim rowCount As Integer
Dim currentRowRange As Range
rowCount = 1
lastCreatedKey = ""
With Me.ZonesTree.Nodes
'Clear TreeView control
.Clear
For Each rCell In rngZones
If Not rCell.Text = "" Then
.Add Key:=rCell.Text, Text:=rCell.Text
lastCreatedKey = rCell.Text
Else
Set currentRowRange = rngBC.Rows(rowCount)
.Add Relative:=lastCreatedKey, relationship:=tvwChild, Key:=currentRowRange.Cells(, 2).Text, Text:=currentRowRange.Cells(, 1).Text
End If
rowCount = rowCount + 1
Next rCell
End With
End Sub
Private Sub Treeview1_NodeClick(ByVal Node As MSComctlLib.Node)
Me.Label1.Caption = Node.Key
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
This tree picks data from a sheet in this manner:
---A---------B---------C---------D
ParentNode
------------ChildNode
------------ChildNode
------------ChildNode
ParentNode
------------ChildNode
------------ChildNode
ParentNode
------------ChildNode
etc... (you get the idea, its an excel sheet...)
What is the vba code to select/unselect the boxes?? I have been searching a lot and couldn't find an answer to this easy problem....
Thx in advance!
On access which I assume uses the same control the property you use is .checked
Just set that to true for the boxes you want ticked
Here is a code sample
Set iNode = objTree.Nodes.Add(strParent,tvwChild, strKey, strText)
iNode.Checked = true
You should be to adapt it to work in excel

Resources