Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'说明：复制请保留源作者信息，转载请说明，欢迎大家提出意见和建议
'--------------画文本用函数----------------------------------------------------
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
'--------------画椎圆用函数----------------------------------------------------
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const CB_SHOWDROPDOWN = &H14F
Const CB_GETDROPPEDSTATE = &H157
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal y As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'------------调用保存对话框--------------------------------
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Dim OriginalX As Single '区域起点X坐标
Dim OriginalY As Single '区域起点的Y坐标
Dim X1 As Single, Y1 As Single, LeftL As Single, TopL As Single
Dim NewX As Single
Dim NewY As Single
Dim Status As String '当前状态（正在选择区域或者拖动区域）
Dim ImgMove As String
Dim Rc As RECT '区域的范围
Dim MPoint As POINTAPI
Dim DPoint As POINTAPI
Dim ptInPic As Boolean '鼠标是否位于pic上
Dim UnloadFrm As Long
Dim Edit As Boolean '是否编辑状态
Dim EditStr As String '编辑内容
Dim Start As Boolean
Dim ImgIndex As Long '记录单击Image2的索引
Dim x0 As Single, y0 As Single
Dim pba As New ExcelPropertyBag
Private Type Bytes
arr() As Byte
End Type
Dim Byt() As Bytes
Dim Indexs As Long, iCount As Long
Private Type POINTAPI
X As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub GetRGBColors(ByVal RGBColor As Long, ByRef RedColor As Long, ByRef GreenColor As Long, ByRef BlueColor As Long)
RedColor = RGBColor Mod 256
GreenColor = (RGBColor \ &H100) Mod 256
BlueColor = (RGBColor \ &H10000) Mod 256
End Sub
Private Sub Timer1_Timer() '放大镜跟随鼠标计时器
Dim result As Long
Dim POINT As POINTAPI
result = GetCursorPos(POINT)
If result <> 0 Then
If POINT.X < 3 Or POINT.X > Screen.Width / 15 - 3 Or POINT.y < 3 Or POINT.y > Screen.Height / 15 - 3 Then Picture3.Cls '只在需要时清除,以免PictureBox一直闪动
'成倍放大,坐标单位:Pixel
StretchBlt Picture3.hdc, 0, 0, 130, 100, GetDC(0), POINT.X - 29, POINT.y - 20, 66, 48, &HCC0020
If POINT.X > Screen.Width / 15 - 142 Then
Picture3.Left = POINT.X - 142
Else
Picture3.Left = POINT.X + 26
End If
If POINT.y > Screen.Height / 15 - 110 Then
Picture3.Top = POINT.y - 110
Else
Picture3.Top = POINT.y + 26
End If
Picture3.DrawWidth = 2 '指定线宽画十字准心
Picture3.Line (Picture3.ScaleWidth / 2, Picture3.ScaleTop + 200)-(Picture3.ScaleWidth / 2, Picture3.ScaleHeight - 200), vbGreen
Picture3.Line (Picture3.ScaleLeft + 200, Picture3.ScaleHeight / 2)-(Picture3.ScaleWidth - 200, Picture3.ScaleHeight / 2), vbGreen
Picture3.DrawStyle = 2
Picture3.DrawWidth = 1
Picture3.Circle (Picture3.ScaleWidth / 2, Picture3.ScaleHeight / 2), 260, vbRed
End If
End Sub
Private Sub Form_Load()
SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 2 Or 1
Timer1.Enabled = True '放大镜跟随鼠标计时开始
Picture1.Top = -Picture1.Height
Picture1.Visible = False
Dim SourceDC As Long
Me.AutoRedraw = True
Me.ScaleMode = 3
Screen.MousePointer = 99 '更改鼠标指针样式
Screen.MouseIcon = LoadResPicture(100, vbResCursor)
SourceDC = CreateDC("DISPLAY", 0, 0, 0)
BitBlt Me.hdc, 0, 0, Screen.Width / 15, Screen.Height / 15, SourceDC, 0, 0, &HCC0020 '拷贝当前屏幕到窗体
DeleteDC SourceDC
Me.WindowState = 2
Me.Picture = Me.Image
Indexs = Indexs + 1
ReDim Preserve Byt(Indexs)
pba.WriteP Byt(Indexs).arr(), Me.Picture
Status = "draw" '绘图状态
Edit = False
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
Unload Me
End If
End Sub
Private Sub Image1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
If Indexs = 1 Then
Edit = False
End If
If Edit = False Then
If Status = "move" Then
ImgMove = "Start"
GetCursorPos DPoint
LeftL = Shape1.Left: TopL = Shape1.Top
X1 = Shape1.Left + Shape1.Width: Y1 = Shape1.Top + Shape1.Height
Picture1.Visible = False
Picture2.Visible = False
Indexs = 1: iCount = 1
ReDim Preserve Byt(Indexs)
End If
End If
End Sub
Private Sub Image1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
On Error Resume Next
Select Case Index
Case 0: Screen.MousePointer = 8
Case 1: Screen.MousePointer = 7
Case 2: Screen.MousePointer = 6
Case 3: Screen.MousePointer = 9
Case 4: Screen.MousePointer = 6
Case 5: Screen.MousePointer = 7
Case 6: Screen.MousePointer = 8
Case 7: Screen.MousePointer = 9
End Select
If ImgMove = "Start" Then
GetCursorPos MPoint '取得当前鼠标位置
Image1(Index).Move MPoint.X, MPoint.y
Select Case Index
Case 0 '左上移动
Shape1.Move MPoint.X + Image1(Index).Width / 2, MPoint.y + Image1(Index).Height / 2, X1 - MPoint.X, Y1 - MPoint.y
Case 1 '上移动
Shape1.Move LeftL, MPoint.y + Image1(Index).Height / 2, X1 - LeftL, Y1 - MPoint.y
Case 2 '右上移动
Shape1.Move LeftL, MPoint.y + Image1(Index).Height / 2, (MPoint.X - LeftL) + Image1(Index).Width / 2, Y1 - MPoint.y
Case 3 '左移动
Shape1.Move MPoint.X + Image1(Index).Width / 2, TopL, X1 - MPoint.X, Y1 - TopL
Case 4 '左下移动
Shape1.Move MPoint.X + Image1(Index).Width / 2, TopL, X1 - MPoint.X, MPoint.y - TopL
Case 5 '下移动
Shape1.Move LeftL, TopL, X1 - LeftL, MPoint.y - TopL
Case 6 '右下移动
Shape1.Move LeftL, TopL, MPoint.X - LeftL, MPoint.y - TopL
Case 7 '右移动
Shape1.Move LeftL, TopL, MPoint.X - LeftL, Y1 - TopL
End Select
ImageMove
LblPos.Caption = Shape1.Width & "x" & Shape1.Height
LblPos.Move Shape1.Left + 2, Shape1.Top + 2 '尺寸信息位置
LblInfo.Move Shape1.Left + 2, LblPos.Top + LblPos.Height + 2 'RGB 信息位置
OriginalX = Shape1.Left
OriginalY = Shape1.Top
End If
End Sub
Private Sub Image1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
ImgMove = "Stop"
If (Shape1.Top + Shape1.Height + 4 + Picture1.Height) > Screen.Height / 15 Then
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, (Shape1.Top + Shape1.Height) - Picture1.Height - 4
Else
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, Shape1.Top + Shape1.Height + 4
End If
If Picture1.Left < 0 Then Picture1.Move 0
Picture1.Visible = True
End Sub
Private Sub Image2_Click(Index As Integer)
Dim i As Integer
Select Case Index
Case 0 '撤销
Indexs = Indexs - 1
If Indexs > 0 Then
Set Me.Picture = pba.ReadP(Byt(Indexs).arr())
Else
Status = "draw"
Shape1.Visible = False
Picture1.Visible = False
Picture2.Visible = False
LblPos.Visible = False
LblInfo.Visible = False
Shape1.Width = 0
Shape1.Height = 0
For i = 0 To 7
Image1(i).Visible = False
Next
Indexs = 1
Edit = False
' ReDim Byt(1)
End If
Case 1
'--------------隐藏截图区控件--------------------------
Picture1.Visible = False '如果选区包含部分提示图片，则需要把图片先隐藏。
Picture2.Visible = False
Sleep 10 '有时候没有这两句会使得shape1也显示在截取的区域里
DoEvents
Shape1.Visible = False
'--------------开始按指定坐标截图---------------------------------------
ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
Unload Me
Case 2
Dim PicBool As Boolean
If Picture2.Visible = True Then PicBool = True Else PicBool = False
'--------------隐藏截图区控件--------------------------
Picture1.Visible = False '如果选区包含部分提示图片，则需要把图片先隐藏。
Picture2.Visible = False
Sleep 10 '有时候没有这两句会使得shape1也显示在截取的区域里
DoEvents
Shape1.Visible = False
'--------------开始按指定坐标截图---------------------------------------
ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
'----------重新显示隐藏控件----------------
Picture1.Visible = True
If PicBool = True Then Picture2.Visible = True
Shape1.Visible = True
'------------------------------------------
Call CutdSave '保存截图
Unload Me
Case 3
Unload Me
Case 4
Picture2.Left = Picture1.Left
If (Picture1.Top + Picture1.Height + 3 + Picture2.Height) > Screen.Height / 15 Then
Picture2.Top = Picture1.Top - Picture2.Height - 3
Else
Picture2.Top = Picture1.Top + Picture1.Height + 3
End If
PicFont.Visible = False
PicColor.Left = PicFont.Left
Picture2.Width = 3620 / 15 - PicFont.Width - 2
Shape4.Width = Picture2.ScaleWidth
If Picture2.Visible = False Then
Picture2.Visible = True
Else
If ImgIndex = Index Then Picture2.Visible = False '如果当前单击的按钮索引与记录索引相同就将Picture2隐藏
End If
Edit = True
EditStr = Image2(Index).ToolTipText
Case 5
Picture2.Left = Picture1.Left
If (Picture1.Top + Picture1.Height + 3 + Picture2.Height) > Screen.Height / 15 Then
Picture2.Top = Picture1.Top - Picture2.Height - 3
Else
Picture2.Top = Picture1.Top + Picture1.Height + 3
End If
PicFont.Visible = True
PicColor.Left = 78.667
Picture2.Width = 3620 / 15
Shape4.Width = Picture2.ScaleWidth
If Picture2.Visible = False Then
Picture2.Visible = True
Else
If ImgIndex = Index Then Picture2.Visible = False '如果当前单击的按钮索引与记录索引相同就将Picture2隐藏
End If
Edit = True
EditStr = Image2(Index).ToolTipText
Case 6
Picture2.Left = Picture1.Left
If (Picture1.Top + Picture1.Height + 3 + Picture2.Height) > Screen.Height / 15 Then
Picture2.Top = Picture1.Top - Picture2.Height - 3
Else
Picture2.Top = Picture1.Top + Picture1.Height + 3
End If
PicFont.Visible = False
PicColor.Left = PicFont.Left
Picture2.Width = 3620 / 15 - PicFont.Width - 2
Shape4.Width = Picture2.ScaleWidth
If Picture2.Visible = False Then
Picture2.Visible = True
Else
If ImgIndex = Index Then Picture2.Visible = False '如果当前单击的按钮索引与记录索引相同就将Picture2隐藏
End If
Edit = True
EditStr = Image2(Index).ToolTipText
Case 7
Picture2.Left = Picture1.Left
If (Picture1.Top + Picture1.Height + 3 + Picture2.Height) > Screen.Height / 15 Then
Picture2.Top = Picture1.Top - Picture2.Height - 3
Else
Picture2.Top = Picture1.Top + Picture1.Height + 3
End If
PicFont.Visible = False
PicColor.Left = PicFont.Left
Picture2.Width = 3620 / 15 - PicFont.Width - 2
Shape4.Width = Picture2.ScaleWidth
If Picture2.Visible = False Then
Picture2.Visible = True
Else
If ImgIndex = Index Then Picture2.Visible = False '如果当前单击的按钮索引与记录索引相同就将Picture2隐藏
End If
Edit = True
EditStr = Image2(Index).ToolTipText
Case 8 '重做
Indexs = Indexs + 1
If Indexs <= iCount Then
Set Me.Picture = pba.ReadP(Byt(Indexs).arr())
Else
Indexs = iCount
End If
End Select
ImgIndex = Index
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, y As Single)
If Edit = False Then
Picture1.Visible = False
If Status = "draw" Then '如果是抓取状态
Shape1.Visible = True
Shape1.Width = 0
Shape1.Height = 0
OriginalX = X
OriginalY = y '起点坐标
Shape1.Left = OriginalX
Shape1.Top = OriginalY
If Button = 2 Then
UnloadFrm = 0
End If
Else
Screen.MousePointer = 99 '更改鼠标指针样式
Screen.MouseIcon = LoadResPicture(100, vbResCursor)
Rc.Left = Shape1.Left
Rc.Right = Shape1.Left + Shape1.Width
Rc.Top = Shape1.Top
Rc.Bottom = Shape1.Top + Shape1.Height
If PtInRect(Rc, X, y) Then '如果按下的点位于区域内
NewX = X
NewY = y '则移动区域
If Button = 2 Then
Shape1.Width = 0
Shape1.Height = 0
OriginalX = X
OriginalY = y
Shape1.Left = OriginalX
Shape1.Top = OriginalY
Shape1.Visible = False
LblPos.Visible = False
LblInfo.Visible = False
For i = 0 To 7
Image1(i).Visible = False
Next
Screen.MousePointer = 0
Status = "draw" '状态恢复到抓取
UnloadFrm = 1
End If
Else '否则重新画一个区域
Shape1.Width = 0
Shape1.Height = 0
OriginalX = X
OriginalY = y
Shape1.Left = OriginalX
Shape1.Top = OriginalY
Shape1.Visible = False
LblPos.Visible = False
LblInfo.Visible = False
For i = 0 To 7
Image1(i).Visible = False
Next
Screen.MousePointer = 0
Status = "draw" '状态恢复到抓取
UnloadFrm = 1
End If
End If
Else
If X > Shape1.Left And X < Shape1.Left + Shape1.Width And y > Shape1.Top And y < Shape1.Top + Shape1.Height Then
Start = True: Me.AutoRedraw = False: x0 = X: y0 = y
End If
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, y As Single)
If Start = True Then '开始编辑
Me.AutoRedraw = True
Dim X2 As Single, Y2 As Single
If Start = True Then
Me.Cls
If X > Shape1.Left + Shape1.Width Then
X2 = Shape1.Left + Shape1.Width
ElseIf X < Shape1.Left Then
X2 = Shape1.Left
Else
X2 = X
End If
If y > Shape1.Top + Shape1.Height Then
Y2 = Shape1.Top + Shape1.Height
ElseIf y < Shape1.Top Then
Y2 = Shape1.Top
Else
Y2 = y
End If
Select Case EditStr
Case "添加箭头"
Call Arrow(Me, x0, y0, X2, Y2, 10, Pcolor(16).BackColor)
'----------将当前窗体Image设置为窗体Picture----------
Start = False
Me.Picture = Me.Image
Indexs = Indexs + 1
iCount = Indexs
ReDim Preserve Byt(Indexs)
pba.WriteP Byt(Indexs).arr(), Me.Picture
Case "添加文字"
TextEdit.ForeColor = Pcolor(16).BackColor
Me.FontSize = Text1.Text
TextEdit.FontSize = Text1.Text
If TextEdit.Visible = False Then
TextEdit.Left = X: TextEdit.Top = y
TextEdit.Width = 375 / 15
TextEdit.Visible = True: TextEdit.SetFocus
Else
SetTextColor Me.hdc, Pcolor(16).BackColor
TextOut Me.hdc, TextEdit.Left, TextEdit.Top, TextEdit, LenB(StrConv(TextEdit, vbFromUnicode))
TextEdit.Visible = False: TextEdit = ""
'----------将当前窗体Image设置为窗体Picture----------
Start = False
Me.Picture = Me.Image
Indexs = Indexs + 1
iCount = Indexs
ReDim Preserve Byt(Indexs)
pba.WriteP Byt(Indexs).arr(), Me.Picture
End If
Case "添加椭圆"
Dim tmppen As Long
Dim pen As Long
pen = CreatePen(0, 1, Pcolor(16).BackColor) '创建一个画笔
tmppen = SelectObject(Me.hdc, pen) '选定一个刷子
Ellipse Me.hdc, x0, y0, X2, Y2 '画图
SelectObject Me.hdc, tmppen '删除对象
DeleteObject pen
'----------将当前窗体Image设置为窗体Picture----------
Start = False
Me.Picture = Me.Image
Indexs = Indexs + 1
iCount = Indexs
ReDim Preserve Byt(Indexs)
pba.WriteP Byt(Indexs).arr(), Me.Picture
Case "添加矩形"
Me.Line (x0, y0)-(X2, Y2), Pcolor(16).BackColor, B '画矩形
'----------将当前窗体Image设置为窗体Picture----------
Start = False
Me.Picture = Me.Image
Indexs = Indexs + 1
iCount = Indexs
ReDim Preserve Byt(Indexs)
pba.WriteP Byt(Indexs).arr(), Me.Picture
End Select
End If
End If
If Button = 1 Then
If Status = "draw" Then
Status = "move"
End If
OriginalX = Shape1.Left '更新OriginalX，因为选择区域时可能会出现shape的right点大于left点
OriginalY = Shape1.Top
If (Shape1.Top + Shape1.Height + 4 + Picture1.Height) > Screen.Height / 15 Then
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, (Shape1.Top + Shape1.Height) - Picture1.Height - 4
Else
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, Shape1.Top + Shape1.Height + 4
End If
If Picture1.Left < 0 Then Picture1.Move 0
Picture1.Visible = True
Else
If UnloadFrm = 0 Then Unload Me
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
Dim RGBColor As Long, Red As Long, Green As Long, Blue As Long
X1 = X: Y1 = y
RGBColor = GetPixel(Me.hdc, X, y)
GetRGBColors RGBColor, Red, Green, Blue
LblInfo.Caption = "RGB(" & Red & "," & Green & "," & Blue & ")"
Dim Info As String
If Edit = False Then '编辑状态
If Shape1.Visible = True And X > Shape1.Left And y > Shape1.Top And X < (Shape1.Left + Shape1.Width) And y < (Shape1.Top + Shape1.Height) Then
Screen.MousePointer = 5
Timer1.Enabled = False '放大镜跟随鼠标计时结束
Picture3.Visible = False '放大镜跟随鼠标关闭
Else
Screen.MousePointer = 99 '更改鼠标指针样式
Screen.MouseIcon = LoadResPicture(100, vbResCursor)
Timer1.Enabled = True '放大镜跟随鼠标计时开始
Picture3.Visible = True '放大镜跟随鼠标开启
End If
If Button = 1 Then
Shape1.Visible = False
LblPos.Visible = False
LblInfo.Visible = False
If Status = "draw" Then '如果是绘图状态
If X > OriginalX And y > OriginalY Then '根据鼠标位置调整shape1的大小和位置
Shape1.Move OriginalX, OriginalY, X - OriginalX, y - OriginalY
ElseIf X < OriginalX And y > OriginalY Then
Shape1.Move X, OriginalY, OriginalX - X, y - OriginalY
ElseIf X > OriginalX And y < OriginalY Then
Shape1.Move OriginalX, y, X - OriginalX, OriginalY - y
ElseIf X < OriginalX And y < OriginalY Then
Shape1.Move X, y, OriginalX - X, OriginalY - y
End If
Info = Shape1.Width & "x" & Shape1.Height '显示当前区域的大小
LblPos.Move Shape1.Left + 2, Shape1.Top + 2 '尺寸信息位置
LblInfo.Move Shape1.Left + 2, LblPos.Top + LblPos.Height + 2 'RGB 信息位置
LblPos.Caption = Info
Screen.MousePointer = vbCrosshair
Else '如果是移动状态
Screen.MousePointer = 5
Shape1.Left = OriginalX - (NewX - X)
Shape1.Top = OriginalY - (NewY - y)
If Shape1.Left < 0 Then Shape1.Left = 0 '使区域不超过屏幕
If Shape1.Top < 0 Then Shape1.Top = 0
If Shape1.Left + Shape1.Width > Screen.Width / 15 Then Shape1.Left = Screen.Width / 15 - Shape1.Width
If Shape1.Top + Shape1.Height > Screen.Height / 15 Then Shape1.Top = Screen.Height / 15 - Shape1.Height
LblPos.Move Shape1.Left + 2, Shape1.Top + 2
LblInfo.Move Shape1.Left + 2, LblPos.Top + LblPos.Height + 2
End If
Call ImageMove
Shape1.Visible = True
LblPos.Visible = True
LblInfo.Visible = True
End If
Else
Dim X2 As Single, Y2 As Single
If Start = True Then '开始编辑
Me.Cls
If X > Shape1.Left + Shape1.Width Then
X2 = Shape1.Left + Shape1.Width
ElseIf X < Shape1.Left Then
X2 = Shape1.Left
Else
X2 = X
End If
If y > Shape1.Top + Shape1.Height Then
Y2 = Shape1.Top + Shape1.Height
ElseIf y < Shape1.Top Then
Y2 = Shape1.Top
Else
Y2 = y
End If
Select Case EditStr
Case "添加箭头"
Call Arrow(Me, x0, y0, X2, Y2, 10, Pcolor(16).BackColor)
Case "添加文字"
Case "添加椭圆"
Dim tmppen As Long
Dim pen As Long
pen = CreatePen(0, 1, Pcolor(16).BackColor) '创建一个画笔
tmppen = SelectObject(Me.hdc, pen) '选定一个刷子
Ellipse Me.hdc, x0, y0, X2, Y2 '画图
SelectObject Me.hdc, tmppen '删除对象
DeleteObject pen
Case "添加矩形"
Me.Line (x0, y0)-(X2, Y2), Pcolor(16).BackColor, B '画矩形
End Select
End If
End If
End Sub
Private Sub Form_DblClick()
If PtInRect(Rc, NewX, NewY) Then '看是否在区域内
Picture1.Visible = False '如果选区包含部分提示图片，则需要把图片先隐藏。
Sleep 10 '有时候没有这两句会使得shape1也显示在截取的区域里
DoEvents
Shape1.Visible = False
ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
'MsgBox "图象已经保存到剪贴板中", vbInformation, "提示"
Unload Me
End If
End Sub
Public Sub ScrnCap(Left As Long, Top As Long, Right As Long, Bottom As Long)
Dim i As Integer
Shape1.Visible = False '不需要拷贝shape
LblPos.Visible = False
LblInfo.Visible = False
For i = 0 To 7
Image1(i).Visible = False
Next
DoEvents
Dim rWidth As Long
Dim rHeight As Long
Dim SourceDC As Long
Dim DestDC As Long
Dim BHandle As Long
Dim Wnd As Long
Dim DHandle As Long
rWidth = Right - Left
rHeight = Bottom - Top
SourceDC = CreateDC("DISPLAY", 0, 0, 0)
DestDC = CreateCompatibleDC(SourceDC)
BHandle = CreateCompatibleBitmap(SourceDC, rWidth, rHeight)
SelectObject DestDC, BHandle
BitBlt DestDC, 0, 0, rWidth, rHeight, SourceDC, Left, Top, &HCC0020
Wnd = GetDesktopWindow
OpenClipboard Wnd
EmptyClipboard
SetClipboardData 2, BHandle
CloseClipboard
DeleteDC DestDC
ReleaseDC DHandle, SourceDC
End Sub
'--------------------保存截图-----------------------------------------
Public Function CutdSave()
Dim sFile As String
Dim SaveOpen As OPENFILENAME
Dim PicType As String
SaveOpen.lStructSize = Len(SaveOpen)
SaveOpen.hwndOwner = 0&
SaveOpen.lpstrFile = String$(255, 0)
SaveOpen.nMaxFile = 255
SaveOpen.lpstrInitialDir = App.Path
SaveOpen.lpstrFilter = "PNG文件(*.PNG)" + Chr$(0) + "*.PNG" + Chr$(0) + "JPEG文件(*.jpg;*.jpeg)" + Chr$(0) + "*.jpg" + Chr$(0) + "位图文件(*.bmp)" + Chr$(0) + "*.bmp" + Chr$(0) + "GIF文件(*.gif)" + Chr$(0) + "*.gif" + Chr$(0) + "TIFF文件(*.TIFF)" + Chr$(0) + "*.tiff" + Chr$(0) + "所有文件(*.*)" + Chr$(0) + "*.*" + Chr$(0)
SaveOpen.lpstrTitle = "保存为"
SaveOpen.nFilterIndex = 1 '设置默认选择扩展类型
SaveOpen.lpstrDefExt = "PNG" '初始化扩展名
'SaveOpen.lpstrFile = FileName '保存文件名称
If GetSaveFileName(SaveOpen) <> 0 Then
sFile = Left(SaveOpen.lpstrFile, InStr(SaveOpen.lpstrFile, Chr$(0)) - 1)
Else
Exit Function
End If
'SavePicture Clipboard.GetData(), sFile
PicType = Right(sFile, Len(sFile) - InStrRev(sFile, "."))
SavePic Clipboard.GetData(), sFile, PicType
Clipboard.Clear ' 清除剪贴板
End Function
Private Sub Image2_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
Dim i As Integer
For i = 0 To 8
Shape3(i).Visible = False
Next
Shape3(Index).Visible = True
End Sub
Private Sub Pcolor_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
Pcolor(16).BackColor = Pcolor(Index).BackColor
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
Screen.MousePointer = 1
Timer1.Enabled = False '放大镜跟随鼠标计时结束
Picture3.Visible = False '放大镜跟随鼠标关闭
For i = 0 To 8
Shape3(i).Visible = False
Next
End Sub
'------------移动图片控件Image1--------------------
Public Function ImageMove()
Dim i As Integer
Image1(0).Move Shape1.Left - (Image1(0).Width / 2), Shape1.Top - (Image1(0).Height / 2)
Image1(1).Move (Shape1.Left + (Shape1.Width / 2)) - (Image1(0).Width / 2), Shape1.Top - (Image1(0).Height / 2)
Image1(2).Move (Shape1.Left + (Shape1.Width)) - (Image1(2).Width / 1.5), Shape1.Top - (Image1(2).Height / 2)
Image1(3).Move Shape1.Left - (Image1(3).Width / 2), Shape1.Top + (Shape1.Height / 2) - (Image1(3).Height / 2)
Image1(4).Move Shape1.Left - (Image1(4).Width / 2), Shape1.Top + (Shape1.Height) - (Image1(4).Height / 2)
Image1(5).Move (Shape1.Left + (Shape1.Width / 2)) - (Image1(5).Width / 2), Shape1.Top + (Shape1.Height) - (Image1(5).Height / 2)
Image1(6).Move (Shape1.Left + (Shape1.Width)) - (Image1(6).Width / 2), Shape1.Top + (Shape1.Height) - (Image1(6).Height / 2)
Image1(7).Move (Shape1.Left + (Shape1.Width)) - (Image1(7).Width / 2), Shape1.Top + (Shape1.Height / 2) - (Image1(7).Height / 2)
For i = 0 To 7
Image1(i).Visible = True
Next
End Function
'-----------------------------增加---------------------------------
Private Sub PicCombox_MouseDown(Button As Integer, Shift As Integer, X As Single, y As Single)
PicCombox.Picture = Image4(2).Picture
OpenCombo Combo1.hwnd
End Sub
Private Sub PicCombox_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
PicCombox.Picture = Image4(1).Picture
End Sub
Private Sub PicFont_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
PicCombox.Picture = Image4(0).Picture
End Sub
Private Sub Combo1_Click()
Text1.Text = Combo1.Text
End Sub
Private Sub Pcolor_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
If Index <> 16 Then
Pcolor(Index).BorderStyle = 1
Else
For i = 0 To 15
Pcolor(i).BorderStyle = 0
Next
End If
End Sub
Private Sub PicColor_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
For i = 0 To 15
Pcolor(i).BorderStyle = 0
Next
End Sub
Public Sub OpenCombo(Chwnd As Long) '强制弹出Combo1的下拉列表
Dim Rc As Long
Rc = SendMessage(Chwnd, CB_GETDROPPEDSTATE, 0, 0)
If Rc = 0 Then
SendMessage Chwnd, CB_SHOWDROPDOWN, True, 0
Else
SendMessage Chwnd, CB_SHOWDROPDOWN, False, 0
End If
End Sub
Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
Screen.MousePointer = 1
End Sub
'-------------------画箭头---------------------
Sub Arrow(Pic As Object, x0 As Single, y0 As Single, X1 As Single, Y1 As Single, ArrowLen As Single, Optional color As Long = 0)
Dim Xa As Single, Ya As Single, Xb As Single, Yb As Single, D As Double, Xc As Single, Yc As Single, Xd As Single, Yd As Single
D = Sqr(((Y1 - y0) * (Y1 - y0) + (X1 - x0) * (X1 - x0)) / 2)
If D > 0.0000000001 Then
Xa = X1 + ArrowLen * ((x0 - X1) + (y0 - Y1) / 2) / D
Ya = Y1 + ArrowLen * ((y0 - Y1) - (x0 - X1) / 2) / D
Xb = X1 + ArrowLen * ((x0 - X1) - (y0 - Y1) / 2) / D
Yb = Y1 + ArrowLen * ((y0 - Y1) + (x0 - X1) / 2) / D
Xc = ((Xa + Xb) / 2 + (X1 + Xa) / 2) / 2
Yc = ((Ya + Yb) / 2 + (Y1 + Ya) / 2) / 2
Xd = ((Xa + Xb) / 2 + (X1 + Xb) / 2) / 2
Yd = ((Ya + Yb) / 2 + (Y1 + Yb) / 2) / 2
Pic.Line (x0, y0)-(Xc, Yc), color '如果仅画箭头，此句可删除
Pic.Line (x0, y0)-(Xd, Yd), color '如果仅画箭头，此句可删除
Pic.Line (Xa, Ya)-(X1, Y1), color
Pic.Line (Xb, Yb)-(X1, Y1), color
Pic.Line (Xa, Ya)-(Xc, Yc), color
Pic.Line (Xb, Yb)-(Xd, Yd), color
End If
End Sub
Private Sub TextEdit_Change()
If Me.TextWidth(TextEdit) > TextEdit.Width Then TextEdit.Width = Me.TextWidth(TextEdit)
End Sub