when i tried to move the tube for example to (x,y) (0, 0.1) direction and the other tube to (x,y) (0, -0.1) it acts like a subtraction so both of them doesn't move (0.1-0.1) so how do i solve this.
sub tube (R#, T#, JumPias#)
dim pi#
dim teta#
dim N#
dim x1#, y1#, z1#
dim x2#, y2#, z2#
dim x3#, y3#, z3#
dim x4#, y4#, z4#
dim xa#, ya#, za#
dim xb#, yb#, zb#
dim sd1#, sd2#
pi#=3.1415926535897932384626433832795
teta#=2*pi#/JumPias#
glBegin(GL_QUADS)
for N#=0 to JumPias# -1
sd1#=N#*teta#
sd2#=(N#+1)*teta#
x1#=0
y1#=R#*cos(sd1#)
z1#=R#*sin(sd1#)
x2#=0
y2#=R#*cos(sd2#)
z2#=R#*sin(sd2#)
x3#=T#
y3#=R#*cos(sd2#)
z3#=R#*sin(sd2#)
x4#=T#
y4#=R#*cos(sd1#)
z4#=R#*sin(sd1#)
'pias selubung
glVertex3f(x1#,y1# , z1#) 'P1
glVertex3f(x2#,y2# , z2#) 'P2
glVertex3f(x3#,y3# , z3#) 'P3
glVertex3f(x4#,y4# , z4#) 'P4
next
glEnd()
end sub
dim a#
while true
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT)
glmatrixmode (GL_MODELVIEW)
glloadidentity ()
gltranslatef(0, 0, -25.0)
a#=a#+0.1
glrotatef(a#,0,1,0)
tube(1,3,10)
gltranslatef(0,10,0)
a#=a#-0.1
tube(1,3,10)
swapbuffers()
wend
Related
I have 2 strings that each contain 25 characters. E.g.
X = "0000111111110111111111110"
Y = "0000011111000000000000000"
What would be the most efficient method to identify, true or false if every position that has a "1" string Y also has a "1" in string X? In this example it should return True as there are 1s in X that match the positions of all 1s in Y.
I could read each character position and do a comparison for all 25 but was hoping some clever person would know of a more elegant way.
The easier way is to use Convert.ToInt32() to parse the string as a binary literal and perform binary AND:
Public Function MatchAsBinary(ByVal x As String, ByVal y As String) As Boolean
Dim x_int = Convert.ToInt32(x, 2)
Dim y_int = Convert.ToInt32(y, 2)
Return (x_int And y_int) = y_int
End Function
The faster (~10 times in release build) way is to compare the chars directly:
Public Function MatchAsChars(ByVal x As String, ByVal y As String) As Boolean
For i As Integer = 0 To y.Length - 1
If y(i) = "1"c AndAlso x(i) = "0"c Then
Return False
End If
Next
Return True
End Function
If you regard the strings as binary numbers, you can convert them to numbers and then use the bitwise and operator, like this:
Module Module1
Sub Main()
Dim X = "0000111111110111111111110"
Dim Y = "0000011111000000000000000"
Dim Xb = Convert.ToInt64(X, 2)
Dim Yb = Convert.ToInt64(Y, 2)
Console.WriteLine((Xb And Yb) = Yb)
Console.ReadLine()
End Sub
End Module
That will output True and work for strings of up to 64 characters.
Or, following on from your comment, you could use Convert.ToInt32 as that would give enough bits for your data.
Can do something similar #JoshD said above, but use Convert.ToInt32(Y, 2) to convert from a binary string to an integer.
Xint = Convert.ToInt32(X, 2)
Yint = Convert.ToInt32(Y, 2)
return ((Xint And Yint) = Yint)
This includes what others have shown plus a test for each bit one at a time.
Dim s As String = "0000011111000000000000000"
Dim X As String = "0000111111110111111111110"
Dim Y As String = "0000011111000000000000000"
Dim xi As Integer = Convert.ToInt32(X, 2)
Dim yi As Integer = Convert.ToInt32(Y, 2)
'check each bit
For i As Integer = 0 To 24
Dim msk As Integer = 1 << i
If (msk And xi) = msk AndAlso (msk And yi) = msk Then
Debug.WriteLine("Bit {0} on in both", i)
End If
Next
'all bits
Dim rslt As Integer = xi And yi
s = Convert.ToString(rslt, 2).PadLeft(25, "0"c)
Dim intY As Integer = CInt(Y)
Dim res As Boolean = (CInt(X) And intY) = intY
Convert them to integers, get all instances of matching 1's with a bitwise And, then compare to see if Y was changed by that comparison. If the comparison preserved the original Y, the result will be True.
I have a spreadsheet with two raw data sheets on separate excel tabs that has been extracted from a finance system, containing values that represent cost codes. The dataset on both tabs is quite large and the codes that I want listed just once are repeated multiple times. I want a macro that will scan these two relevant columns (say column A on both sheets) and list the cost codes once in numerical order on a third sheet.
I've searched this site but can't seem to find a code that does the above completely.
Thanks in advance
This may not be the fastest implementation possible, as it mostly relies on VBA operations to do the work, except the final sort. Has not been tested.
Sub AppendUnique(ByVal W1 As Worksheet, ByVal W2 As Worksheet, ByVal R1 As Long, ByVal R2 As Long, ByVal C1 As Long, ByVal C2 As Long)
' Append values from an unsorted column to a new unique but unsorted column
Dim V1 As Variant, V2 As Variant
Dim I As Long
V1 = W1.Cells(R1, C1).Value
While Not IsEmpty(V1)
I = R2
V2 = W2.Cells(I, C2).Value
While Not IsEmpty(V2)
If V2 = V1 Then Exit While
I = I + 1
V2 = W2.Cells(I, C2).Value
Wend
W2.Cells(I, C2).Value = V1
R1 = R1 + 1
V1 = W1.Cells(R1, C1).Value
Wend
End Sub
Dim W1 As Worksheet, W2 As Worksheet, W3 As Worksheet
Dim C1 As Long, Dim C2 As Long, Dim C3 As Long
Dim R1 As Long, Dim R2 As Long, Dim R3 As Long
Set W1 = Worksheets("Sheet1") ' Source 1
Set W2 = Worksheets("Sheet2") ' Source 2
Set W3 = Worksheets("Sheet3") ' Destination
C1 = 1 ' Column on Sheet1: Source 1
C2 = 1 ' Column on Sheet2: Source 2
C3 = 1 ' Column on Sheet3: Destination
R1 = 1 ' Starting Row on Sheet1: Source 1
R2 = 1 ' Starting Row on Sheet2: Source 2
R3 = 1 ' Starting Row on Sheet3: Destination
AppendUnique W1, W3, R1, R3, C1, C3
AppendUnique W2, W3, R2, R3, C2, C3
W3.Range(W3.Cells(R3, C3), W3.Cells(R3, C3).End(xlDown)).Sort
The below code will split 1 cell into 3 or 4 column based on a pattern of 6chr,5chr,4chr,5+chr. The below also needs to be available on all open workbooks and work from the user selection.
How to fix a bug that after the first splitting of the cell is done and by mistake you run it again will override the data?
Class Module
Option Explicit
'Rename this Class Module cFabric
Private pStyle As String
Private pFabric As String
Private pColour As String
Private pSize As String
Public Property Get Style() As String
Style = pStyle
End Property
Public Property Let Style(Value As String)
pStyle = Value
End Property
Public Property Get Fabric() As String
Fabric = pFabric
End Property
Public Property Let Fabric(Value As String)
pFabric = UCase(Value)
End Property
Public Property Get Colour() As String
Colour = pColour
End Property
Public Property Let Colour(Value As String)
pColour = Value
End Property
Public Property Get Size() As String
Size = pSize
End Property
Public Property Let Size(Value As String)
pSize = Value
End Property
Regular Module
Option Explicit
Sub Fabrics()
Dim wsSrc As Workbook, wsRes As Workbook
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveWorkbook
Set wsRes = ActiveWorkbook
Set rRes = wsRes.Application.Selection
'Read source data into array
vSrc = Application.Selection
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
'iterate through the list
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
Else
cF.Style = S
End If
colF.Add cF
Next I
End With
'create results array
'Exit if no results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate the rest
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.Value = vRes
End Sub
Credits for the above goes to #Ron Rosenfeld for the project!
One way to tell if the entry has been previously split is as follows
If the regex.test fails, then
If the results line passes, then the item has been previously split
if not, then it is a blank, or a malformed entry
Note that a lot of this could be avoided if you were not overwriting your original data. I would recommend against overwriting your data both for audit and debugging purposes, but the below should help in case you cannot change that.
You just need to make some small changes in the logic where we checked for the malformed entry originally. As well as reading in the "possible" results array into vSrc so that we have the potentially split data to compare:
Option Explicit
Sub Fabrics()
'assume data is in column A
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveSheet
Set wsRes = ActiveSheet
Set rRes = Selection
'Read source data into array
vSrc = Selection.Resize(columnsize:=4)
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'iterate through the list
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
ElseIf .test(vSrc(I, 1) & vSrc(I, 2) & vSrc(I, 3)) = False Then
cF.Style = S
Else
cF.Style = vSrc(I, 1)
cF.Fabric = vSrc(I, 2)
cF.Colour = vSrc(I, 3)
cF.Size = vSrc(I, 4)
End If
colF.Add cF
Next I
End With
'create results array
'Exit if not results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Clear
.NumberFormat = "#"
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
Disregarding the previous regex/class method,
Option Explicit
Sub Fabrics_part_Deux()
Dim a As Long, b As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 3))
With .Columns("B")
.Offset(1, 0).Replace what:=Chr(32), replacement:=vbNullString, lookat:=xlPart
End With
.AutoFilter field:=2, Criteria1:="<>"
.AutoFilter field:=3, Criteria1:=""
With .Resize(.Rows.Count - 1, 1).Offset(1, 1)
If CBool(Application.Subtotal(103, .Cells)) Then
With .SpecialCells(xlCellTypeVisible)
For a = 1 To .Areas.Count
With .Areas(a).Cells
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(11, 1), Array(15, 2))
For b = 1 To .Rows.Count
.Cells(b, 2) = UCase$(.Cells(b, 2).Value2)
If CBool(InStr(1, .Cells(b, 4).Value2, Chr(47), vbBinaryCompare)) Then
.Cells(b, 4) = Trim(Split(.Cells(b, 4), Chr(47))(1))
End If
Next b
End With
Next a
End With
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
In your code to output to the spreadsheet, you need to check for empty strings
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
If len(.Fabric) > 0 then
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End If
End With
Next V
I can not get this shader to return its uniforms.
I have looked everywhere for a possible problem with my shader assembler or bindings. I even rebooted my machine (desktop quad core) thinking maybe the OpenGL driver crapped out.
Here's the code that tries but fails to get the uniform locations:
Private Sub set_deferredLighting_variables()
deferred_cam_position = Gl.glGetUniformLocation(shader_list.deferred_shader, "viewPos")
deferred_light_position = Gl.glGetUniformLocation(shader_list.deferred_shader, "Light_position")
deferred_gcolor = Gl.glGetUniformLocation(shader_list.deferred_shader, "gColor")
deferred_gnormal = Gl.glGetUniformLocation(shader_list.deferred_shader, "gNormal")
deferred_gposition = Gl.glGetUniformLocation(shader_list.deferred_shader, "gPosition")
End Sub
And here is the fragment shader:
#version 330 core
in vec2 TexCoords;
out vec4 FragColor;
uniform sampler2D gPosition;
uniform sampler2D gNormal;
uniform sampler2D gColor;
uniform vec3 Light_position;
uniform vec3 viewPos;
void main()
{
vec3 light_Color = vec3 (1.0, 1.0, 0.9);
// Retrieve data from G-buffer
vec3 FragPos = texture(gPosition, TexCoords).rgb;
vec3 Normal = texture(gNormal, TexCoords).rgb;
vec3 Albedo = texture(gColor, TexCoords).rgb;
float Specular = texture(gNormal, TexCoords).a;
// Then calculate lighting as usual
vec3 lighting = Albedo * 0.1; // hard-coded ambient component
vec3 viewDir = normalize(viewPos - FragPos);
// Diffuse
vec3 lightDir = normalize(Light_position - FragPos);
vec3 diffuse = max(dot(Normal, lightDir), 0.0) * Albedo * light_Color;
FragColor = vec4(lighting + diffuse, 1.0);
}
For the life of me I can't find a reason why the uniforms are not showing up.
I have a very very good shader assembler that checks at every stage for the status and any glGetError. If glGetError returns anything but 0, it throws up a message box. My assembler reads and builds the shaders in the folder.. Naming of the shaders is critical. The assembler builds 20+ shaders with no problem including this one.. There are absolutely no errors thrown!
I had this issue once a few months back and rebooting fixed the problem.. I tried that.. No luck.
Any help would be fantastic!
Here is the shader assembler code: Not how crazy I am at checking every thing.
Public Function assemble_shader(v As String, g As String, f As String, ByRef shader As Integer, ByRef name As String, ByRef has_geo As Boolean) As Integer
Dim vs(1) As String
Dim gs(1) As String
Dim fs(1) As String
Dim vertexObject As Integer
Dim geoObject As Integer
Dim fragmentObject As Integer
Dim status_code As Integer
Dim info As New StringBuilder
info.Length = 1024
Dim info_l As Integer
If shader > 0 Then
Gl.glUseProgram(0)
Gl.glDeleteProgram(shader)
Gl.glGetProgramiv(shader, Gl.GL_DELETE_STATUS, status_code)
Gl.glFinish()
End If
Dim e = Gl.glGetError
If e <> 0 Then
Dim s = Glu.gluErrorString(e)
Dim ms As String = System.Reflection.MethodBase.GetCurrentMethod().Name
'MsgBox("Function: " + ms + vbCrLf + "Error! " + s, MsgBoxStyle.Exclamation, "OpenGL Issue")
End If
'have a hard time with files remaining open.. hope this fixes it! (yep.. it did)
Using vs_s As New StreamReader(v)
vs(0) = vs_s.ReadToEnd
vs_s.Close()
vs_s.Dispose()
End Using
Using fs_s As New StreamReader(f)
fs(0) = fs_s.ReadToEnd
fs_s.Close()
fs_s.Dispose()
End Using
If has_geo Then
Using gs_s As New StreamReader(g)
gs(0) = gs_s.ReadToEnd
gs_s.Close()
gs_s.Dispose()
End Using
End If
vertexObject = Gl.glCreateShader(Gl.GL_VERTEX_SHADER)
fragmentObject = Gl.glCreateShader(Gl.GL_FRAGMENT_SHADER)
'--------------------------------------------------------------------
shader = Gl.glCreateProgram()
' Compile vertex shader
Gl.glShaderSource(vertexObject, 1, vs, vs(0).Length)
Gl.glCompileShader(vertexObject)
Gl.glGetShaderInfoLog(vertexObject, 8192, info_l, info)
Gl.glGetShaderiv(vertexObject, Gl.GL_COMPILE_STATUS, status_code)
If Not status_code = Gl.GL_TRUE Then
Gl.glDeleteShader(vertexObject)
gl_error(name + "_vertex didn't compile!" + vbCrLf + info.ToString)
'Return
End If
e = Gl.glGetError
If e <> 0 Then
Dim s = Glu.gluErrorString(e)
Dim ms As String = System.Reflection.MethodBase.GetCurrentMethod().Name
MsgBox("Function: " + ms + vbCrLf + "Error! " + s, MsgBoxStyle.Exclamation, "OpenGL Issue")
End If
If has_geo Then
'geo
geoObject = Gl.glCreateShader(Gl.GL_GEOMETRY_SHADER_EXT)
Gl.glShaderSource(geoObject, 1, gs, gs(0).Length)
Gl.glCompileShader(geoObject)
Gl.glGetShaderInfoLog(geoObject, 8192, info_l, info)
Gl.glGetShaderiv(geoObject, Gl.GL_COMPILE_STATUS, status_code)
If Not status_code = Gl.GL_TRUE Then
Gl.glDeleteShader(geoObject)
gl_error(name + "_geo didn't compile!" + vbCrLf + info.ToString)
'Return
End If
e = Gl.glGetError
If e <> 0 Then
Dim s = Glu.gluErrorString(e)
Dim ms As String = System.Reflection.MethodBase.GetCurrentMethod().Name
MsgBox("Function: " + ms + vbCrLf + "Error! " + s, MsgBoxStyle.Exclamation, "OpenGL Issue")
End If
Gl.glProgramParameteriEXT(shader, Gl.GL_GEOMETRY_INPUT_TYPE_EXT, Gl.GL_TRIANGLES)
Gl.glProgramParameteriEXT(shader, Gl.GL_GEOMETRY_OUTPUT_TYPE_EXT, Gl.GL_LINE_STRIP)
If name.Contains("normal") Then
Gl.glProgramParameteriEXT(shader, Gl.GL_GEOMETRY_VERTICES_OUT_EXT, 18)
Else
Gl.glProgramParameteriEXT(shader, Gl.GL_GEOMETRY_VERTICES_OUT_EXT, 4) 'leaf needs 4
End If
e = Gl.glGetError
If e <> 0 Then
Dim s = Glu.gluErrorString(e)
Dim ms As String = System.Reflection.MethodBase.GetCurrentMethod().Name
MsgBox("Function: " + ms + vbCrLf + "Error! " + s, MsgBoxStyle.Exclamation, "OpenGL Issue")
End If
End If
' Compile fragment shader
Gl.glShaderSource(fragmentObject, 1, fs, fs(0).Length)
Gl.glCompileShader(fragmentObject)
Gl.glGetShaderInfoLog(fragmentObject, 8192, info_l, info)
Gl.glGetShaderiv(fragmentObject, Gl.GL_COMPILE_STATUS, status_code)
If Not status_code = Gl.GL_TRUE Then
Gl.glDeleteShader(fragmentObject)
gl_error(name + "_fragment didn't compile!" + vbCrLf + info.ToString)
'Return
End If
e = Gl.glGetError
If e <> 0 Then
Dim s = Glu.gluErrorString(e)
Dim ms As String = System.Reflection.MethodBase.GetCurrentMethod().Name
MsgBox("Function: " + ms + vbCrLf + "Error! " + s, MsgBoxStyle.Exclamation, "OpenGL Issue")
End If
'attach shader objects
Gl.glAttachShader(shader, fragmentObject)
If has_geo Then
Gl.glAttachShader(shader, geoObject)
End If
Gl.glAttachShader(shader, vertexObject)
'link program
Gl.glLinkProgram(shader)
' detach shader objects
Gl.glDetachShader(shader, fragmentObject)
If has_geo Then
Gl.glDetachShader(shader, geoObject)
End If
Gl.glDetachShader(shader, vertexObject)
e = Gl.glGetError
If e <> 0 Then
Dim s = Glu.gluErrorString(e)
Dim ms As String = System.Reflection.MethodBase.GetCurrentMethod().Name
MsgBox("Function: " + ms + vbCrLf + "Error! " + s, MsgBoxStyle.Exclamation, "OpenGL Issue")
End If
Gl.glGetShaderiv(shader, Gl.GL_LINK_STATUS, status_code)
If Not status_code = Gl.GL_TRUE Then
Gl.glDeleteProgram(shader)
gl_error(name + " did not link!" + vbCrLf + info.ToString)
'Return
End If
'delete shader objects
Gl.glDeleteShader(fragmentObject)
Gl.glGetShaderiv(fragmentObject, Gl.GL_DELETE_STATUS, status_code)
If has_geo Then
Gl.glDeleteShader(geoObject)
Gl.glGetShaderiv(geoObject, Gl.GL_DELETE_STATUS, status_code)
End If
Gl.glDeleteShader(vertexObject)
Gl.glGetShaderiv(vertexObject, Gl.GL_DELETE_STATUS, status_code)
e = Gl.glGetError
If e <> 0 Then
'aways throws a error after deletion even though the status shows them as deleted.. ????
Dim s = Glu.gluErrorString(e)
Dim ms As String = System.Reflection.MethodBase.GetCurrentMethod().Name
'MsgBox("Function: " + ms + vbCrLf + "Error! " + s, MsgBoxStyle.Exclamation, "OpenGL Issue")
End If
vs(0) = Nothing
fs(0) = Nothing
If has_geo Then
gs(0) = Nothing
End If
GC.Collect()
GC.WaitForFullGCComplete()
Return shader
End Function
Once I use visualTreeHelper.getchild to find a child object, how would I get the name of that object, or even other properties of the object like width or height?
i.e.
This doesnt work:
For i As Integer = 0 To VisualTreeHelper.GetChildrenCount(Can1) - 1
Dim ChildVisual As Visual = CType(VisualTreeHelper.GetChild(Can1, i), Visual)
Dim ChildName As DependencyProperty = childVisual.GetValue(Name)
It says value of type "Name" cannot be converted to a system.windows.dependencyProperty
Nor does this work (But at least it compiles):
For i As Integer = 0 To VisualTreeHelper.GetChildrenCount(Can1) - 1
Dim childVisual As Visual = CType(VisualTreeHelper.GetChild(Can1, i), Visual)
Dim GT1 As GeneralTransform = childVisual.TransformToAncestor(Can1)
Dim currentpoint As Point = GT1.Transform(New Point(0, 0))
x = currentpoint.X
y = currentpoint.Y
If I hover over childvisual, I can look at it's properties and see that name has been set to a name of an image I have on the canvas(Can1).
But, X and Y are always 0.
I found this finally on the net, and it seems to work great.
Dim childVisual As Visual = CType(VisualTreeHelper.GetChild(Can1, i), Visual)
Dim ChildName As String = ChildVisual.GetValue(Control.NameProperty)