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(HexKaTeX parse error: Expected 'EOF', got '&' at position 25: …(0))) = 1, "0" &̲ Hex(ColorArr(0)), HexKaTeX parse error: Expected 'EOF', got '&' at position 16: (ColorArr(0))) &̲ IIf(Len(Hex(ColorArr(1))) = 1, “0” & _
Hex$(ColorArr(1)),Hex$(ColorArr(1))) & IIf(Len(HexKaTeX parse error: Expected 'EOF', got '&' at position 25: …(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