frmmain.frm

一款漂亮的控件。 快

                ElseIf b > 32767 Then
                    b = b - 32767
                End If
                If r > 32767 Or g > 32767 Or b > 32767 Then
                    GoTo nOK
                End If
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
End Sub

Private Sub mnuHorzLine_Click()
    curTools = Tools.sHorzLine
End Sub

Private Sub mnuIce_Click()
    Dim TColI As Long
    
    Call Save
    For i = 0 To cX
        For j = 0 To cY
            TColI = GetPixel(picMain.hdc, i, j)
            r = TColI Mod 256
            g = (TColI \ 256) Mod 256
            b = TColI \ 256 \ 256
            r = Abs((r - g - b) * 1.5)
            g = Abs((g - b - r) * 1.5)
            b = Abs((b - r - g) * 1.5)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
End Sub


Private Sub mnuM25_Click()
    Call Zoom(0.25)
End Sub

Private Sub mnuM50_Click()
    Call Zoom(0.5)
End Sub

Private Sub mnuM75_Click()
    Call Zoom(0.75)
End Sub

Private Sub mnuNew_Click()
    picMain.Refresh
    picNew.Height = picMain.Height
    picNew.Width = picMain.Width
    picMain.Picture = picNew.Image
End Sub

Private Sub mnuOpen_Click()
    Dim sFName As String
    
    On Error Resume Next
    comDiag.Filter = "*.bmp;*.jpg;*.gif;*.wmf;"
    comDiag.ShowOpen
    sFName = comDiag.FileName
    
    If sFName = "" Then Exit Sub
    
    If Not FileExist(sFName) Then
        MsgBox "File doesn't exist.", vbCritical, "Error"
        Exit Sub
    End If
    
    picMain.Picture = LoadPicture(sFName)
    If Err Then
        MsgBox "This is not a valid picture!", vbCritical, "Error"
        Exit Sub
    End If
    Call ResizePicBoxes
    cX = picMain.ScaleWidth
    cY = picMain.ScaleHeight
End Sub

Private Sub mnuP25_Click()
    Call Zoom(1.25)
End Sub

Private Sub mnuP50_Click()
    Call Zoom(1.5)
End Sub

Private Sub mnuP75_Click()
    Call Zoom(1.75)
End Sub

Private Sub mnuPencil_Click()
    curTools = Tools.sPencil
End Sub

Private Sub mnuPolygon_Click()
    curTools = Tools.sPolygon
End Sub

Private Sub mnuRect_Click()
    curTools = Tools.sRect
End Sub






Private Sub mnuRepCol_Click()

End Sub

Private Sub mnuSave_Click()

End Sub

Private Sub mnuStar_Click()
    curTools = Tools.sStar
End Sub

Private Sub mnuStLine_Click()
    curTools = Tools.sStLine
End Sub

Private Sub mnuText_Click()
    curTools = Tools.sText
    frmText.Show
End Sub

Private Sub mnuUDefPolygon_Click()
    curTools = Tools.sUDefPolygon
End Sub




Private Sub mnuVertLine_Click()
    curTools = Tools.sVertLine
End Sub


Private Sub picBack_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        picMain.Width = x
        picMain.Height = y
        Call ResizePicBoxes
    End If
End Sub


Private Sub picBCol_Click()
    On Error Resume Next
    
    comDiag.CancelError = True
    comDiag.ShowColor
    If Not Err Then
        picBCol.BackColor = comDiag.Color
        tColors.lBCol = comDiag.Color
    End If
End Sub

Private Sub picFCol_Click()
    On Error Resume Next
    
    comDiag.CancelError = True
    comDiag.ShowColor
    If Not Err Then
        picFCol.BackColor = comDiag.Color
        tColors.lFCol = comDiag.Color
    End If
End Sub

