home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH4 / SRC / REFLECTF.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-01-03  |  14.2 KB  |  452 lines

  1. VERSION 4.00
  2. Begin VB.Form ReflectForm 
  3.    Caption         =   "Reflect"
  4.    ClientHeight    =   4560
  5.    ClientLeft      =   1080
  6.    ClientTop       =   1290
  7.    ClientWidth     =   7680
  8.    Height          =   5250
  9.    Left            =   1020
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   304
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   512
  14.    Top             =   660
  15.    Width           =   7800
  16.    Begin VB.PictureBox ToPict 
  17.       AutoRedraw      =   -1  'True
  18.       BackColor       =   &H00C0C0C0&
  19.       Height          =   4560
  20.       Left            =   3120
  21.       Picture         =   "REFLECTF.frx":0000
  22.       ScaleHeight     =   300
  23.       ScaleMode       =   3  'Pixel
  24.       ScaleWidth      =   300
  25.       TabIndex        =   1
  26.       Top             =   0
  27.       Width           =   4560
  28.    End
  29.    Begin VB.PictureBox FromPict 
  30.       AutoRedraw      =   -1  'True
  31.       BackColor       =   &H00C0C0C0&
  32.       Height          =   3060
  33.       Left            =   0
  34.       Picture         =   "REFLECTF.frx":0446
  35.       ScaleHeight     =   200
  36.       ScaleMode       =   3  'Pixel
  37.       ScaleWidth      =   200
  38.       TabIndex        =   0
  39.       Top             =   0
  40.       Width           =   3060
  41.    End
  42.    Begin MSComDlg.CommonDialog FileDialog 
  43.       Left            =   2520
  44.       Top             =   3120
  45.       _Version        =   65536
  46.       _ExtentX        =   847
  47.       _ExtentY        =   847
  48.       _StockProps     =   0
  49.       CancelError     =   -1  'True
  50.       FontSize        =   7.82965e-39
  51.    End
  52.    Begin VB.Menu mnuFile 
  53.       Caption         =   "&File"
  54.       Begin VB.Menu mnuFileLoad 
  55.          Caption         =   "&Load..."
  56.          Shortcut        =   ^L
  57.       End
  58.       Begin VB.Menu mnuFileSep 
  59.          Caption         =   "-"
  60.       End
  61.       Begin VB.Menu mnuFileExit 
  62.          Caption         =   "E&xit"
  63.       End
  64.    End
  65. Attribute VB_Name = "ReflectForm"
  66. Attribute VB_Creatable = False
  67. Attribute VB_Exposed = False
  68. Option Explicit
  69. Dim SysPalSize As Integer
  70. Dim NumStaticColors As Integer
  71. Dim StaticColor1 As Integer
  72. Dim StaticColor2 As Integer
  73. Dim LogPal As Integer
  74. Dim palentry(0 To 255) As PALETTEENTRY
  75. Dim wid As Long
  76. Dim hgt As Long
  77. Dim bytes() As Byte
  78. ' ************************************************
  79. ' Draw the rotated image.
  80. ' ************************************************
  81. Sub DrawImage()
  82. Const m = 0.5
  83. Const b = 50#
  84.     ' Draw a line where we will reflect.
  85.     FromPict.Line (0, b)- _
  86.         (FromPict.ScaleWidth, _
  87.         m * FromPict.ScaleWidth + b)
  88.     ToPict.Cls
  89.     ReflectPicture FromPict, ToPict, _
  90.         0, 0, _
  91.         FromPict.ScaleWidth - 1, _
  92.         FromPict.ScaleHeight - 1, _
  93.         m, b
  94. End Sub
  95. ' ************************************************
  96. ' Reflect the area fx1 <= x <= fx2,
  97. ' fy1 <= y <= fy2 across the line y = m * x + b.
  98. ' ************************************************
  99. Sub ReflectPicture( _
  100.     ByVal from_pic As Control, ByVal to_pic As Control, _
  101.     ByVal fx1 As Integer, ByVal fy1 As Integer, _
  102.     ByVal fx2 As Integer, ByVal fy2 As Integer, _
  103.     ByVal m As Single, ByVal b As Single)
  104. Dim bm As BITMAP
  105. Dim hbm As Integer
  106. Dim status As Long
  107. Dim from_bytes() As Byte
  108. Dim to_bytes() As Byte
  109. Dim from_wid As Long
  110. Dim from_hgt As Long
  111. Dim to_wid As Long
  112. Dim to_hgt As Long
  113. Dim hyp As Single
  114. Dim sin_theta As Single
  115. Dim cos_theta As Single
  116. Dim tx1 As Single
  117. Dim tx2 As Single
  118. Dim ty1 As Single
  119. Dim ty2 As Single
  120. Dim fx As Single
  121. Dim fy As Single
  122. Dim tx As Single
  123. Dim ty As Single
  124. Dim x As Single
  125. Dim y As Single
  126. Dim ifx As Integer
  127. Dim ify As Integer
  128. Dim dx As Single
  129. Dim dy As Single
  130. Dim c1 As Integer
  131. Dim c2 As Integer
  132. Dim c3 As Integer
  133. Dim c4 As Integer
  134. Dim i1 As Integer
  135. Dim i2 As Integer
  136. Dim clr As Integer
  137.     ' Get from_pic's pixels.
  138.     hbm = from_pic.Image
  139.     status = GetObject(hbm, BITMAP_SIZE, bm)
  140.     from_wid = bm.bmWidthBytes
  141.     from_hgt = bm.bmHeight
  142.     ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1)
  143.     status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0))
  144.     ' Get to_pic's pixels.
  145.     hbm = to_pic.Image
  146.     status = GetObject(hbm, BITMAP_SIZE, bm)
  147.     to_wid = bm.bmWidthBytes
  148.     to_hgt = bm.bmHeight
  149.     ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1)
  150.     status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
  151.     ' Compute the sine and cosine of theta.
  152.     hyp = Sqr(m * m + 1)
  153.     sin_theta = m / hyp
  154.     cos_theta = 1 / hyp
  155.         
  156.     ' Make some bounds for to_pic.
  157.     TransformPoint fx1, fy1, tx1, ty1, b, sin_theta, cos_theta
  158.     tx2 = tx1
  159.     ty2 = ty1
  160.     TransformPoint fx1, fy2, tx, ty, b, sin_theta, cos_theta
  161.     If tx1 > tx Then tx1 = tx
  162.     If ty1 > ty Then ty1 = ty
  163.     If tx2 < tx Then tx2 = tx
  164.     If ty2 < ty Then ty2 = ty
  165.     TransformPoint fx2, fy1, tx, ty, b, sin_theta, cos_theta
  166.     If tx1 > tx Then tx1 = tx
  167.     If ty1 > ty Then ty1 = ty
  168.     If tx2 < tx Then tx2 = tx
  169.     If ty2 < ty Then ty2 = ty
  170.     TransformPoint fx2, fy2, tx, ty, b, sin_theta, cos_theta
  171.     If tx1 > tx Then tx1 = tx
  172.     If ty1 > ty Then ty1 = ty
  173.     If tx2 < tx Then tx2 = tx
  174.     If ty2 < ty Then ty2 = ty
  175.     If tx1 < 1 Then tx1 = 1
  176.     If tx2 < 1 Then tx2 = 1
  177.     If tx1 > to_wid - 1 Then tx1 = to_wid - 1
  178.     If tx2 > to_wid - 1 Then tx2 = to_wid - 1
  179.     If ty1 < 1 Then ty1 = 1
  180.     If ty2 < 1 Then ty2 = 1
  181.     If ty1 > to_hgt - 1 Then ty1 = to_hgt - 1
  182.     If ty2 > to_hgt - 1 Then ty2 = to_hgt - 1
  183.     ' Perform the rotation.
  184.     For ty = ty1 To ty2
  185.         For tx = tx1 To tx2
  186.             ' See where the point came from.
  187.             TransformPoint tx, ty, fx, fy, b, sin_theta, cos_theta
  188.             ' Skip it if any of the four nearest
  189.             ' source pixels lie outside the allowed
  190.             ' source area.
  191.             ify = Int(fy)
  192.             ifx = Int(fx)
  193.             If ifx >= fx1 And ifx < fx2 And _
  194.                ify >= fy1 And ify < fy2 Then
  195.                 ' Interpolate using the four nearest
  196.                 ' pixels in from_pic.
  197.                 dy = fy - ify
  198.                 dx = fx - ifx
  199.                 c1 = palentry(from_bytes(ifx, ify)).peRed
  200.                 c2 = palentry(from_bytes(ifx + 1, ify)).peRed
  201.                 c3 = palentry(from_bytes(ifx, ify + 1)).peRed
  202.                 c4 = palentry(from_bytes(ifx + 1, ify + 1)).peRed
  203.                 ' Interpolate in the Y direction.
  204.                 i1 = c1 * (1 - dy) + c3 * dy
  205.                 i2 = c2 * (1 - dy) + c4 * dy
  206.                 ' Interpolate the results in the X direction.
  207.                 clr = i1 * (1 - dx) + i2 * dx
  208.                 to_bytes(tx, ty) = NearestNonstaticGray(clr)
  209.             End If
  210.         Next tx
  211.     Next ty
  212.     ' Update from_pic.
  213.     status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
  214.     to_pic.Refresh
  215. End Sub
  216. ' ***********************************************
  217. ' Load the control's palette so the non-static
  218. ' colors are grays. Map the logical palette to
  219. ' match the system palette. Convert the image to
  220. ' use the non-static grays.
  221. ' Set the following module global variables.
  222. '   LogPal      Image logical palette handle.
  223. '   palentry()  Image logical palette entries.
  224. '   wid         Width of image.
  225. '   hgt         Height of image.
  226. '   bytes(1 To wid, 1 To hgt)
  227. '               Image pixel values.
  228. ' ***********************************************
  229. Sub MatchGrayPalette(pic As Control)
  230. Dim sys(0 To 255) As PALETTEENTRY
  231. Dim i As Integer
  232. Dim bm As BITMAP
  233. Dim hbm As Integer
  234. Dim status As Long
  235. Dim x As Integer
  236. Dim y As Integer
  237. Dim gray As Single
  238. Dim dgray As Single
  239. Dim c As Integer
  240. Dim clr As Integer
  241.     ' Make sure pic has the foreground palette.
  242.     pic.ZOrder
  243.     i = RealizePalette(pic.hdc)
  244.     DoEvents
  245.     ' Get the system palette entries.
  246.     i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))
  247.         
  248.     ' Get the image pixels.
  249.     hbm = pic.Image
  250.     status = GetObject(hbm, BITMAP_SIZE, bm)
  251.     wid = bm.bmWidthBytes
  252.     hgt = bm.bmHeight
  253.     ReDim bytes(1 To wid, 1 To hgt)
  254.     status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  255.     ' Make the logical palette as big as possible.
  256.     LogPal = pic.Picture.hPal
  257.     If ResizePalette(LogPal, SysPalSize) = 0 Then
  258.         Beep
  259.         MsgBox "Error resizing logical palette.", _
  260.             vbExclamation
  261.         Exit Sub
  262.     End If
  263.     ' Blank the non-static colors.
  264.     For i = 0 To StaticColor1
  265.         palentry(i) = sys(i)
  266.     Next i
  267.     For i = StaticColor1 + 1 To StaticColor2 - 1
  268.         With palentry(i)
  269.             .peRed = 0
  270.             .peGreen = 0
  271.             .peBlue = 0
  272.             .peFlags = PC_NOCOLLAPSE
  273.         End With
  274.     Next i
  275.     For i = StaticColor2 To 255
  276.         palentry(i) = sys(i)
  277.     Next i
  278.     i = SetPaletteEntries(LogPal, 0, SysPalSize, palentry(0))
  279.     ' Insert the non-static grays.
  280.     gray = 0
  281.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  282.     For i = StaticColor1 + 1 To StaticColor2 - 1
  283.         c = gray
  284.         gray = gray + dgray
  285.         With palentry(i)
  286.             .peRed = c
  287.             .peGreen = c
  288.             .peBlue = c
  289.         End With
  290.     Next i
  291.     i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
  292.     ' Recreate the image using the new colors.
  293.     For y = 1 To hgt
  294.         For x = 1 To wid
  295.             clr = bytes(x, y)
  296.             With sys(clr)
  297.                 c = (CInt(.peRed) + .peGreen + .peBlue) / 3
  298.             End With
  299.             bytes(x, y) = NearestNonstaticGray(c)
  300.         Next x
  301.     Next y
  302.     status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  303.     ' Realize the gray palette.
  304.     i = RealizePalette(pic.hdc)
  305.     pic.Refresh
  306. End Sub
  307. ' ************************************************
  308. ' Return the index of the nonstatic gray closest
  309. ' to the given value (assuming the non-static
  310. ' colors are a gray scale created by
  311. ' MatchGrayPalette).
  312. ' ************************************************
  313. Function NearestNonstaticGray(c As Integer) As Integer
  314. Dim dgray As Single
  315.     If c < 0 Then
  316.         c = 0
  317.     ElseIf c > 255 Then
  318.         c = 255
  319.     End If
  320.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  321.     NearestNonstaticGray = c / dgray + StaticColor1 + 1
  322. End Function
  323. ' ************************************************
  324. ' Transform the point (fx, fy) to the point
  325. ' (tx, ty) for reflection across the line with Y
  326. ' intercept b and making angle with the X axis
  327. ' having sine sin_theta and cosine cos_theta.
  328. ' ************************************************
  329. Sub TransformPoint(ByVal fx As Single, ByVal fy As Single, tx As Single, ty As Single, ByVal b As Single, ByVal sin_theta As Single, ByVal cos_theta As Single)
  330. Dim x1 As Single
  331. Dim y1 As Single
  332. Dim x2 As Single
  333. Dim y2 As Single
  334. Dim x3 As Single
  335. Dim y3 As Single
  336. Dim x4 As Single
  337. Dim y4 As Single
  338.     ' Translate by (0, -b).
  339.     x1 = fx
  340.     y1 = fy - b
  341.     ' Rotate by angle theta.
  342.     x2 = x1 * cos_theta + y1 * sin_theta
  343.     y2 = -x1 * sin_theta + y1 * cos_theta
  344.     ' Reflect.
  345.     x3 = x2
  346.     y3 = -y2
  347.     ' Rotate by angle -theta.
  348.     x4 = x3 * cos_theta - y3 * sin_theta
  349.     y4 = x3 * sin_theta + y3 * cos_theta
  350.     ' Translate by (0, b).
  351.     tx = x4
  352.     ty = y4 + b
  353. End Sub
  354. Private Sub Form_Load()
  355. Dim i As Integer
  356.     ' Make sure the screen supports palettes.
  357.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  358.         Beep
  359.         MsgBox "This monitor does not support palettes.", _
  360.             vbCritical
  361.         End
  362.     End If
  363.     ' Get system palette size and # static colors.
  364.     SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
  365.     NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
  366.     StaticColor1 = NumStaticColors \ 2 - 1
  367.     StaticColor2 = SysPalSize - NumStaticColors \ 2
  368.     ' Make the pictures all use gray palettes.
  369.     Me.Show
  370.     DoEvents
  371.     WaitStart
  372.     MatchGrayPalette ToPict
  373.     DoEvents
  374.     ' Let each image repair its palette if needed.
  375.     FromPict.ZOrder
  376.     DoEvents
  377.     ToPict.ZOrder
  378.     DoEvents
  379.     WaitEnd
  380. End Sub
  381. ' ***********************************************
  382. ' Reset the cursors for the form and all the
  383. ' picture boxes.
  384. ' ***********************************************
  385. Sub WaitEnd()
  386.     MousePointer = vbDefault
  387.     FromPict.MousePointer = vbDefault
  388.     ToPict.MousePointer = vbDefault
  389. End Sub
  390. ' ***********************************************
  391. ' Give the form and all the picture boxes an
  392. ' hourglass cursor.
  393. ' ***********************************************
  394. Sub WaitStart()
  395.     MousePointer = vbHourglass
  396.     FromPict.MousePointer = vbHourglass
  397.     ToPict.MousePointer = vbHourglass
  398.     DoEvents
  399. End Sub
  400. Private Sub Form_Unload(Cancel As Integer)
  401.     End
  402. End Sub
  403. Private Sub mnuFileExit_Click()
  404.     Unload Me
  405. End Sub
  406. ' ***********************************************
  407. ' Load a new image file.
  408. ' ***********************************************
  409. Private Sub mnuFileLoad_Click()
  410. Dim fname As String
  411.     ' Allow the user to pick a file.
  412.     On Error Resume Next
  413.     FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
  414.     FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  415.     FileDialog.ShowOpen
  416.     If Err.Number = cdlCancel Then
  417.         Exit Sub
  418.     ElseIf Err.Number <> 0 Then
  419.         Beep
  420.         MsgBox "Error selecting file.", , vbExclamation
  421.         Exit Sub
  422.     End If
  423.     On Error GoTo 0
  424.     fname = Trim$(FileDialog.filename)
  425.     FileDialog.InitDir = Left$(fname, Len(fname) _
  426.         - Len(FileDialog.FileTitle) - 1)
  427.     ' Load the picture.
  428.     WaitStart
  429.     LoadFromPict fname
  430.     DrawImage
  431.     WaitEnd
  432. End Sub
  433. ' ***********************************************
  434. ' Load the indicated file and prepare to work
  435. ' with its palette.
  436. ' ***********************************************
  437. Sub LoadFromPict(fname As String)
  438. Dim status As Long
  439.     On Error GoTo LoadFileError
  440.     FromPict.Picture = LoadPicture(fname)
  441.     On Error GoTo 0
  442.         
  443.     MatchGrayPalette FromPict
  444.     Caption = "Reflect [" & fname & "]"
  445.     Exit Sub
  446. LoadFileError:
  447.     Beep
  448.     MsgBox "Error loading file " & fname & "." & _
  449.         vbCrLf & Error$
  450.     Exit Sub
  451. End Sub
  452.