VB icon

______LINE super

Email
Submitted on: 1/28/2015 12:12:00 AM
By: pietro ing. cecchi (from psc cd)  
Level: Advanced
User Rating: By 3 Users
Compatibility: VB 6.0
Views: 1904
 
     SUPERLINE - Awesome! Draws even thick lines in dashes and dots! SEE SCREENSHOT Keywords: graphics, graph, shape, rectangle, ellipse, polyline, polygon, border, borderwidth, solid, dash, dot, dashdot, dashdotdot, drawwidth, drawstyle, drawmode, gdi

 

Windows API/Global Declarations:

Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
'**************************************
'Windows API/Global Declarations for :______LINE super
'**************************************
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
'**************************************
' Name: ______LINE super
' Description:SUPERLINE - Awesome! Draws even thick lines in dashes and dots!
SEE SCREENSHOT
Keywords: graphics, graph, shape, rectangle, ellipse, polyline, polygon, border, borderwidth,
solid, dash, dot, dashdot, dashdotdot, drawwidth, drawstyle, drawmode, gdi
' By: pietro ing. cecchi (from psc cd)
'
' Assumes:See Line method for Form or Picture.
SUPERLINE is just the same, BUT thick lines
can be drawn with dashes and dots (Line method can't).
'
' Side Effects:no side effect possible, safest code
'**************************************

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+ +
'+ Published on Planet-Source-Code the 11th of september 2002 +
'+ +
'+ by Pietro Cecchi, pietrocecchi@inwind.it+
'+ +
'+ SUPERLINE - Awesome! Draws even thick lines in dashes and dots! +
'+ Function DrawLine(ByVal isHwnd As Long,+
'+ByVal isX1 As Long, ByVal isY1 As Long, +
'+ByVal isX2 As Long, ByVal isY2 As Long, +
'+ByVal isColor As Long,+
'+ByVal isStyle As PenStyle,+
'+ByVal isWidth As Long)+
'+ Enjoy!+
'+ +
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Option Explicit
Private Type POINTAPI
 x As Long
 y As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Pen Styles
Public Enum PenStyle
 PS_SOLID = 0 'vbBSSolid-1
 PS_DASH = 1 'vbBSDash-1
 PS_DOT = 2 'vbBSDot-1
 PS_DASHDOT = 3 'vbBSDashDot-1
 PS_DASHDOTDOT = 4 'vbBSDashDotDot-1
End Enum
Public Function SUPERLINE(ByVal isHwnd As Long, ByVal isX1 As Long, ByVal isY1 As Long, ByVal isX2 As Long, ByVal isY2 As Long, ByVal isColor As Long, ByVal isStyle As PenStyle, ByVal isWidth As Long) As Integer
 Dim ishDC, hpen, hpenOLD, isPoint As POINTAPI
 Dim dashlen, dotlen, dashdotintervallen, linelen
 Dim a, segmentlen, segmenthowmany, segmentoflineX, intervallenonlineX, segmentoflineY, intervallenonlineY
 Dim isarc, istn, dashprojectionX, dashprojectionY
 Dim dotprojectionX, dotprojectionY
 Dim dashdotintervalprojectionX, dashdotintervalprojectionY
 Dim minlength As Integer
 Dim commandstring As String
 Dim movetoX, movetoY, movetoXsave, movetoYsave
 
Dim isTMP As Single
If isY1 > isY2 Then
'shaffle end points
isTMP = isX1
isX1 = isX2
isX2 = isTMP
isTMP = isY1
isY1 = isY2
isY2 = isTMP
End If
 'INPUT CONTROL
 Select Case isWidth
 Case 1 To 20
 Case Else
 isWidth = 1
 End Select
 
 ishDC = GetDC(isHwnd)
 hpen = CreatePen(PS_SOLID, isWidth, isColor) 'note: always solid
 hpenOLD = SelectObject(ishDC, hpen)
 
 dashlen = 4 * isWidth
 dotlen = 1 'note: dot len always 1
 dashdotintervallen = 2 * isWidth
 Select Case isStyle
 Case PS_SOLID
 MoveToEx ishDC, isX1, isY1, isPoint
 LineTo ishDC, isX2, isY2
 SUPERLINE = 1 'OK
 Case PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT
 Select Case isStyle
 Case PS_DASH
 '- -
 minlength = 2 * dashlen + 1 * dashdotintervallen
 commandstring = "- "
 segmentlen = 1 * dashlen + 1 * dashdotintervallen
 Case PS_DOT
 '. .
 minlength = 2 * dotlen + 1 * dashdotintervallen
 commandstring = ". "
 segmentlen = 1 * dotlen + 1 * dashdotintervallen
 Case PS_DASHDOT
 '- . -
 minlength = 2 * dashlen + 1 * dotlen + 2 * dashdotintervallen
 commandstring = "- . "
 segmentlen = 1 * dashlen + 1 * dotlen + 2 * dashdotintervallen
 Case PS_DASHDOTDOT
 '- . . -
 minlength = 2 * dashlen + 2 * dotlen + 3 * dashdotintervallen
 commandstring = "- . . "
 segmentlen = 1 * dashlen + 2 * dotlen + 3 * dashdotintervallen
 End Select
 linelen = CInt(Sqr((isX2 - isX1) ^ 2 + (isY2 - isY1) ^ 2))
 Select Case linelen
 Case Is <= minlength 'shorter, draw solid line
 MoveToEx ishDC, isX1, isY1, isPoint
 LineTo ishDC, isX2, isY2
 SUPERLINE = 0 'line too short, dot and dashes can't be drawn
 Case Else 'longer, can draw dashed/dotted line
 SUPERLINE = 1 'OK
 segmenthowmany = linelen \ segmentlen
 segmentoflineX = (isX2 - isX1) \ segmenthowmany
 segmentoflineY = (isY2 - isY1) \ segmenthowmany
 If (isY2 - isY1) <> 0 Then 'avoid division by 0
istn = (isX2 - isX1) / (isY2 - isY1)
isarc = Atn(istn)
 Else 'pi/2
isarc = Atn(1) * 2 * Sgn(isX2 - isX1)
 End If
 dashprojectionX = dashlen * Sin(isarc)
 dashprojectionY = dashlen * Cos(isarc)
 dotprojectionX = dotlen * Sin(isarc)
 dotprojectionY = dotlen * Cos(isarc)
 dashdotintervalprojectionX = dashdotintervallen * Sin(isarc)
 dashdotintervalprojectionY = dashdotintervallen * Cos(isarc)
 For a = 1 To segmenthowmany
DoEvents
Select Case isStyle
Case PS_DASH
movetoX = isX1 + segmentoflineX * (a - 1)
movetoY = isY1 + segmentoflineY * (a - 1)
MoveToEx ishDC, movetoX, movetoY, isPoint
LineTo ishDC, movetoX + dashprojectionX, movetoY + dashprojectionY
Case PS_DOT
movetoX = isX1 + segmentoflineX * (a - 1)
movetoY = isY1 + segmentoflineY * (a - 1)
MoveToEx ishDC, movetoX, movetoY, isPoint
LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY
Case PS_DASHDOT
'dash
movetoX = isX1 + segmentoflineX * (a - 1)
movetoY = isY1 + segmentoflineY * (a - 1)
MoveToEx ishDC, movetoX, movetoY, isPoint
LineTo ishDC, movetoX + dashprojectionX, movetoY + dashprojectionY
'move to middle of left space of segment
movetoX = movetoX + dashprojectionX + (segmentoflineX - dashprojectionX) / 2
movetoY = movetoY + dashprojectionY + (segmentoflineY - dashprojectionY) / 2
MoveToEx ishDC, movetoX, movetoY, isPoint
'dot is always 1 pixel
dotprojectionX = 1
dotprojectionY = 1
'dot
LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY
Case PS_DASHDOTDOT
'dash
movetoX = isX1 + segmentoflineX * (a - 1)
movetoY = isY1 + segmentoflineY * (a - 1)
MoveToEx ishDC, movetoX, movetoY, isPoint
LineTo ishDC, movetoX + dashprojectionX, movetoY + dashprojectionY
 
movetoXsave = movetoX
movetoYsave = movetoY
'move to 1/3 of left space of segment
movetoX = movetoX + dashprojectionX + (segmentoflineX - dashprojectionX) / 3
movetoY = movetoY + dashprojectionY + (segmentoflineY - dashprojectionY) / 3
MoveToEx ishDC, movetoX, movetoY, isPoint
'dot is always 1 pixel
dotprojectionX = 1
dotprojectionY = 1
'dot
LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY
'move to 2/3 of left space of segment
movetoX = movetoXsave + dashprojectionX + (segmentoflineX - dashprojectionX) / 3 * 2
movetoY = movetoYsave + dashprojectionY + (segmentoflineY - dashprojectionY) / 3 * 2
MoveToEx ishDC, movetoX, movetoY, isPoint
'dot
LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY
End Select
 Next
 
 
 End Select
 End Select
 
 
 SelectObject ishDC, hpenOLD
 DeleteObject hpen
 ReleaseDC isHwnd, ishDC
 
 
End Function


Other 7 submission(s) by this author

 


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Advanced category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.