Results 1 to 2 of 2

Thread: DrawingControls for VB6: Shape and Line controls replacement with anti-aliasing

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,995

    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.

  2. #2
    Fanatic Member
    Join Date
    Feb 2017
    Posts
    858

    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
  •  



Click Here to Expand Forum to Full Width