I am trying to animate the position of a border control in code. For the life of me I cannot see what is wrong with this code, but it I keep getting an error on Storyboard.Begin()
"No installed components were detected. Cannot resolve TargetProperty
(UIElement.RenderTransformProperty).(CompositeTransform.TranslateXProperty)
on specified object.
Below is the code I am using:
Private Sub bdrTest1_PointerPressed(sender As Object, e As PointerRoutedEventArgs) Handles bdrTest1.PointerPressed
Animate(1, -100, 2)
End Sub
Private AnimateToX As Integer
Private AnimateToY As Integer
Private IsAnimating As Boolean
Private WithEvents Storyboard As Storyboard
Private Sub Animate(dx As Integer, dy As Integer, dt As Double)
bdrTest1.RenderTransform = New CompositeTransform
Dim duration As New Duration(TimeSpan.FromSeconds(dt))
Dim DoubleAnimationX As New DoubleAnimation With {
.Duration = duration,
.EasingFunction = New ExponentialEase() With {.Exponent = 7, .EasingMode = EasingMode.EaseOut},
.To = dx
}
AnimateToX = dx
Dim DoubleAnimationY As New DoubleAnimation With {
.Duration = duration,
.EasingFunction = New ExponentialEase() With {.Exponent = 7, .EasingMode = EasingMode.EaseOut},
.To = dy
}
AnimateToY = dy
Storyboard = New Storyboard With {.Duration = duration}
Storyboard.SetTarget(DoubleAnimationX, bdrTest1)
Storyboard.SetTargetProperty(DoubleAnimationX, "(UIElement.RenderTransformProperty).(CompositeTransform.TranslateXProperty)")
Storyboard.Children.Add(DoubleAnimationX)
Storyboard.SetTarget(DoubleAnimationY, bdrTest1)
Storyboard.SetTargetProperty(DoubleAnimationY, "(UIElement.RenderTransformProperty).(CompositeTransform.TranslateYProperty)")
Storyboard.Children.Add(DoubleAnimationY)
IsAnimating = True
Storyboard.Begin()
End Sub
Private Sub Storyboard_Completed(sender As Object, e As Object) Handles Storyboard.Completed
CType(sender, Storyboard).Stop()
IsAnimating = False
End Sub
I am using slightly similar code to animate a large image in a scroll viewer on a page, and it works fine, but I can't seem to translate that to moving a simple control.
Any help would be appreciated.
OK. Several hours of web searching later, I see the error of my ways:
Simply dropped the 'Property' descriptor from the path names, thus changing:
Storyboard.SetTargetProperty(DoubleAnimationX, "(UIElement.RenderTransformProperty).(CompositeTransform.TranslateXProperty)")
to:
Storyboard.SetTargetProperty(DoubleAnimationX, "(UIElement.RenderTransform).(CompositeTransform.TranslateX)")
Now it works fine.
Related
I'm trying to create a custom ComboBox with rounded corners where i'm still able to edit the text through user input. The solution i have so far allows me to have a decent ComboBox but only in DropDownList style, i want to go the extra mile and try to paint the embedded EditControl that appears when the combobox is set to DropDown. The solution i have so far is
Public Sub New()
' Esta llamada es exigida por el diseñador.
InitializeComponent()
' Agregue cualquier inicialización después de la llamada a InitializeComponent().
Me.SetStyle(ControlStyles.UserPaint _
Or ControlStyles.AllPaintingInWmPaint _
Or ControlStyles.Opaque _
Or ControlStyles.ResizeRedraw, True)
Me.m_ControlBuffer = New Bitmap(Me.Width, Me.Height)
Me.m_ControlGraphics = Graphics.FromImage(m_ControlBuffer)
Me.m_BackBuffer = New Bitmap(Me.Width, Me.Height)
Me.m_BackGraphics = Graphics.FromImage(m_BackBuffer)
Dim backcolor As Color = If(Enabled, m_UITheme.TextBoxColor, Color.White)
BackgroundBrush = New SolidBrush(backcolor)
Me.BackColor = backcolor
End Sub
and Paint method is
Public Sub CustomPaint(screenGraphics As Graphics)
' If there is body to be drawn.
If Me.Width > 0 AndAlso Me.Height > 0 Then
' Clear the background image graphics
If Me.m_backImage Is Nothing Then
' Cached Background Image
Me.m_backImage = New Bitmap(Me.Width, Me.Height)
Dim backGraphics As Graphics = Graphics.FromImage(Me.m_backImage)
backGraphics.Clear(Color.Transparent)
Me.PaintTransparentBackground(backGraphics, Me.ClientRectangle)
End If
m_BackGraphics.Clear(Color.Transparent)
m_BackGraphics.DrawImageUnscaled(Me.m_backImage, 0, 0)
m_ControlGraphics.Clear(Color.Transparent)
m_ControlGraphics.SmoothingMode = SmoothingMode.HighQuality
' Begin drawing
Dim path As GraphicsPath = GetBoxBorder()
m_ControlGraphics.FillPath(BackgroundBrush, path)
PaintArrowAndLine(m_ControlGraphics)
' Draw text
DrawText(m_ControlGraphics)
m_ControlGraphics.Flush()
m_BackGraphics.DrawImage(m_ControlBuffer,
New Rectangle(0, 0,
m_ControlBuffer.Width,
m_ControlBuffer.Height),
0, 0,
m_ControlBuffer.Width,
m_ControlBuffer.Height,
GraphicsUnit.Pixel)
m_BackGraphics.Flush()
' Now paint this to the screen
screenGraphics.DrawImageUnscaled(m_BackBuffer, 0, 0)
End If
End Sub
The problem is that for DropDown style a white EditControl appears on top of my drawing. Searching on other forums i received the idea of getting a handle of that control and maybe i could change the color.
I then found the WM_CTLCOLOREDIT which i think would help me in what i have to do. It says,
If an application processes this message, it must return the handle of a brush. The system uses the brush to paint the background of the edit control.
So what i tried was to catch that message on the WndProc of my ComboBox and alter result of the message (which as i understand is the return value for the WM_CTLCOLOREDIT) to be the pointer to the brush i'm creating.
<DllImport("gdi32.dll")>
Public Shared Function CreateSolidBrush(ByVal color As Integer) As IntPtr
End Function
Protected Overrides Sub WndProc(ByRef m As Message)
If (m.Msg = &H133) Then
Dim brush As IntPtr = CreateSolidBrush(RGB(255, 0, 0))
m.Result = brush
End If
MyBase.WndProc(m)
End Sub
I'm not sure how to use the WndProc and this code above still does not work.
Any help will be aprecciated.
EDIT:
After changing the WndProc,
Private hBrush As IntPtr = CreateSolidBrush(RGB(255, 0, 0))
Protected Overrides Sub WndProc(ByRef m As Message)
If (m.Msg = &H133) Then
m.Result = hBrush
Else
MyBase.WndProc(m)
End If
End Sub
It does paints the red rectangle except when i have the focus on the control. See Images below,
I feel so far and so close to the solution at the same time.
I have problems getting launching some shortcuts and getting their icon for some strange and unknown reason, using the following methods :
Public Shared Sub Launch(itemToLaunch As String)
Process.Start(itemToLaunch)
End Sub
Public Function GetShellIcon(ByVal path As String) As Icon
Dim info As SHFILEINFO = New SHFILEINFO()
Dim retval As IntPtr = SHGetFileInfo(path, 0, info, Marshal.SizeOf(info), SHGFI_ICON Or SHGFI_SMALLICON Or SHGFI_LARGEICON)
If retval = IntPtr.Zero Then
Return New Icon(GetType(Control), "Error.ico")
End If
Dim cargt() As Type = {GetType(IntPtr)}
Dim ci As ConstructorInfo = GetType(Icon).GetConstructor(BindingFlags.NonPublic Or BindingFlags.Instance, Nothing, cargt, Nothing)
Dim cargs() As Object = {info.IconHandle}
Dim icon As Icon = CType(ci.Invoke(cargs), Icon)
Return icon
End Function
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Auto)>
Private Structure SHFILEINFO
Public IconHandle As IntPtr
Public IconIndex As Integer
Public Attributes As UInteger
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=260)>
Public DisplayString As String
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=80)>
Public TypeName As String
End Structure
Private Declare Auto Function SHGetFileInfo Lib "Shell32.dll" (path As String, attributes As Integer, ByRef info As SHFILEINFO, infoSize As Integer, flags As Integer) As IntPtr
Public Const SHGFI_ICON = &H100
Public Const SHGFI_SMALLICON = &H1
Public Const SHGFI_LARGEICON = &H0 ' Large icon
These methods works well on almost any item, but sometimes they send me a System.ComponentModel.Win32Exception in System.dll when trying to execute a shortcut file, and on these same files, getting their icon.
It gives me the following message (given by Process.Start is called with a ProcessStartInfo parameter with ErrorDialog=True) :
This error is different than the one that is raised if the path to the .lnk file is not correct pointing to an non existing file :
As an example, you can reproduce this problem this way :
Locate on a Windows 7 install the following files :
C:\Program Files\DVD Maker\DVDMaker.exe (native with Windows 7)
C:\Program Files\WinRAR\WinRAR.exe (v5.0 64 bits, but I guess this will have the same effect with another version)
C:\Program Files\Windows NT\Accessories\wordpad.exe (native with Windows 7)
Copy each of them to the Desktop
With a right-click-drag, create 3 links shortcuts for each of these 3 files from their original location to the desktop. Renames these Shortcuts (for convenience) "[Filename] linkorig"
With a right-click-drag, create 3 links shortcuts for each of the 3 copied files from the Desktop to the desktop. Renames these Shortcuts (for convenience) "[Filename] linkcopy"
Create a Visual basic project, put 4 PictureBoxes onto a Form and name them :
ExeOrigPictureBox
ExeCopyPictureBox
LnkOrigPictureBox
LnkCopyPictureBox
And some Labels to help yourself.
Then copy/paste the following code into the Form code window :
Imports System.Reflection
Imports System.Runtime.InteropServices
Public Class Form1
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
Me.ExeOrigPictureBox.Tag = "C:\Program Files\WinRAR\WinRAR.exe"
Me.ExeCopyPictureBox.Tag = "C:\Users\Moi\Desktop\WinRAR.exe"
Me.LnkOrigPictureBox.Tag = "C:\Users\Moi\Desktop\WinRAR.exe linkorig.lnk"
Me.LnkCopyPictureBox.Tag = "C:\Users\Moi\Desktop\WinRAR.exe linkcopy.lnk"
Me.ExeOrigPictureBox.Image = GetShellIcon(Me.ExeOrigPictureBox.Tag).ToBitmap
Me.ExeCopyPictureBox.Image = GetShellIcon(Me.ExeCopyPictureBox.Tag).ToBitmap
Me.LnkOrigPictureBox.Image = GetShellIcon(Me.LnkOrigPictureBox.Tag).ToBitmap
Me.LnkCopyPictureBox.Image = GetShellIcon(Me.LnkCopyPictureBox.Tag).ToBitmap
End Sub
Private Sub ExeOrigPictureBox_Click(sender As Object, e As EventArgs) Handles ExeOrigPictureBox.Click, ExeCopyPictureBox.Click, LnkOrigPictureBox.Click, LnkCopyPictureBox.Click
Dim pBox As PictureBox = DirectCast(sender, PictureBox)
Dim pi As ProcessStartInfo = New ProcessStartInfo
pi.FileName = pBox.Tag
pi.ErrorDialog = True
Process.Start(pi)
End Sub
End Class
Module Shell32
Public Function GetShellIcon(ByVal path As String) As Icon
Dim info As SHFILEINFO = New SHFILEINFO()
Dim retval As IntPtr = SHGetFileInfo(path, 0, info, Marshal.SizeOf(info), SHGFI_ICON Or SHGFI_SMALLICON Or SHGFI_LARGEICON)
If retval = IntPtr.Zero Then
Return New Icon(GetType(Control), "Error.ico")
End If
Dim cargt() As Type = {GetType(IntPtr)}
Dim ci As ConstructorInfo = GetType(Icon).GetConstructor(BindingFlags.NonPublic Or BindingFlags.Instance, Nothing, cargt, Nothing)
Dim cargs() As Object = {info.IconHandle}
Dim icon As Icon = CType(ci.Invoke(cargs), Icon)
Return icon
End Function
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Auto)>
Private Structure SHFILEINFO
Public IconHandle As IntPtr
Public IconIndex As Integer
Public Attributes As UInteger
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=260)>
Public DisplayString As String
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=80)>
Public TypeName As String
End Structure
Private Declare Auto Function SHGetFileInfo Lib "Shell32.dll" (path As String, attributes As Integer, ByRef info As SHFILEINFO, infoSize As Integer, flags As Integer) As IntPtr
Public Const SHGFI_ICON = &H100
Public Const SHGFI_SMALLICON = &H1
Public Const SHGFI_LARGEICON = &H0 ' Large icon
End Module
Then execute.
You will obtain the following :
Clicking on any of the well displayed icons launches the WinRar application.
Clicking on the bad displayed icon displays this error :
Changing the value of Me.LnkOrigPictureBox.Tag with a wrong path like "C:\Users\Moi\Desktop\WinRARdontexistshere.exe linkorig.lnk" and doing the same thing displays another visual and error (as expected) :
This don't work neither with DVDMaker.exe
But everything is fine with wordpad.exe, icon and application launch.
(I've tested the case of the lower/uppercase to see if it interfers, but this is not the problem)
I've noticed the problem on some other apps without understanding the reasons of this, for example :
Paint .net
VirtualBox
CloneSpy
VirtualDub
and other standard Windows apps.
When copy/pasting the problematic file path C:\Users\Moi\Desktop\WinRAR.exe linkorig.lnk onto a Windows explorer title bar, the WinRAR.exe app is launched.
Of course same thing is I double-click the .lnk file.
It is also launched well when copy/pasted into a Windows-R command window.
And also launched if called by typing WinRAR.lnk from a command-line window being placed in the C:\Users\Moi\Desktop\ folder.
I'm running onto a Windows 7 64 bits. The app is compiled using Visual Studio Express 2015. I'm logged as administrator (the one and only default account created on the Windows install). Runing the compiled app "as an administrator" does not change anything.
I tried using some configurations such the following without success :
Dim info As ProcessStartInfo = New ProcessStartInfo(--- here the path ---)
info.CreateNoWindow = False
info.UseShellExecute = False
info.RedirectStandardError = True
info.RedirectStandardOutput = True
info.RedirectStandardInput = True
Dim whatever As Process = Process.Start(info)
How could I solve this launch problem, and the icon retrieval problem of these files ?
Woow... I found the answer by luck when I saw, making some tests with some examples found over the net, that the icon problem and the error message when trying to use the corresponding file was also present when using a standard OpenFileDialog. I suspected a bug in the .Net framework. And the solution was near this, and I still don't really understand its deep reasons.
The problem was the following :
The project was defined by default into the project settings to run with .Net Framework 4.5
I switched it to run with Framework 4
Runned the app : no more problem
I switched it back to run with Framework 4.5
No more problem at all.
I created NPCs that move that direction you're standing at the moment. If they touch something, they never will move again. I don't have a clue and already wasted like 6 hours searching the fault.
That is my Move-Method:
Overrides Sub Move()
Dim actorPosition As Vector2
Dim spieler As Actor
For Each obj As Actor In Actor.ActorList
If TypeOf obj Is Actor And obj.Alive And obj.ObjektTyp = "A"c Then
actorPosition = obj.position
spieler = obj
End If
Next
Dim difPos As Vector2 = position - actorPosition
normaldifpos = difPos
normaldifpos.Normalize()
If lastTimeAttack + intervallBetweenAttack1 < Game1.Game1Time Then
If difPos.Length < range Then
Select Case ObjektTyp
Case "Z"c
spieler.leben -= stärke
Case "H"c
For Each obj As Objekt In ObjList
If TypeOf obj Is Spells Then
If obj.ObjektTyp = "Z"c And obj.Alive = False Then
obj.position = position
obj.richtung = -normaldifpos
obj.senderE = Me
obj.stärke = stärke
obj.Alive = True
Exit For
End If
End If
Next
End Select
lastTimeAttack = Game1.Game1Time
End If
End If
If difPos.Length() < agroRange Then
If spieler IsNot Nothing And Not collide((normaldifpos + New Vector2(-4, -4) * speed)) Then
position = position - normaldifpos * speed
Else
End If
End If
End Sub
And this my collide method:
Public Overridable Function collide(vek As Vector2) As Boolean
Dim extrahitbox As Rectangle
extrahitbox = Hitbox
extrahitbox.X += vek.X
extrahitbox.Y += vek.Y
For Each obj As Objekt In Objekt.ObjList
If TypeOf obj Is Spells Or TypeOf obj Is Key Or TypeOf obj Is PowerUP Or TypeOf obj Is Coin Then
Else
If extrahitbox.Intersects(obj.Hitbox) Then
Return True
End If
End If
Next
For Each Act As Actor In Actor.ActorList
If Act IsNot Me Then
If extrahitbox.Intersects(Act.Hitbox) Then
Return True
Else
End If
End If
Next
If extrahitbox.X < 0 Then
Return True
ElseIf extrahitbox.Right > 1280 Then
Return True
ElseIf extrahitbox.Top < 0 Then
Return True
ElseIf extrahitbox.Bottom > 720 Then
Return True
End If
End Function
I would appreciate help!
From your example it looks object stuck because once when it collide with other object you are not doing any update to position. After determing collision you have to calculate how deep object is inside other object and move it back to previous position.
One way is after you determinate collision you simply negate velocity.
object.Position -= object.Velocity
object.Velocity = new vector2(0,0)
Other way is more accurate as velocity remain same and if your origin is on top-left position. It collision happened, it will position your object right next to other object depend from where collision happened.
If obj.Intersect(otherObj) Then
Dim newPos as new vector2d = obj.Position
if (obj.velocity.x>0) then newPos.x = otherObj.Left - obj.width
if (obj.velocity.x<0) then newPos.x = otherObj.right
obj.Position = newPos
End If
So basicly goes like this
put position to temp varialbe
check collision
if collision happened set original to temp
draw
I am facing an issue with Dual Monitors in VB6, Please help me to find out the any one the following.
Either get the Dual Monitor is connected or not?
Get the Full Width of Screen (Primary Screen + Extended Monitor Screen)
Currently I am using the existing Properties available in VB6.
Screen.Width & Screen.Height which gives me only the Primary Monitor's Width and Height.
You'll have to use Windows API to determine the virtual screen size for a multi-monitor setup:
Private Const SM_CXVIRTUALSCREEN = 78
Private Const SM_CYVIRTUALSCREEN = 79
Private Const SM_CMONITORS = 80
Private Const SM_SAMEDISPLAYFORMAT = 81
Private Declare Function GetSystemMetrics Lib "user32" ( _
ByVal nIndex As Long) As Long
Public Property Get VirtualScreenWidth() As Long
VirtualScreenWidth = GetSystemMetrics(SM_CXVIRTUALSCREEN)
End Property
Public Property Get VirtualScreenHeight() As Long
VirtualScreenHeight = GetSystemMetrics(SM_CYVIRTUALSCREEN)
End Property
Public Property Get DisplayMonitorCount() As Long
DisplayMonitorCount = GetSystemMetrics(SM_CMONITORS)
End Property
Public Property Get AllMonitorsSame() As Long
AllMonitorsSame = GetSystemMetrics(SM_SAMEDISPLAYFORMAT)
End Property
From vbAccelerator.com
Im a complete novice to the "best practices" etc of writing in any code.
I tend to just write it an if it works, why fix it.
Well, this way of working is landing me in some hot water. I am writing a simple windows service to server a single webpage. (This service will be incorperated in to another project which monitors the services and some folders on a group of servers.)
My problem is that whenever a request is recieved, the memory usage jumps up by a few K per request and keeps qoing up on every request.
Now ive found that by putting GC.Collect in the mix it stops at a certain number but im sure its not meant to be used this way. I was wondering if i am missing something or not doing something i should to free up memory.
Here is the code:
Public Class SimpleWebService : Inherits ServiceBase
'Set the values for the different event log types.
Public Const EVENT_ERROR As Integer = 1
Public Const EVENT_WARNING As Integer = 2
Public Const EVENT_INFORMATION As Integer = 4
Public listenerThread As Thread
Dim HTTPListner As HttpListener
Dim blnKeepAlive As Boolean = True
Shared Sub Main()
Dim ServicesToRun As ServiceBase()
ServicesToRun = New ServiceBase() {New SimpleWebService()}
ServiceBase.Run(ServicesToRun)
End Sub
Protected Overrides Sub OnStart(ByVal args As String())
If Not HttpListener.IsSupported Then
CreateEventLogEntry("Windows XP SP2, Server 2003, or higher is required to " & "use the HttpListener class.")
Me.Stop()
End If
Try
listenerThread = New Thread(AddressOf ListenForConnections)
listenerThread.Start()
Catch ex As Exception
CreateEventLogEntry(ex.Message)
End Try
End Sub
Protected Overrides Sub OnStop()
blnKeepAlive = False
End Sub
Private Sub CreateEventLogEntry(ByRef strEventContent As String)
Dim sSource As String
Dim sLog As String
sSource = "Service1"
sLog = "Application"
If Not EventLog.SourceExists(sSource) Then
EventLog.CreateEventSource(sSource, sLog)
End If
Dim ELog As New EventLog(sLog, ".", sSource)
ELog.WriteEntry(strEventContent)
End Sub
Public Sub ListenForConnections()
HTTPListner = New HttpListener
HTTPListner.Prefixes.Add("http://*:1986/")
HTTPListner.Start()
Do While blnKeepAlive
Dim ctx As HttpListenerContext = HTTPListner.GetContext()
Dim HandlerThread As Thread = New Thread(AddressOf ProcessRequest)
HandlerThread.Start(ctx)
HandlerThread = Nothing
Loop
HTTPListner.Stop()
End Sub
Private Sub ProcessRequest(ByVal ctx As HttpListenerContext)
Dim sb As StringBuilder = New StringBuilder
sb.Append("<html><body><h1>Test My Service</h1>")
sb.Append("</body></html>")
Dim buffer() As Byte = Encoding.UTF8.GetBytes(sb.ToString)
ctx.Response.ContentLength64 = buffer.Length
ctx.Response.OutputStream.Write(buffer, 0, buffer.Length)
ctx.Response.OutputStream.Close()
ctx.Response.Close()
sb = Nothing
buffer = Nothing
ctx = Nothing
'This line seems to keep the mem leak down
'System.GC.Collect()
End Sub
End Class
Please feel free to critisise and tear the code apart but please BE KIND. I have admitted I dont tend to follow the best practice when it comes to coding.
You are right, you should not be doing this. Remove the Collect() call and let it run for a week. Any decent .NET book will talk about how the garbage collector works and how it does not immediately release memory when you set an object to Nothing. It doesn't kick in until you've consumed somewhere between 2 and 8 megabytes. This is not a leak, merely effective use of a plentiful resource.
You use a new thread for each individual connection, that's pretty expensive and scales very poorly when you get a lot of connections. Consider using ThreadPool.QueueUserWorkItem instead. Threadpool threads are very cheap and their allocation and execution is well controlled by the threadpool manager.