frmmain.frm

VB图像编辑程序

    
    On Error GoTo Fa
    
    With picBack
        .Top = 8
        .Left = 8
        .Width = frmMain.ScaleWidth - 28
        .Height = frmMain.ScaleHeight - 60
    End With
    With scrHorz
        .Left = 8
        .Top = 10 + picBack.ScaleHeight
        .Width = picBack.ScaleWidth + 3
    End With
    With scrVert
        .Left = 8 + picBack.ScaleWidth
        .Top = 8
        .Height = picBack.ScaleHeight + 3
    End With
    With pg1
        .Top = scrHorz.Top + 20
        .Width = picBack.ScaleWidth + 17
    End With
    With lblCoords
        .Left = 8
        .Top = pg1.Top + pg1.Height + 1
    End With
    With picBCol
        .Left = frmMain.ScaleWidth - 65
        .Top = frmMain.ScaleHeight - 16
    End With
    With picFCol
        .Left = frmMain.ScaleWidth - 33
        .Top = frmMain.ScaleHeight - 16
    End With
    fratemp.Width = frmMain.ScaleWidth
Fa:

End Sub

Private Sub mnuAbout_Click()
    MsgBox "Made by Stephan Kirchmaier in Y2K" & vbCr & "Please vote for me ;-)", vbInformation, "About"
End Sub