Private Sub picMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim sTmp As String
    Dim points(2) As cPoint, cCount As Double, cDetails As Double
    Dim col As Long, r As Long, a As Double, u As Long, v As Long
    
    sX = x
    sY = y
    If Button = 1 Then
        
        If curTools = Tools.sCircle Or curTools = Tools.sStLine Or curTools = Tools.sFCircle Or curTools = Tools.sFRect Or curTools = Tools.sRect Then
            picMain.PSet (sX, sY), vbBlack
            Exit Sub
        End If
        
        If curTools = Tools.sPolygon Then
            If Not stat Then
                stat = True
                curX = x
                curY = y
            End If
            sX = x
            sY = y
            If Shift = 1 Then
                picMain.Line (wX1, wY1)-(curX, curY), tColors.lFCol
                stat1 = False
                stat = False
                Exit Sub
            End If
            If Not stat1 Then
                picMain.PSet (x, y), tColors.lFCol
                wX1 = x
                wY1 = y
                stat1 = True
            Else
                picMain.Line (wX1, wY1)-(x, y), tColors.lFCol
            End If
            Exit Sub
        End If
        
        If curTools = Tools.sUDefPolygon Then
            upX = x
            upY = y
        End If
        
        If curTools = Tools.sFillRegions Then
            Call Filling(picMain.Point(x, y), propFillStyle, x, y)
            
        End If
        
        If curTools = Tools.sText Then
            picMain.CurrentX = x
            picMain.CurrentY = y
            sTmp = InputBox("Type in the Text!", "SEK - Paint 1.0")
            picMain.Print sTmp
        End If
        
        If curTools = Tools.sHammer Then
            On Error Resume Next
            
            
            r = InputBox("Please type in the radius!  (1-150)", "B閦ier")
            If Err Or r < 0 Or r > 150 Then
                MsgBox "Please type in a number between 1 and 150!", vbCritical, "Error"
                Exit Sub
            End If
            a = ((r / 50) * 360)
        
            For i = 0 To a
                points(0).cX = r * Cos(i) + x
                points(0).cY = r * Sin(i) + y
                points(1).cX = x
                points(1).cY = y
                points(2).cX = x
                points(2).cY = y
        
                cCount = 0
                cDetails = 1 / (r * 2)
        
                Do
                    col = GetPixel(picMain.hdc, points(0).cX, points(0).cY)
                    u = points(0).cX * (cCount * cCount) + points(1).cX * (2 * cCount * (1 - cCount)) + points(2).cX * ((1 - cCount) * (1 - cCount))
                    v = points(0).cY * (cCount * cCount) + points(1).cY * (2 * cCount * (1 - cCount)) + points(2).cY * ((1 - cCount) * (1 - cCount))
                    picMain.PSet (sX, sY), col
                    SetPixel picMain.hdc, u, v, col
                    cCount = cCount + cDetails
                Loop While cCount <= 1
                          Next i
         
        End If
        
        If curTools = Tools.sReplaceColor Then
            If FirstChoose Then
                tmpCol1 = picMain.Point(x, y)
                FirstChoose = False
            Else
                tmpCol2 = picMain.Point(x, y)
                
            End If
        End If
    End If
End Sub

Private Sub picMain_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim tmpbX As Integer, tmpbY As Integer
  
    If Button = 1 Then
        Select Case curTools
            Case Tools.sPencil:
                picMain.Line (sX, sY)-(x, y), tColors.lFCol
                sX = x
                sY = y
                
            Case Tools.sStar:
                picMain.Line (sX, sY)-(x, y), tColors.lFCol
            
            Case Tools.sErase:
                picMain.Line (sX, sY)-(x, y), vbWhite
                sX = x
                sY = y
            
            Case Tools.sCross:
                picMain.Line (x - 5, y - 5)-(x + 5, y + 5), tColors.lFCol
                picMain.Line (x + 5, y - 5)-(x - 5, y + 5), tColors.lFCol
            
            Case Tools.sCrossND:
                picMain.Line (x - 5, y)-(x + 5, y), tColors.lFCol
                picMain.Line (x, y - 5)-(x, y + 5), tColors.lFCol
                
            Case Tools.sDiagLineLR:
                picMain.Line (x, y)-(x - 5, y + 5), tColors.lFCol
                
            Case Tools.sDiagLineRL:
                picMain.Line (x, y)-(x + 5, y + 5), tColors.lFCol
            
            Case Tools.sUDefPolygon:
                picMain.Line (sX, sY)-(x, y), tColors.lFCol
                sX = x
                sY = y
            
            Case Tools.sHorzLine:
                picMain.Line (x - 5, y)-(x + 5, y), tColors.lFCol
                
            Case Tools.sVertLine:
                picMain.Line (x, y - 5)-(x, y + 5), tColors.lFCol
        
            Case Tools.sBrush:
                For i = 0 To 25
                    tmpbX = Int(Rnd * 14 - 7)
                    tmpbY = Int(Rnd * 14 - 7)
                    picMain.PSet (x + tmpbX, y + tmpbY), tColors.lFCol
                Next i
            
        End Select
    End If
    wX = x
    wY = y
