CADクロスカーソルのVB模倣

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
中止 = 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
プライベート タイプ MARQUEE_AREA
Left As Long
Top As Long
Right As
Long
Bottom 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)
X > BoxArea.Left および X < BoxArea.Right + XL および Y > BoxArea.Top および Y < BoxArea.Bottom + YT の場合
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
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 Me.ScaleWidth へのステップ距離
Me.Line (X, 0)-( X, Me.ScaleHeight), LineColor
Next
For Y = 0 Me.ScaleHeight ステップ距離
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"

Me.Picture = Me.Image を設定します。

サブ終了

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, 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, オプションの Bcolor As Long, オプションの 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: 赤 = 0: 緑 = 0
青 = Bcolor \ 65536
緑 = (Bcolor - 65536 * 青) \ 256
赤 = Bcolor - 65536 * 青 - 緑 * 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) (タイミング)) = 1, “0” & Hex(タイミング), Hex(タイミング))

Fcolor = IIf(Len(Hex KaTeX parse error: Expected 'EOF', got '&' at position 25: …(0))) = 1, "0" &̲ Hex (ColorArr (0)), Hex KaTeX parse error: 'EOF' が予期され、位置 16 で '&' を取得: (ColorArr(0))) &̲ IIf(Len(Hex (ColorArr(1))) = 1, “0” & _
Hex $\left(ColまたはArr\right(1\left)\right)、Hex$ (ColorArr(1))) & IIf(Len(HexKaTeX 解析エラー: 'EOF' が予期され、位置 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)

GdipDeleteBrush(Brush) を呼び出す
GdipDeleteGraphics(Graphics) を呼び出す
GdiplusShutdown(mToken) を
呼び出す DeleteObject(mToken) を呼び出す

Lhdc(4) = 0 から 3 の場合
Call DeleteDC(Lhdc(Lhdc(4)))
Call DeleteObject(Lhdc(Lhdc(4)))
Next
'Nx:
End Sub