Private Sub mnuBaW_Click()
    Dim col As Long
    
    Call Save
    For i = 0 To picMain.Width
        For j = 0 To picMain.Height
            col = GetPixel(picMain.hdc, i, j)
            r = col Mod 256
            g = (col Mod 256) \ 256
            b = col \ 256 \ 256
            
            If r < 200 And g < 200 And b < 200 Then
                col = vbBlack
            Else
                col = vbWhite
            End If
            SetPixel picMain.hdc, i, j, col
        Next j
        pg1.Value = i * 100 \ (picMain.Width - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
End Sub

Private Sub mnuBrush_Click()
    curTools = Tools.sBrush
End Sub

Private Sub mnuCircle_Click()
    curTools = Tools.sCircle
End Sub

Private Sub mnuComic_Click()
    Dim col As Long
    
    Call Save
    For i = 0 To picMain.Width
        For j = 0 To picMain.Height
            col = GetPixel(picMain.hdc, i, j)
            r = Abs(col Mod 256)
            g = Abs((col \ 256) Mod 256)
            b = Abs(col \ 256 \ 256)
            r = Abs(r * (g - b + g + r)) / 256
            g = Abs(r * (b - g + b + r)) / 256
            b = Abs(g * (b - g + b + r)) / 256
            col = RGB(r, g, b)
            r = Abs(col Mod 256)
            g = Abs((col \ 256) Mod 256)
            b = Abs(col \ 256 \ 256)
            r = (r + g + b) / 3
            col = RGB(r, r, r)
            SetPixel picMain.hdc, i, j, col
        Next j
        pg1.Value = i * 100 \ (picMain.Width - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
    
End Sub

Private Sub mnuCross_Click()
    curTools = Tools.sCross
End Sub

Private Sub mnuCrossND_Click()
    curTools = Tools.sCrossND
End Sub

Private Sub mnuDFilled_Click()
    picMain.DrawStyle = 0
End Sub

Private Sub mnuDiagLineLR_Click()
    curTools = Tools.sDiagLineLR
End Sub

Private Sub mnuDiagLineRL_Click()
    curTools = Tools.sDiagLineRL
End Sub

Private Sub mnuDLine_Click()
    picMain.DrawStyle = 1
End Sub

Private Sub mnuDLinPoint_Click()
    picMain.DrawStyle = 3
End Sub

Private Sub mnuDLinPointPt_Click()
    picMain.DrawStyle = 4
End Sub

Private Sub mnuDPoint_Click()
    picMain.DrawStyle = 2
End Sub

Private Sub mnuErase_Click()
    curTools = Tools.sErase
End Sub

Private Sub mnuFCircle_Click()
    curTools = Tools.sFCircle
End Sub

Private Sub mnuFCross_Click()
    propFillStyle = 6
End Sub

Private Sub mnuFDiagCross_Click()
    propFillStyle = 7
End Sub

Private Sub mnuFDiagonalLR_Click()
    propFillStyle = 5
End Sub

Private Sub mnuFDiagonalRL_Click()
    propFillStyle = 4
End Sub

Private Sub mnuFHorzLine_Click()
    propFillStyle = 2
End Sub

Private Sub mnuFilled_Click()
    propFillStyle = 0
End Sub

Private Sub mnuFillReg_Click()
    curTools = Tools.sFillRegions
End Sub

Private Sub mnuFlip1_Click()
    Call Save
    Call PrepFlip
    
    picMain.PaintPicture picFlip.Picture, 0, picMain.ScaleHeight - 1, picMain.ScaleWidth, -picMain.ScaleHeight, , , , , vbSrcCopy

End Sub

Private Sub mnuFlip2_Click()
    Call Save
    
    Call PrepFlip
    picMain.PaintPicture picFlip.Picture, picMain.ScaleWidth - 1, 0, -picMain.ScaleWidth, picMain.ScaleHeight, , , , , vbSrcCopy

End Sub

Private Sub mnuFlip3_Click()
    Call Save
    Call PrepFlip
    picMain.PaintPicture picFlip.Picture, picMain.ScaleWidth - 1, picMain.ScaleHeight - 1, -picMain.ScaleWidth, -picMain.ScaleHeight, , , , , vbSrcCopy
    
End Sub

Private Sub mnuFRect_Click()
    curTools = Tools.sFRect
End Sub

Private Sub mnuFVertLine_Click()
    propFillStyle = 3
End Sub

Private Sub mnuHammer_Click()
    curTools = Tools.sHammer
End Sub

Private Sub mnuHeat_Click()
    Dim bNo As Boolean
    Dim TColW As Long
    
    Call Save
    For i = 0 To cX
        For j = 0 To cY
            TColW = GetPixel(picMain.hdc, i, j)
            r = TColW Mod 256
            g = (TColW \ 256) Mod 256
            b = TColW \ 256 \ 256
            
            r = Abs(((r ^ 2) / ((b + g) + 10)) * 128)
            b = Abs(((b ^ 2) / ((g + r) + 10)) * 128)
            g = Abs(((g ^ 2) / ((r + b) + 10)) * 128)
nOK:
                If r > 32767 Then
                    r = r - 32767
                ElseIf g > 32767 Then
                    g = g - 32767
                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 mnuPrint_Click()
    frmPrint.Show
End Sub

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

Private Sub mnuRects_Click()
    Dim tColR1 As Long, tColR2 As Long, tColR3 As Long, tColR4 As Long, tColR5 As Long
    
    Call Save
    For i = 0 To cX
        For j = 0 To cY
            tColR1 = GetPixel(picMain.hdc, i, j)
            tColR2 = GetPixel(picMain.hdc, i + 1, j)
            tColR3 = GetPixel(picMain.hdc, i - 1, j)
            tColR4 = GetPixel(picMain.hdc, i, j + 1)
            tColR5 = GetPixel(picMain.hdc, i, j - 1)
            SetPixel picMain.hdc, i, j, (Abs(tColR1) - (Abs(tColR2 + tColR3 + tColR4 + tColR5) / 4))
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
End Sub

Private Sub mnuRepCol_Click()
    Call Save
    MsgBox "At first, you must choose the color you want to replace on the picture. Then you must choose the ""replacing-color"".", vbInformation, "SEK - Paint 1.0"
    FirstChoose = True
    curTools = Tools.sReplaceColor
End Sub

Private Sub mnuSave_Click()
    Dim sFName As String
    
    On Error Resume Next
    comDiag.CancelError = True
    comDiag.Filter = "*.bmp"
    comDiag.ShowSave
    If Err Then Exit Sub
    sFName = comDiag.filename
    
    If FileExist(sFName) Then
        MsgBox "The File already exist!", vbCritical, "Error"
        Exit Sub
    End If
    
    If (LCase$(Right$(sFName, 4)) = ".bmp") Then
        SavePicture picMain.Image, sFName
    Else
        sFName = sFName & ".bmp"
        SavePicture picMain.Image, sFName
    End If
    
End Sub

Private Sub mnuSetDW_Click()
    Dim iCool As Integer
    
    iCool = InputBox("Type in the desired Draw Width!", "SEK - Paint 1.0", picMain.DrawWidth)
    If Not IsNumeric(iCool) Then
        MsgBox "You must type in a valid number!", vbCritical, "Error"
        Exit Sub
    End If
    picMain.DrawWidth = iCool
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 mnuUndo_Click()
    Call UndoFilters
End Sub

Private Sub mnuUndoEffects_Click()
    Call UndoFilters
End Sub

Private Sub mnuUndoTools_Click()
    On Error Resume Next
    
    Set picMain.Picture = picUndoTools.Image
End Sub

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

Private Sub mnuWave_Click()
    Dim i As Long, j As Long
    Dim sw As Long, sh As Long
    Dim coli() As Long, posy() As Double
    
    Call Save
    sw = picMain.Width
    sh = picMain.Height
    
    ReDim coli(sw, sh)
    ReDim posy(sw, sh)
    
    For i = 0 To sw
        For j = 0 To sh
            coli(i, j) = GetPixel(picMain.hdc, i, j)
            posy(i, j) = Sin(i) * 6 + (j - 3)
        Next j
        pg1.Value = i * 100 \ (sw - 1)
    Next i
    For i = 0 To sw
        For j = 0 To sh
            picMain.PSet (i, posy(i, j)), coli(i, j)
        Next j
        pg1.Value = i * 100 \ (sw - 1)
    Next i
    pg1.Value = 0
    
End Sub

Private Sub picBack_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then