-
Mar 3rd, 2023, 04:26 PM
#1
DrawingControls for VB6: Shape and Line controls replacement with anti-aliasing
This is a further development of the ShapeEx control.
In this case, it is in an ocx project and has been added the companion control LineEx, that is a Line control replacement.
The main advantage is the anti-aliasing, that means better quality for the figures.
A second advantage is that there are more shapes and the LineEx control is able to draw arrows.
A third advantage is more properties that means more features, more versatility. In the test form you can check all the properties of the ShapeEx control.
Download from GitHub.
Screen shots:
If you want, you should be able to replace the old Shape and Line controls by editing the source code files (*.frm, etc.).
Changing VB.Shape to DrawingCtrls.ShapeEx and VB.Line to DrawingCtrls.LineEx
But you first need to reference the OCX in the project first.
Of course, always make a backup before such an operation.
Note: this version of the ShapeEx control includes the possibility of filling the shapes with a texture pattern.
For doing so, set the FillStyle property to seFSTexture and load the image for the texture in the FillTexture property.
Last edited by Eduardo-; Mar 3rd, 2023 at 07:01 PM.
-
Feb 19th, 2024, 11:23 AM
#2
Fanatic Member
Re: DrawingControls for VB6: Shape and Line controls replacement with anti-aliasing
Elroy: This is not a control but what I've used for years. Have to reference GDI MoveToEx, LineTo
and REM kDEBUGON and DoError.
Code:
Public Sub DrawLineDashWide(objPBox As PictureBox, ByVal X1 As _
Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal _
Y2 As Single, ByVal dash_length As Single, ByVal _
skip_length As Single, ByVal draw_width As Integer)
'Draw Wide Dashed Lines
#If kDEBUGON Then
Debug.Print "Begin DrawLineDashWide"
#End If
On Error GoTo Error_DrawLineDashWide
'-----------------
Dim i As Integer
Dim i_max As Integer
Dim dash_dx As Single
Dim dash_dy As Single
Dim skip_dx As Single
Dim skip_dy As Single
Dim Length As Single
Dim X As Single
Dim Y As Single
'API
Dim ptPoint As POINTAPI
Dim dl As Long
'*******
'STARTUP
'*******
objPBox.DrawWidth = draw_width
' Get vectors in the desired direction
' with the right length.
skip_dx = X2 - X1
If skip_dx = 0 Then Exit Sub
skip_dy = Y2 - Y1
If skip_dy = 0 Then Exit Sub
Length = Sqr(skip_dx * skip_dx + skip_dy * skip_dy)
dash_dx = skip_dx / Length * dash_length
dash_dy = skip_dy / Length * dash_length
skip_dx = skip_dx / Length * skip_length
skip_dy = skip_dy / Length * skip_length
'*******
'MAIN
'*******
X = X1
Y = Y1
i_max = Int(Length / (dash_length + skip_length))
For i = 1 To i_max
dl = MoveToEx(objPBox.hdc, X, Y, ptPoint)
dl = LineTo(objPBox.hdc, X + dash_dx, Y + dash_dy)
' objPBox.Line (X, Y)-Step(dash_dx, dash_dy) 'Orig VB
X = X + dash_dx + skip_dx
Y = Y + dash_dy + skip_dy
Next i
' See how much line is undrawn.
Length = Length - i_max * (dash_length + skip_length)
If Length > dash_length Then
dl = MoveToEx(objPBox.hdc, X, Y, ptPoint)
dl = LineTo(objPBox.hdc, X + dash_dx, Y + dash_dy)
' objPBox.Line (X, Y)-Step(dash_dx, dash_dy)
Else
dl = MoveToEx(objPBox.hdc, X, Y, ptPoint)
dl = LineTo(objPBox.hdc, X2, Y2)
' objPBox.Line (X, Y)-(X2, Y2)
End If
'*******
'WRAPUP
'*******
#If kDEBUGON Then
Debug.Print "End DrawLineDashWide"
#End If
Exit Sub
Error_DrawLineDashWide:
With TError
.Type = ERR_CRITICAL
.Src = mstrModule & "DrawLineDashWide"
.Action = MsgAndLog
End With
Call DoError
End Sub
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|