How can I show the title bar of a form only if the mouse is at the top of the form like on Windows Media Player 9? I already implemented this but it is awkward and the controls/elements and the window moves down a little if I use my code while WMP 9/10's window stays at the current position.
Private Sub Timer1_Timer()
Dim pos as coord 'my type, has x as long and y as long
GetCursorPos pos
If pos.y * 15 > Me.Top - 500 And pos.y * 15 < Me.Top + 300 And pos.x * 15 > Me.Left And pos.x * 15 < Me.Left + Me.Width Then
Me.BorderStyle = 2
Me.Caption = Me.Caption
Else
Me.BorderStyle = 0
Me.Caption = Me.Caption
End If
End Sub
Related
The title of this question can also be, "The alpha values in the WIA.Vector object don't work."
I'm trying to render an ellipse on a transparent background using my own discovered algorithm, and then save the resulting image into a .bmp file. The ellipse is rasterized properly with a black stroke, but my program does not make the background of the image transparent.
As I examined the program, it turned out that when I retrieve an ImageFile object from the Vector object, its IsAlphaPixelFormat property is set to false, indicating that the alpha channel is not available in the output image. Even though I set the alpha value of the background color to zero in the vector, the ImageFile object generates an opaque white background.
So could you please help me make the background transparent? Here is my VBScript code, which must be run with cscript.exe.
Note: This program requires Windows Image Acquisition (WIA) library v2.0 in order to create a .bmp image file. So it must be run on Window Vista or higher.
Const width = 500
Const height = 500
color_transparent = GetARGB(0, 255, 255, 255) ' This does not work, renders as opaque white
color_black = GetARGB(255, 0, 0, 0)
PI = 4 * Atn(1)
Dim oVector, oImageFile
Set oVector = NewBlankPage()
rasterizeEllipse oVector, 220, 120, 200, 100, color_black
Set oImageFile = oVector.ImageFile(width, height)
oImageFile.SaveFile "ellipse.bmp"
WScript.StdOut.WriteLine "Done! Press Enter to quit."
WScript.StdIn.SkipLine
Function NewBlankPage()
Dim oVector, i
WScript.StdOut.WriteLine "Creating a new blank page... Please wait..."
Set oVector = CreateObject("WIA.Vector")
For i = 1 To (width * height)
oVector.Add color_transparent
Next
Set NewBlankPage = oVector
End Function
Function getPointOnEllipse(cx, cy, rx, ry, d)
Dim theta
theta = d * Sqr(2 / (rx * rx + ry * ry))
' theta = 2 * PI * d / getEllipsePerimeter(rx, ry)
Dim point(1)
point(0) = Fix(cx + Cos(theta) * rx)
point(1) = Fix(cy - Sin(theta) * ry)
getPointOnEllipse = point
End Function
Function getEllipsePerimeter(rx, ry)
getEllipsePerimeter = Fix(PI * Sqr(2 * (rx * rx + ry * ry)))
End Function
Sub SetPixel(oVector, x, y, color)
x = x + 1
y = y + 1
If x > width Or x < 1 Or y > height Or y < 1 Then
Exit Sub
End If
oVector(x + (y - 1) * width) = color
End Sub
Sub rasterizeEllipse(oVector, cx, cy, rx, ry, color)
Dim perimeter, i
WScript.StdOut.WriteLine "Rendering ellipse..."
perimeter = getEllipsePerimeter(rx, ry)
For i = 0 To (perimeter - 1)
Dim point
point = getPointOnEllipse(cx, cy, rx, ry, i)
SetPixel oVector, point(0), point(1), color
Next
End Sub
' These functions are taken from examples in the documentation
Function Get1ByteHex(val)
Dim s
s = Hex(val)
Do While Len(s) < 2
s = "0" & s
Loop
Get1ByteHex = Right(s, 2)
End Function
Function GetARGB(a, r, g, b)
Dim s
s = "&h" & Get1ByteHex(a) & Get1ByteHex(r) & Get1ByteHex(g) & Get1ByteHex(b)
GetARGB = CLng(s)
End Function
After running the code, you can test the transparency of the output image using this simple HTA:
<html>
<head>
<title>Test</title>
</head>
<body bgcolor="blue">
<img src="ellipse.bmp">
</body>
</html>
And you will see that a white box is displayed behind the ellipse, which indicates non-transparent background.
This can be done by using the ARGB filter to change all white pixels to transparent and saving the image as a PNG file. Unfortunately, this means iterating through every pixel, so your script will take twice as long to run. I could not find a way to create the initial image with transparency. See here for info regarding the performance issue. Here's the revised script:
Const wiaFormatPNG = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
Const width = 500
Const height = 500
color_white = GetARGB(255, 255, 255, 255)
color_transparent = GetARGB(0, 255, 255, 255)
color_black = GetARGB(255, 0, 0, 0)
PI = 4 * Atn(1)
Dim oVector, oImageFile
Set oVector = NewBlankPage()
rasterizeEllipse oVector, 220, 120, 200, 100, color_black
Set oImageFile = oVector.ImageFile(width, height)
Set IP = CreateObject("WIA.ImageProcess")
IP.Filters.Add IP.FilterInfos("ARGB").FilterID
Set oVector = oImageFile.ARGBData
Wscript.StdOut.WriteLine "Changing white pixels to transparent... Please wait..."
For i = 1 To oVector.Count
If oVector.Item(i) = color_white Then oVector.Item(i) = color_transparent
Next
IP.Filters(1).Properties("ARGBData").Value = oVector
IP.Filters.Add IP.FilterInfos("Convert").FilterID
IP.Filters(2).Properties("FormatID").Value = wiaFormatPNG
Set oImageFile = IP.Apply(oImageFile)
oImageFile.SaveFile "ellipse.png"
Wscript.StdOut.WriteLine "Done! Press Enter to quit."
Wscript.StdIn.SkipLine
Function NewBlankPage()
Dim oVector, i
Wscript.StdOut.WriteLine "Creating a new blank page... Please wait..."
Set oVector = CreateObject("WIA.Vector")
For i = 1 To (width * height)
oVector.Add color_white
Next
Set NewBlankPage = oVector
End Function
Function getPointOnEllipse(cx, cy, rx, ry, d)
Dim theta
theta = d * Sqr(2 / (rx * rx + ry * ry))
' theta = 2 * PI * d / getEllipsePerimeter(rx, ry)
Dim point(1)
point(0) = Fix(cx + Cos(theta) * rx)
point(1) = Fix(cy - Sin(theta) * ry)
getPointOnEllipse = point
End Function
Function getEllipsePerimeter(rx, ry)
getEllipsePerimeter = Fix(PI * Sqr(2 * (rx * rx + ry * ry)))
End Function
Sub SetPixel(oVector, x, y, color)
x = x + 1
y = y + 1
If x > width Or x < 1 Or y > height Or y < 1 Then
Exit Sub
End If
oVector(x + (y - 1) * width) = color
End Sub
Sub rasterizeEllipse(oVector, cx, cy, rx, ry, color)
Dim perimeter, i
Wscript.StdOut.WriteLine "Rendering ellipse..."
perimeter = getEllipsePerimeter(rx, ry)
For i = 0 To (perimeter - 1)
Dim point
point = getPointOnEllipse(cx, cy, rx, ry, i)
SetPixel oVector, point(0), point(1), color
Next
End Sub
' These functions are taken from examples in the documentation
Function Get1ByteHex(val)
Dim s
s = Hex(val)
Do While Len(s) < 2
s = "0" & s
Loop
Get1ByteHex = Right(s, 2)
End Function
Function GetARGB(a, r, g, b)
Dim s
s = "&h" & Get1ByteHex(a) & Get1ByteHex(r) & Get1ByteHex(g) & Get1ByteHex(b)
GetARGB = CLng(s)
End Function
Note: If you only need an ellipse in your HTA, it can be done instantly with CSS:
<!DOCTYPE html>
<html>
<head>
<title>Test</title>
<meta http-equiv="X-UA-Compatible" content="IE=9">
<style>
.ellipseDiv
{
height:200px;
width:400px;
border: 1px solid #005;
border-radius:200px / 100px;
}
</style>
</head>
<body bgcolor="blue">
<div class=ellipseDiv>
</div>
</body>
</html>
I have a circle that is drawn on the window, how can I define its boundaries ? So far, I can place it in an invisible rectangle and so I detect the mouse, but this is not what I want
CIRCLE_STEP = 10
def draw_circle(cx,cy,r,color)
0.step(360, CIRCLE_STEP) do |a1|
a2 = a1 + CIRCLE_STEP
$window.draw_line cx + Gosu.offset_x(a1, r), cy + Gosu.offset_y(a1, r), color, cx + Gosu.offset_x(a2, r), cy + Gosu.offset_y(a2, r), color, 10
end
end
def update
if mouse_over_button($window.mouse_x, $window.mouse_y, 180)
#color = Gosu::Color::GREEN
else
#color = Gosu::Color.argb(255, 240, 232, 196)
end
end
def mouse_over_button(mouse_x, mouse_y, shift)
mouse_x.between?(get_rect_width, get_rect_width + shift) && mouse_y.between?(get_rect_height, get_rect_height + shift)
end
def get_rect_width()
$window.width / 2
end
def get_rect_height()
$window.height / 2 + 200
end
Is there any other more efficient way ?
Use the Center of the circle's screen position, then take the mouse's screen position. Then offset by the circles radius.
Gosu::Window#mouse_
my = Gosu::Window#mouse_x
mx = Gosu::Window#mouse_y
if (my - circle_y).abs + (mx - circle_x).abs < circle_radius
# mouse is over circle
end
In my application I have two picture boxes. Picture1 is aligned to bottom. When I press the mouse button and move the Picture2, the height of Picture1 will change accordingly. Its working fine.
My problem is when I resize the form Picture1 and Picture2 are in different position. Picture2 is not exactly in the top position of Picture1.
Private Sub Form_Resize()
Picture2.Width = Me.ScaleWidth
Picture2.Top = Picture1.Height + Picture1.Top
End Sub
Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Screen.MousePointer = 7
If Button = 1 Then
Picture2.Top = Picture2.Top + (Y)
Picture1.Height = Me.Height - Picture2.Top - 720
End If
End Sub
I am not sure what are you trying to accomplish. It seems to me that Picture1
is aligned to top, not bottom.
Anyway. Did you mean this?
Private Sub Form_Resize()
Picture2.Width = ScaleWidth
Picture2.Top = Picture1.Top + Picture1.Height
End Sub
Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Screen.MousePointer = 7
If Button = 1 Then
Picture2.Top = Picture2.Top + (Y)
Picture1.Height = Picture2.Top
End If
End Sub
The picture boxes should stay in the same position wheather you resize the form or not. As #ota milink said, I do not know what you are truly one to accomplish.
lblRoom is control array of labels and brdrRoom is control array of shapes, On double click over each label, we can drag it with mouse. When one label move slowly over others there is no problem, it moves smooth, but when mouse move fast and when reach on center of other labels it gets moves and selected label goes stationary.
Code segment for MouseMove is given as:
Private Sub lblRoom_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SelectedItemIndex = Index
XPos = lblRoom(SelectedItemIndex).Left + X
YPos = lblRoom(SelectedItemIndex).Top + Y
If DragItem = True Then
lblRoom(SelectedItemIndex).Left = XPos - lblRoom(SelectedItemIndex).Width / 2
lblRoom(SelectedItemIndex).Top = YPos - lblRoom(SelectedItemIndex).Height / 2
brdrRoom(SelectedItemIndex).Left = XPos - brdrRoom(SelectedItemIndex).Width / 2
brdrRoom(SelectedItemIndex).Top = YPos - brdrRoom(SelectedItemIndex).Height / 2
End If
End Sub
What is the problem ? Help me :)
When you move overtop another label, it's getting MouseMove() events as well and so your procedure is presumably switching the SelectedItemIndex between your two labels.
To fix this, you should ignore mouse events from other labels besides the one you're dragging. For example:
Private m_intDragIndex As Long
Private Sub lblRoom_DblClick(Index As Integer)
m_intDragIndex = Index
End Sub
Private Sub lblRoom_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
' Only process events from the label that was double-clicked...
If Index <> m_intDragIndex Then Exit Sub
...
End Sub
You haven't said when the drag should stop, but whatever you're doing to end the drag, make sure to set m_intDragIndex = -1 or some other "invalid" value.
How i can to Draw Original diameter in form, with Pset method?
i want to draw a line like this : see image
thanks.
Open a new vb project (Standard Executable) and copy/paste this code.
Option Explicit
Private Sub Form_Load()
Me.AutoRedraw = True
Me.ScaleMode = vbPixels
End Sub
Private Sub DrawLine()
Dim i As Single
Dim Angle As Single
Cls
If Me.ScaleHeight = 0 Then
Exit Sub
End If
If Me.WindowState = vbMinimized Then
Exit Sub
End If
Angle = Atn(Me.ScaleWidth / Me.ScaleHeight)
For i = 0 To Sqr(Me.ScaleWidth * Me.ScaleWidth + Me.ScaleHeight * Me.ScaleHeight)
PSet (i * Sin(Angle), i * Cos(Angle))
Next
End Sub
Private Sub Form_Resize()
Call DrawLine
End Sub
Private Sub circleRoutine(aX As Single, aY As Single, Radius As Single, Steps As Single)
Dim currAngleX As Single
Dim i As Integer
aX = aX - Radius * 1 / Steps
For currAngleX = 0 To Rad(360) Step Steps
aX = aX + Radius * Sin(currAngleX)
aY = aY + Radius * Cos(currAngleX)
Me.PSet (aX, aY)
Next currAngleX
End Sub
Private Sub DrawCircle(ByVal X As Single, ByVal Y As Single, ByVal Diameter As Single, ByVal PointsToDraw As Long)
Dim Angle As Single
For Angle = 0 To 2 * 3.14159 Step (2 * 3.14159) / PointsToDraw
Me.PSet (X + Diameter * Sin(Angle) / 2, Y + Diameter * Cos(Angle) / 2), vbRed
Next
End Sub
You should be aware that there is a Circle function that you can use instead. The code above could be replaced with:
Me.Circle (X,Y), Diameter / 2, vbRed
PSet is a relatively slow way to draw graphics, especially when there is already a built-in function you can use instead.