home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / ScreenGrab209576102001.psc / ScreenGrabForm1.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2001-06-09  |  8.5 KB  |  230 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    AutoRedraw      =   -1  'True
  4.    BorderStyle     =   0  'None
  5.    Caption         =   "Form1"
  6.    ClientHeight    =   3195
  7.    ClientLeft      =   0
  8.    ClientTop       =   0
  9.    ClientWidth     =   4680
  10.    DrawMode        =   6  'Mask Pen Not
  11.    LinkTopic       =   "Form1"
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    MousePointer    =   2  'Cross
  15.    ScaleHeight     =   213
  16.    ScaleMode       =   3  'Pixel
  17.    ScaleWidth      =   312
  18.    ShowInTaskbar   =   0   'False
  19.    StartUpPosition =   3  'Windows Default
  20.    WindowState     =   2  'Maximized
  21.    Begin VB.Label Label1 
  22.       AutoSize        =   -1  'True
  23.       Caption         =   "Label1"
  24.       Height          =   195
  25.       Left            =   120
  26.       TabIndex        =   0
  27.       Top             =   360
  28.       Visible         =   0   'False
  29.       Width           =   480
  30.    End
  31. Attribute VB_Name = "Form1"
  32. Attribute VB_GlobalNameSpace = False
  33. Attribute VB_Creatable = False
  34. Attribute VB_PredeclaredId = True
  35. Attribute VB_Exposed = False
  36. Option Explicit
  37. Dim xStart As Single, yStart As Single, bMouseDown As Boolean
  38. Dim xs, ys
  39. Private Sub Form_Unload(Cancel As Integer)
  40.     MDIForm1.Visible = True
  41. End Sub
  42. Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  43.     'start of mouse down coords xStart:yStart
  44.     xStart = x: yStart = y
  45.     bMouseDown = True
  46. End Sub
  47. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  48.     On Error Resume Next
  49.     If bMouseDown = True Then
  50.         movelines x, y
  51.         
  52.         xs = x: ys = y
  53.         Dim xbig, ybig
  54.         'place label info at bottom right;get biggest coords
  55.         xbig = max(xStart, xs)
  56.         ybig = max(yStart, ys)
  57.         
  58.         Label1.Visible = False
  59.         Label1.left = xbig + 4: Label1.top = ybig + 4
  60.         'who saves a 1 pixel line? same start and new x/y pos makes width/height =0
  61.         Dim grabwidth As Long, grabheight As Long
  62.         If xStart = x Then
  63.             grabwidth = 0
  64.         Else
  65.             grabwidth = Abs(xStart - x) + 1
  66.         End If
  67.         
  68.         If yStart = y Then
  69.             grabheight = 0
  70.         Else
  71.             grabheight = Abs(yStart - y) + 1
  72.         End If
  73.         
  74.         Label1.Caption = "X=" & Format$(x, "0000") & vbCrLf & "Y=" & Format$(y, "0000") & vbCrLf & "Width=" & Format$(grabwidth, "0000") _
  75.            & vbCrLf & "Height=" & Format$(grabheight, "0000")
  76.         '
  77.         Label1.Visible = True
  78.     Else
  79.         'show  coords in label
  80.         Label1.Visible = True
  81.         'move label to left if off screen right
  82.         If x + 4 + Label1.width > Screen.width / Screen.TwipsPerPixelX Then
  83.             'MsgBox "labe3l off"
  84.             Label1.left = x - (Label1.width + 4)
  85.         Else
  86.             Label1.left = x + 4
  87.         End If
  88.         'move label up if off bottom of screen
  89.         If y + 4 + Label1.Height > Screen.Height / Screen.TwipsPerPixelY Then
  90.             'MsgBox "labe3l off"
  91.             Label1.top = y - (Label1.Height + 4)
  92.         Else
  93.             Label1.top = y + 4
  94.         End If
  95.         'Label1.top = y + 4
  96.         
  97.         'just shows xy coords
  98.         Label1.Caption = "X=" & Format$(x, "0000") & vbCrLf & "Y=" & Format$(y, "0000")
  99.         
  100.     End If
  101.     'Form1.Caption = "X= " & Format$(X, "0000") & ": Y= " & Format$(Y, "0000")
  102.    ' Form1.Caption = Format$(x, "0000") & ":" & Format$(y, "0000") & ":" & Format$(Abs(x - xStart), "0000") _
  103.     '   & ":" & Format$(Abs(y - yStart), "0000")
  104. End Sub
  105. Private Sub movelines(x As Single, y As Single)
  106.     If Not (xs = 0 And ys = 0) Then
  107.         'delete previous
  108.         '''-Form1.Line (xStart, yStart)-(xs - 1, ys - 1), , B
  109.         Form1.Line (xStart, yStart)-(xs, ys), , B
  110.     End If
  111.     'draw selection square in invert drawmode
  112.     '''-Form1.Line (xStart, yStart)-(x - 1, y - 1), , B
  113.     Form1.Line (xStart, yStart)-(x, y), , B
  114. End Sub
  115. Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  116.     On Error GoTo errMouseUp
  117.     ''Shape1.Visible = False
  118.     Label1.Visible = False
  119.     bMouseDown = False
  120.     ''Form1.Line (xStart, yStart)-(xs, ys), , B
  121.     '''Form1.Line (xStart, yStart)-(xs, ys), , B
  122.     'delete previous
  123.     Form1.Line (xStart, yStart)-(xs, ys), , B
  124.     'Form1.Line (xs, 0)-(xs, ys - 10) '(10 + Shape1.Width))
  125.     Dim xwidth, yheight
  126.     Dim startx, starty
  127.     Dim endx, endy
  128.     xwidth = Abs(xStart - xs)
  129.     yheight = Abs(yStart - ys)
  130.     If debugme = True Then MsgBox "xStart = " & xStart & "yStart= " & yStart
  131.     If debugme = True Then MsgBox xwidth & ":" & yheight
  132.     'if mouse start x/y positions = new x/y positions
  133.     If xStart = x And yStart = y Then
  134.         If debugme = True Then MsgBox "xStart =x and yStart=y"
  135.         xs = 0: ys = 0
  136.         Unload Me
  137.         'stops rest of code executing
  138.         Exit Sub
  139.     End If
  140.     'get new form to blit to
  141.     If xwidth <= 0 Or yheight <= 0 Then
  142.         MsgBox "No screen grab width or height"
  143.         'possible bug; not initialised variables;9 june 2001
  144.         xs = 0: ys = 0
  145.         Exit Sub
  146.     End If
  147.     'create new child forms of MDI
  148.     Dim frmChild As New frmChild
  149.     frmChild.Show
  150.     If MDIForm1.ActiveForm Is Nothing Then
  151.     'somehow we have no child form
  152.         MsgBox "need form to blit to"
  153.         Exit Sub
  154.     End If
  155.     frmChild.Picture1.Visible = False
  156.     With MDIForm1.ActiveForm.Picture1
  157.         .BackColor = &HFF00FF
  158.         .Cls
  159.         ''
  160.         '.Width = xwidth + 150
  161.         ''.Width = Screen.TwipsPerPixelX * (xwidth + 8)
  162.         .width = xwidth + 1
  163.         If debugme = True Then MsgBox .width
  164.         '''.Width = xwidth 'Shape1.Width
  165.         ''.Height = yheight + 150 'Shape1.Height
  166.         ''.Height = Screen.TwipsPerPixelY * (yheight + 26)
  167.         .Height = yheight + 1
  168.         If debugme = True Then MsgBox .Height
  169.         'systemmetrics 26= caption and menubar;8= 3d borders of form
  170.         '
  171.         MDIForm1.ActiveForm.width = Screen.TwipsPerPixelX * (xwidth + 8 + 2)
  172.         MDIForm1.ActiveForm.Height = Screen.TwipsPerPixelY * (yheight + 26 + 2)
  173.         ''    '     '
  174.         ''get the correct coords;swap if need be
  175.         'draw from top left corner down to right
  176.         If xStart <= xs And yStart <= ys Then
  177.             startx = xStart: starty = yStart
  178.         End If
  179.         ''draw from bottom right to top left
  180.         If xStart > xs And yStart > ys Then
  181.             startx = xs: starty = ys
  182.         End If
  183.         ''from bottom left to top right
  184.         If xStart < xs And yStart > ys Then
  185.             startx = xStart
  186.             starty = yStart - yheight
  187.         End If
  188.         ''from bottom right to top left
  189.         If xStart > xs And yStart < ys Then
  190.             startx = xStart - xwidth
  191.             starty = yStart
  192.         End If
  193.         '''If xStart > xs Then
  194.         'copy from grab screen form (form1) to picture1 on activeform(frmchild)
  195.         If xwidth > 0 And yheight > 0 Then
  196.             MDIForm1.ActiveForm.Picture1.PaintPicture Form1.Picture, 0, 0, , , startx, starty, xwidth + 1, yheight + 1
  197.         End If
  198.         .Visible = True
  199.     End With
  200.     xs = 0: ys = 0
  201.     'convert picture
  202.     MDIForm1.ActiveForm.Picture1.Picture = MDIForm1.ActiveForm.Picture1.Image
  203.     frmChild.Picture1.Visible = True
  204.     Unload Me
  205.     Exit Sub
  206. errMouseUp:
  207.     xs = 0: ys = 0
  208.     MsgBox Err.Description & ": Error number " & Err.Number
  209. End Sub
  210. 'Private Sub savDesktop()
  211. 'Dim sI As Strid MPrivate Sub savDeskto= xs: starty sBkto=Ands"00vFors"00vFors"00vFors"00vFors"00vFors"00vFors"00vFors"00vFowrom grab screYLpformors"00vrgErr.Number
  212. lgFt ys),crU FormtopA   If xwidth > 0 And yheighSFors"00vFors"00vFowrom grab screYLpformors"0)
  213. Gn"b sy = yStart
  214.         End If
  215.         ''draw B
  216.     '''Form1.L Err.4.l 'Form     a05GbEa05GbEsavDeske(trs"00vFor;x3Sim stais = 0: ys =ogowr im irs"'2ormtopAors"00vFors"00vFors"00vFors"age
  217.     frnp5w20vrgErr.Number
  218. lgFt ys),crU Formtop9Ober
  219. I aaaaaaaaaaaaaaaaaaaaaw B
  220. aglgFt ys),crU Fys),crU Formp9Ob(Aax= rm.Picture1.Image
  221.     frmChild.Picture1.Visible = True
  222.   * (yheighten.Twip ys =sc0s =sc0s =sc-Ricture1.iO=sc0s =sc0s =sc-Rictxbue
  223. p.iO=sc0s =>rty sBkto=Ands"00vFors"00vFors"00vFors"00vFors    r.4.l 'FSsIgFt yTa IfB
  224. aglgFwd"00vFowrom grab screYLpformors"0)
  225. Gn"/B
  226. aglgFwd"00vFowrom grnvchild) pe
  227. ure1.IlI aaaaaaaPllllicturne (xStart, 1
  228. s"00vFors"00vF/ B
  229. 00vFors"00vFors""00vF/ = True
  230.