Mit Zoom zeichnen


Mit diesem Script haben Sie die Möglichkeit, beliebige Bilder in einem Image-Bildfeld aufzuzoomen und im gezoomten Zustand zu bearbeiten. Da das Image-Bildfeld keine Daten zurückgibt, können Sie zoomen ohne die Systemresourcen auszuschöpfen. Der Trick ist: gezeichnet wird in der kleineren PictureBox und das Image wird ständig aktualisiert.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Projekt - Download
 

 
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code
Option Explicit
 
Private Declare Function ExtFloodFill Lib "gdi32" ( _
       ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, _
       ByVal crColor As Long, ByVal wFillType As Long) As Long
 
Private Declare Function SetPixel Lib "gdi32" ( _
       ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, _
       ByVal crColor As Long) As Long
 
Public LastX!, LastY!
Public UnDoX!, UnDoY!
Dim Col&, Col2&
Dim Current%, DrFill As Integer

Private Sub Command1_Click(Index As Integer) Current% = Index If Index = 3 Or Index = 5 Then shpArea.Visible = False Else shpArea.Visible = True End If Image1.MousePointer = 2 End Sub
Private Sub mnuOpen_Click() Dim Datei$, fPath$ With Dialog1 .DialogTitle = "Datei öffnen" 'Dateieintrag löschen .FileName = "" 'Suchmaske .Filter = "Alle Bilddateien " & _ "|*.bmp;*.wmf;*.ico;*.jpg;*.jpe;*.gif;*.cur;" & _ " *.dib;*.jpe|Windows Bitmap" & _ " " & _ "(*.BMP)| *.bmp| Windows Metafile" & _ " " & _ "(*.WMF)| *.wmf| Windows Icons - Symbole" & _ " " & _ "(*.ICO)| *.ico|JPEG File Interchange" & _ " " & _ "(*.JPG)| *.jpg|JPEG WebFile" & _ " " & _ "(*.JPE)| *.jpe|CompuServe Gif-File" & _ " " & _ "(*.GIF)| *.gif| PC Paint Brush" & _ " " & _ "(*.PCX)| *.pcx| DIB-Bitmap" & _ " " & _ "(*.DIB)| *.dib| Alle Dateien" & _ " " & _ "(* . *)| *.*" 'Filterindex .FilterIndex = 1 'Flags setzen: Explorer-Dialog mit langen Dateinamen .Flags = cdlOFNCreatePrompt And cdlOFNPathMustExist _ And cdlOFNExplorer 'And cdlOFNLongFileNames 'Datei öffnen .ShowOpen Datei$ = .FileName End With 'Ergebnis der Dateianwahl ausgeben Picture1.Picture = LoadPicture(Datei$) Image1.Picture = Picture1.Image Image1.Refresh fPath = DirName(Datei$) If Right$(fPath, 1) <> "\" Then fPath = fPath + "\" File1.Path = fPath Text3.Text = fPath End Sub
'Alles ScaleMode = 3, Pixel Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim tPosA As Long, tPosB As Long, i& If Button = 1 Then Picture1.ForeColor = Label1.BackColor Col = Label1.BackColor Col2 = vbGreen ElseIf Button = 2 Then Picture1.ForeColor = Label2.BackColor Col = Label2.BackColor Col2 = vbYellow End If shpArea.FillColor = Col Picture1.AutoRedraw = True 'Wichtig Select Case Current Case 0 Picture1.DrawWidth = 1 'Zeichenkoordinaten werden als Anfangskoordinaten 'für die nächste Zeichenfunktion verwendet LastX! = X LastY! = Y Case 1, 2 Picture1.DrawWidth = 5 LastX! = X LastY! = Y Picture1.FontTransparent = False If Shift Then DrFill = 0 Else DrFill = 1 Case 3 'Füllen Picture1.FontTransparent = False Picture1.FillStyle = 0 Picture1.FillColor = Col ExtFloodFill Picture1.hDc, X, Y, Picture1.Point(X, Y), 1 Picture1.FontTransparent = True Picture1.FillStyle = 1 Case 4 'Spray If Button = 1 Or Button = 2 Then For i = 0 To 25 tPosA = Int(Rnd * 14 - 7) tPosB = Int(Rnd * 14 - 7) SetPixel Picture1.hDc, X + tPosA, Y + tPosB, Col Next i Picture1.Refresh End If Case 5 'Farbsonde If Button = vbLeftButton Then Label1.BackColor = Picture1.Point(X, Y) ElseIf Button = vbRightButton Then Label2.BackColor = Picture1.Point(X, Y) End If Current = 10 End Select End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Picture1_MouseDown Button, Shift, _ ((X / 8) / Screen.TwipsPerPixelX) - 0.5, _ ((Y / 8) / Screen.TwipsPerPixelY) - 0.5 'PicFrame.Border Image1.Picture = Picture1.Image Image1.Refresh End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim tPosA As Long, tPosB As Long, i& If Button = 1 Or Button = 2 Then Select Case Current% Case 0 'Freihand Picture1.Line (LastX!, LastY!)-(X, Y) LastX! = X LastY! = Y Case 1 If DrFill = 1 Then 'Rechteck 'nicht gefüllt (transparent) Picture1.FillStyle = 1 If Button = 1 Or Button = 2 Then 'invertiert zeichnen Picture1.DrawMode = 6 If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B End If Picture1.Line (LastX!, LastY!)-(X, Y), , B UnDoX! = X! UnDoY! = Y! End If Else 'gefüllt Picture1.FillStyle = 0 If Button = 1 Or Button = 2 Then 'invertiert zeichnen Picture1.DrawMode = 6 If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B End If Picture1.Line (LastX!, LastY!)-(X, Y), , B UnDoX! = X! UnDoY! = Y! End If End If Case 2 'Kreis If DrFill = 1 Then 'nicht gefüllt (transparent) Picture1.FillStyle = 1 'invertiert zeichnen Picture1.DrawMode = 6 If Button = 1 Or Button = 2 Then If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Circle (LastX!, LastY!), Radius(LastX!, _ LastY!, UnDoX!, UnDoY!) End If Picture1.Circle (LastX!, LastY!), _ Radius(LastX!, LastY!, X, Y) UnDoX! = X! UnDoY! = Y! End If Else 'gefüllt bzw. Muster Picture1.FillStyle = 0 'invertiert zeichnen If Button = 1 Or Button = 2 Then Picture1.DrawMode = 6 If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Circle (LastX!, LastY!), _ Radius(LastX!, LastY!, UnDoX!, UnDoY!) End If Picture1.Circle (LastX!, LastY!), _ Radius(LastX!, LastY!, X, Y) UnDoX! = X! UnDoY! = Y! End If End If Case 4 'Spray If Button = 1 Or Button = 2 Then For i = 0 To 25 tPosA = Int(Rnd * 14 - 7) tPosB = Int(Rnd * 14 - 7) SetPixel Picture1.hDc, X + tPosA, Y + tPosB, Col Next i Picture1.Refresh End If End Select End If End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim X12%, Y12% X12 = X / Screen.TwipsPerPixelX: Y12 = Y / Screen.TwipsPerPixelY AdjustToPixel X12, Y12 shpArea.Width = 9: shpArea.Height = 9 shpArea.Left = X12: shpArea.Top = Y12 If Button = 1 Or Button = 2 Then Picture1_MouseMove Button, Shift, _ ((X / 8) / Screen.TwipsPerPixelX) - 0.5, _ ((Y / 8) / Screen.TwipsPerPixelY) - 0.5 Image1.Picture = Picture1.Image 'Picture Image1.Refresh End If Text1.Text = (X \ 8) \ Screen.TwipsPerPixelX Text2.Text = (Y \ 8) \ Screen.TwipsPerPixelY End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Select Case Current% Case 0 'Freihand If Button = 1 Or Button = 2 Then Picture1.PSet (X, Y), Col End If Case 1 'Quadrat If DrFill = 1 Then Picture1.FillStyle = 1 'Zeichenfarbe Picture1.DrawMode = 13 If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B End If Picture1.Line (LastX!, LastY!)-(X, Y), , B UnDoX! = 0 UnDoY! = 0 Else 'Gefüllt Picture1.DrawMode = 13 If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Line (LastX!, LastY!)-(UnDoX!, UnDoY!), , B End If 'Füllfarbe für Zeichenfunktionen Picture1.FillColor = Col2 Picture1.FillStyle = 0 Picture1.Line (LastX!, LastY!)-(X, Y), , B UnDoX! = 0 UnDoY! = 0 End If Case 2 'Kreis If DrFill = 1 Then Picture1.FillStyle = 1 'Zeichenfarbe Picture1.DrawMode = 13 If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Circle (LastX!, LastY!), _ Radius(LastX!, LastY!, UnDoX!, UnDoY!) End If Picture1.Circle (LastX!, LastY!), _ Radius(LastX!, LastY!, X, Y) UnDoX! = 0 UnDoY! = 0 Else 'Zeichenfarbe Picture1.DrawMode = 13 If UnDoX! <> 0 And UnDoY! <> 0 Then Picture1.Circle (LastX!, LastY!), _ Radius(LastX!, LastY!, UnDoX!, UnDoY!) End If 'Füllfarbe für Zeichenfunktionen Picture1.FillColor = Col2 Picture1.FillStyle = 0 Picture1.Circle (LastX!, LastY!), _ Radius(LastX!, LastY!, UnDoX!, UnDoY!) UnDoX! = 0 UnDoY! = 0 End If End Select Picture1.Picture = Picture1.Image 'Wichtig Picture1.Refresh 'Wichtig Picture1.AutoRedraw = False 'Wichtig End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Picture1_MouseUp Button, Shift, _ ((X / 8) / Screen.TwipsPerPixelX) - 0.5, _ ((Y / 8) / Screen.TwipsPerPixelY) - 0.5 Image1.Picture = Picture1.Image Image1.Refresh End Sub
Function Radius(X1!, Y1!, X2!, Y2!) As Single 'Radiuswert ermitteln On Error Resume Next Dim A!, B! A! = Abs(X1! - X2!) B! = Abs(Y1! - Y2!) Radius = Sqr(A! * A! + B! * B!) End Function
Private Sub Form_Load() Current% = 10 Picture1.MousePointer = 1 shpArea.BackStyle = 1 shpArea.BorderStyle = 0 shpArea.DrawMode = 13 shpArea.FillStyle = 0 Form_Resize Image1.Picture = Picture1.Image Image1.Refresh End Sub
Private Sub File1_Click() Picture1.Picture = LoadPicture(File1.FileName) Form_Resize Image1.Picture = Picture1.Image Image1.Refresh End Sub
Private Sub Label1_Click() Dim X As Integer Dialog1.CancelError = True Dialog1.Flags = cdlCCRGBInit Or cdlCCFullOpen 'Open color dialog Dialog1.Color = Label1.BackColor Dialog1.ShowColor Label1.BackColor = Dialog1.Color End Sub
Private Sub Label2_Click() Dim X As Integer Dialog1.CancelError = True Dialog1.Flags = cdlCCRGBInit Or cdlCCFullOpen Dialog1.Color = Label2.BackColor Dialog1.ShowColor Label2.BackColor = Dialog1.Color End Sub
Private Sub Form_Resize() Image1.Width = Picture1.Width * 8 Image1.Height = Picture1.Height * 8 End Sub
Function DirName(sPath As String) As String 'Extract DirName (Pfad) Dim iCount As Integer 'If Punkt 4.Stelle von Rechts Then If (Left$(LCase(Right(sPath$, 4)), 1) = ".") Then For iCount = Len(sPath) To 1 Step -1 If Mid$(sPath, iCount, 1) = "\" Then Exit For Next DirName = Left$(sPath, iCount - 1) End If End Function
Public Sub AdjustToPixel(A%, B%) A = (A \ 8) * 8 'Zoom 8 B = (B \ 8) * 8 End Sub
Private Sub Timer1_Timer() Text4.Text = Current End Sub