VB模仿CAD十字光标-Toy模板网

这篇具有很好参考价值的文章主要介绍了VB模仿CAD十字光标。希望对大家有所帮助。如果存在错误或未考虑完全的地方，请大家不吝赐教，您也可以点击"举报违法"按钮提交疑问。

Option Explicit
Private Declare Function ShowCursor Lib “user32” (ByVal bShow As Long) As Long
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Enum GpStatus
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
End Enum
Private Declare Function GdipCreateFromHDC Lib “gdiplus” (ByVal hdc As Long, Graphics As Long) As GpStatus
Private Declare Function GdipCreateSolidFill Lib “gdiplus” (ByVal argb As Long, Brush As Long) As GpStatus
Private Declare Function GdiplusStartup Lib “gdiplus” (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Sub GdiplusShutdown Lib “gdiplus” (ByVal Token As Long)
Private Declare Function GdipDeleteBrush Lib “gdiplus” (ByVal Brush As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib “gdiplus” (ByVal Graphics As Long) As GpStatus
Private Declare Function GdipFillRectangle Lib “gdiplus” (ByVal Graphics As Long, ByVal Brush As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
Dim mToken As Long, Graphics As Long, Brush As Long
Private Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib “gdi32” (ByVal hdc As Long) As Long
Dim WithEvents District As Shape
Dim XL As Single, YT As Single
Dim Bnt As Boolean
Private Type MARQUEE_AREA
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Enum OpType
None = 0
Draw = 1
Drag = 2
End Enum
Dim BoxArea As MARQUEE_AREA
Dim Ot As OpType
Dim Sbwzxy(1) As Long
Dim SB As Boolean
Dim Distance As Long
Dim LineColor As Long
Dim XqColor As Long

Private Sub Form_Load()
Me.AutoRedraw = True: Me.ScaleMode = 3
Me.BackColor = RGB(0, 0, 0)
Distance = 10
LineColor = RGB(30, 30, 30)
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
XL = X: YT = Y
If SB = True Then SB = False Else SB = True
Call Region(X, Y, Me.ScaleWidth, Me.ScaleHeight)
If X > BoxArea.Left And X < BoxArea.Right + XL And Y > BoxArea.Top And Y < BoxArea.Bottom + YT Then
Sbwzxy(0) = X: Sbwzxy(1) = Y
End If
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Refresh
Me.Cls
Dim L As Long, T As Long, ll As Long
If SB = True Then
Call Region(X, Y, Me.ScaleWidth, Me.ScaleHeight)
End If
If SB = False Then Me.Line (X - 10, Y - 10)-(X + 10, Y + 10), RGB(255, 255, 255), B
Me.Line (X - 100, Y)-(IIf(SB, X, X - 10), Y), RGB(255, 255, 255), B
Me.Line (IIf(SB, X, X + 10), Y)-(X + 100, Y), RGB(255, 255, 255), B
Me.Line (X, Y - 100)-(X, IIf(SB, Y, Y - 10)), RGB(255, 255, 255), B
Me.Line (X, IIf(SB, Y, Y + 10))-(X, Y + 100), RGB(255, 255, 255), B
End Sub

Private Sub Form_Resize()
Dim X, Y
Me.DrawWidth = 1
Me.Refresh
Me.Cls
Set Me.Picture = LoadPicture(“”)
For X = 0 To Me.ScaleWidth Step Distance
Me.Line (X, 0)-(X, Me.ScaleHeight), LineColor
Next
For Y = 0 To Me.ScaleHeight Step Distance
Me.Line (0, Y)-(Me.ScaleWidth, Y), LineColor
Next
Me.Line (15, Me.ScaleHeight - 30)-(Me.ScaleWidth, Me.ScaleHeight - 30), RGB(100, 0, 0), B
Me.Line (15, Me.ScaleHeight - 30)-(80, Me.ScaleHeight - 30), RGB(255, 255, 255), B
Me.Line (15, 0)-(15, Me.ScaleHeight - 30), RGB(0, 100, 0), B
Me.Line (15, Me.ScaleHeight - 100)-(15, Me.ScaleHeight - 30), RGB(255, 255, 255), B
Me.Line (10, Me.ScaleHeight - 38)-(22, Me.ScaleHeight - 25), RGB(255, 255, 255), B
Me.ForeColor = RGB(255, 255, 255)
Me.CurrentX = 18: Me.CurrentY = Me.ScaleHeight - 110
Me.FontSize = 12
Me.Print “X”
Me.CurrentX = 80: Me.CurrentY = Me.ScaleHeight - 45
Me.FontSize = 12
Me.Print “Y”

Set Me.Picture = Me.Image

End Sub

Private Sub Region(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single)
Dim Lx As Long, Ty As Long, Dcolor As Long
BoxArea.Left = IIf(X1 > XL, XL, IIf(X1 <= 0, 0, X1))
BoxArea.Top = IIf(Y1 > YT, YT, IIf(Y1 <= 0, 0, Y1))
BoxArea.Right = IIf(X1 > XL, IIf(X1 < X2, X1 - XL, X2 - XL), IIf(X1 < 0, XL, XL - X1))
BoxArea.Bottom = IIf(Y1 > YT, IIf(Y1 < Y2, Y1 - YT, Y2 - YT), IIf(Y1 < 0, YT, YT - Y1))

If XL < X1 Then
XqColor = RGB(0, 0, 155): Me.DrawStyle = 0
Lx = X1 + 15: Ty = Y1 - 15: Dcolor = RGB(0, 0, 255)
Else
XqColor = RGB(0, 155, 0): Me.DrawStyle = 2
Lx = X1 + 10: Ty = Y1 - 15: Dcolor = RGB(0, 255, 0)
End If
Call GICpic(Me.hdc, BoxArea.Left, BoxArea.Top, BoxArea.Right, BoxArea.Bottom, XqColor, 100)
Me.Line (BoxArea.Left, BoxArea.Top)-(BoxArea.Left + BoxArea.Right, BoxArea.Top + BoxArea.Bottom), RGB(255, 255, 255), B
Me.Line (X1 + 20, Y1 - 20)-(X1 + 10, Y1 - 10), RGB(255, 255, 255), B
Me.FillStyle = 0
Me.FillColor = Dcolor
Me.Circle (Lx, Ty), 2.5, vbBlack

Me.FillStyle = 1
Me.DrawStyle = 0
End Sub

Private Sub GICpic(hdc As Long, Left As Long, Top As Long, Width As Long, Height As Long, Optional Bcolor As Long, Optional Tming As Long = 255)
Dim GdipInput As GdiplusStartupInput, ColorArr, Fcolor As String, Price As String, Lhdc(4) As Long
Dim Blue&, Red&, Green&
Blue = 0: Red = 0: Green = 0
Blue = Bcolor \ 65536
Green = (Bcolor - 65536 * Blue) \ 256
Red = Bcolor - 65536 * Blue - Green * 256
ColorArr = Array(Red, Green, Blue)
'On Error GoTo Nx
GdipInput.GdiplusVersion = 2
Lhdc(0) = GdiplusStartup(mToken, GdipInput)
Lhdc(1) = GdipCreateFromHDC(hdc, Graphics)
Price = IIf(Len(Hex(Tming)) = 1, “0” & Hex(Tming), Hex(Tming))

Fcolor = IIf(Len(Hex $KaTeX parse error: Expected 'EOF', got '&' at position 25: \dots(0))) = 1, "0" &̲ Hex$ (ColorArr(0)), Hex $KaTeX parse error: Expected 'EOF', got '&' at position 16: (ColorArr(0))) &̲ IIf(Len(Hex$ (ColorArr(1))) = 1, “0” & _
Hex $(C o l or A rr (1)), He x$ (ColorArr(1))) & IIf(Len(Hex $KaTeX parse error: Expected 'EOF', got '&' at position 25: \dots(2))) = 1, "0" &̲ Hex$ (ColorArr(2)), Hex$(ColorArr(2)))
Lhdc(2) = GdipCreateSolidFill(“&H” & Price & Fcolor, Brush)
Lhdc(3) = GdipFillRectangle(Graphics, Brush, Left, Top, Width, Height)

Call GdipDeleteBrush(Brush)
Call GdipDeleteGraphics(Graphics)
Call GdiplusShutdown(mToken)
Call DeleteObject(mToken)

For Lhdc(4) = 0 To 3
Call DeleteDC(Lhdc(Lhdc(4)))
Call DeleteObject(Lhdc(Lhdc(4)))
Next
'Nx:
End Sub文章来源地址https://www.toymoban.com/news/detail-430107.html

到了这里，关于VB模仿CAD十字光标的文章就介绍完了。如果您还想了解更多内容，请在右上角搜索TOY模板网以前的文章或继续浏览下面的相关文章，希望大家以后多多支持TOY模板网！