End Sub

Private Sub picMain_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim r
    
    If Button = 1 Then
        If curTools = Tools.sCircle Then
            r = Sqr((sX - x) * (sX - x) + (sY - y) * (sY - y))
            picMain.Circle (sX, sY), r, tColors.lFCol
            picMain.PSet (sX, sY), picMain.Point(sX + 1, sY)
            
        ElseIf curTools = Tools.sRect Then
            picMain.Line (sX, sY)-(x, y), tColors.lFCol, B
            
        ElseIf curTools = Tools.sStLine Then
            picMain.Line (sX, sY)-(x, y), tColors.lFCol
        
        ElseIf curTools = Tools.sFCircle Then
            picMain.FillStyle = 0
            picMain.FillColor = tColors.lBCol
            r = Sqr((sX - x) * (sX - x) + (sY - y) * (sY - y))
            picMain.Circle (sX, sY), r, tColors.lFCol
            picMain.FillStyle = 1
        
        ElseIf curTools = Tools.sFRect Then
            picMain.Line (sX, sY)-(x, y), tColors.lBCol, BF
            
        ElseIf curTools = Tools.sPolygon Then
            picMain.Line (sX, sY)-(wX, wY), tColors.lFCol
            wX1 = x
            wY1 = y
            
        ElseIf curTools = Tools.sUDefPolygon Then
            picMain.Line (upX, upY)-(x, y), tColors.lFCol

        End If
        
    End If
End Sub

Private Sub scrHorz_Change()
    picMain.Left = -scrHorz.Value
End Sub

Private Sub scrVert_Change()
    picMain.Top = -scrVert.Value
End Sub
Private Sub mnuExit_Click()
    End
End Sub


Private Sub mnuBlur_Click()
    
    Call Save
    Call PrepareImg
    For i = 1 To cX - 1
        For j = 1 To cY - 1
            r = Abs(larrCol(0, i - 1, j - 1) + larrCol(0, i, j - 1) + larrCol(0, i + 1, j - 1) + larrCol(0, i - 1, j) + larrCol(0, i, j) + larrCol(0, i + 1, j) + larrCol(0, i - 1, j + 1) + larrCol(0, i, j + 1) + larrCol(0, i + 1, j + 1))
            g = Abs(larrCol(1, i - 1, j - 1) + larrCol(1, i, j - 1) + larrCol(1, i + 1, j - 1) + larrCol(1, i - 1, j) + larrCol(1, i, j) + larrCol(1, i + 1, j) + larrCol(1, i - 1, j + 1) + larrCol(1, i, j + 1) + larrCol(1, i + 1, j + 1))
            b = Abs(larrCol(2, i - 1, j - 1) + larrCol(2, i, j - 1) + larrCol(2, i + 1, j - 1) + larrCol(2, i - 1, j) + larrCol(2, i, j) + larrCol(2, i + 1, j) + larrCol(2, i - 1, j + 1) + larrCol(2, i, j + 1) + larrCol(2, i + 1, j + 1))
            SetPixel picMain.hdc, i, j, RGB(r / 10, g / 10, b / 10)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub