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>
so i have developed this game in visual basic 6.0,a maze game in which i want my mouse cursor to be set on the start label on the form with maze and once the form is activated and gets focus!
Dim label1 As New label=Start
I've done similar tasks in the past using the Windows API. In the following example, a Form contains a Label named 'Label1' that is positioned somewhere on the Form. When the Form is Activated, the cursor will be centered on 'Label1':
Option Explicit
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Form_Activate()
Dim wr As RECT
Dim tb As Long
Dim le As Long
Dim x As Long
Dim y As Long
'calculate coordinates
Call GetWindowRect(Me.hwnd, wr) 'window coordinates
tb = (Me.Height - Me.ScaleHeight) - (Me.Width - Me.ScaleWidth) / 2 'title bar height
le = (Me.Width - Me.ScaleWidth) * 0.5 'left edge of client area
'calculate center of label
x = wr.Left + ScaleX(le + Label1.Left + Label1.Width * 0.5, Me.ScaleMode, vbPixels)
y = wr.Top + ScaleY(tb + Label1.Top + Label1.Height * 0.5, Me.ScaleMode, vbPixels)
SetCursorPos x, y
End Sub
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.
I am developing a game using VB6.0, I want to generate randomly moving shapes (circles, squares, rectangles, ovals, etc.) with different colors in the background of form. I am using timers and shapes to achieve this.my contribution is furnished below.
Private Sub Timer1_Timer()
For i = 0 To 20
s_left = Round(Rnd * 20050)
s_top = Round(Rnd * 860)
shape(i).Left = s_left
shape(i).Top = s_top
shape(i).Visible = True
Next i
End Sub
Now the problem is that, I can use only one shape and one color, is there any possibility to select a random color and shape within this Timer1_Timer()?
' the function that generate random colors
Public Function RandomRGBColor() As Long
RandomRGBColor = RGB( _
Int(Rnd() * 256), _
Int(Rnd() * 256), _
Int(Rnd() * 256))
End Function
your code should be changed as follows to get the requested result
dim shape_style as integer
Private Sub Timer1_Timer()
For i = 0 To 20
shape_style= Round(Rnd * 5)
s_left = Round(Rnd * 20050)
s_top = Round(Rnd * 860)
shape(i).Left = s_left
shape(i).Top = s_top
shape(i).Visible = True
shape(i).fillcolor=RandomRGBColor()
shape(i).shape=shape_style
Next i
End Sub
i have used loads of websites for this but none worked so i am hoping i could get a correct answer
i have tried this could any one tell me whats wrong with it:
Private sub Picture1_mouseDown
x = picture1.currentx
y = picture1.currenty
End sub
Private sub Picture1_MouseMove
If button = 1 then
line (picture1.currentx,picture1.currenty)-(x,y), _
QBColor(0)
End if
End sub
i have cut the Private sub Picture1_MouseMove,Mousedown() bits off because i am in a rush to finish
This one will draw a line, only slightly different from kurniliya's solution which draws points
Option Explicit
Private lastX As Single
Private lastY As Single
Private Sub Form_Load()
' no need to set this every time we move the mouse inside Picture1
Picture1.DrawWidth = 5
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Picture1.Line (lastX, lastY)-(X, Y), vbBlue
End If
lastX = X
lastY = Y
End Sub
You draw a line on PictureBox control using its Line method:
Sub Line(Flags As Integer, X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Color As Long)
Member of VB.PictureBox
Draws lines and rectangles on an object.
There isn't much to say about it, and it has already been covered in How do you draw a line dynamically in vb6?
You seem to have trouble with writing event handlers though. If you don't know/remember the signature, IDE is always there to assist. Check out Assigning Code to a Control to Respond to an Event in VB6 tutorial.
There is the code to help you get started with drawing. Picture1 is PictureBox control. Blue line will be drawn when you move your mouse over the picture box holding left mouse button down.
Option Explicit
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Picture1.DrawWidth = 5
Picture1.Line (X, Y)-(X, Y), vbBlue
End If
End Sub