home *** CD-ROM | disk | FTP | other *** search
Wrap
VERSION 4.00 Begin VB.Form ReflectForm Caption = "Reflect" ClientHeight = 4560 ClientLeft = 1080 ClientTop = 1290 ClientWidth = 7680 Height = 5250 Left = 1020 LinkTopic = "Form1" ScaleHeight = 304 ScaleMode = 3 'Pixel ScaleWidth = 512 Top = 660 Width = 7800 Begin VB.PictureBox ToPict AutoRedraw = -1 'True BackColor = &H00C0C0C0& Height = 4560 Left = 3120 Picture = "REFLECTF.frx":0000 ScaleHeight = 300 ScaleMode = 3 'Pixel ScaleWidth = 300 TabIndex = 1 Top = 0 Width = 4560 End Begin VB.PictureBox FromPict AutoRedraw = -1 'True BackColor = &H00C0C0C0& Height = 3060 Left = 0 Picture = "REFLECTF.frx":0446 ScaleHeight = 200 ScaleMode = 3 'Pixel ScaleWidth = 200 TabIndex = 0 Top = 0 Width = 3060 End Begin MSComDlg.CommonDialog FileDialog Left = 2520 Top = 3120 _Version = 65536 _ExtentX = 847 _ExtentY = 847 _StockProps = 0 CancelError = -1 'True FontSize = 7.82965e-39 End Begin VB.Menu mnuFile Caption = "&File" Begin VB.Menu mnuFileLoad Caption = "&Load..." Shortcut = ^L End Begin VB.Menu mnuFileSep Caption = "-" End Begin VB.Menu mnuFileExit Caption = "E&xit" End End Attribute VB_Name = "ReflectForm" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim SysPalSize As Integer Dim NumStaticColors As Integer Dim StaticColor1 As Integer Dim StaticColor2 As Integer Dim LogPal As Integer Dim palentry(0 To 255) As PALETTEENTRY Dim wid As Long Dim hgt As Long Dim bytes() As Byte ' ************************************************ ' Draw the rotated image. ' ************************************************ Sub DrawImage() Const m = 0.5 Const b = 50# ' Draw a line where we will reflect. FromPict.Line (0, b)- _ (FromPict.ScaleWidth, _ m * FromPict.ScaleWidth + b) ToPict.Cls ReflectPicture FromPict, ToPict, _ 0, 0, _ FromPict.ScaleWidth - 1, _ FromPict.ScaleHeight - 1, _ m, b End Sub ' ************************************************ ' Reflect the area fx1 <= x <= fx2, ' fy1 <= y <= fy2 across the line y = m * x + b. ' ************************************************ Sub ReflectPicture( _ ByVal from_pic As Control, ByVal to_pic As Control, _ ByVal fx1 As Integer, ByVal fy1 As Integer, _ ByVal fx2 As Integer, ByVal fy2 As Integer, _ ByVal m As Single, ByVal b As Single) Dim bm As BITMAP Dim hbm As Integer Dim status As Long Dim from_bytes() As Byte Dim to_bytes() As Byte Dim from_wid As Long Dim from_hgt As Long Dim to_wid As Long Dim to_hgt As Long Dim hyp As Single Dim sin_theta As Single Dim cos_theta As Single Dim tx1 As Single Dim tx2 As Single Dim ty1 As Single Dim ty2 As Single Dim fx As Single Dim fy As Single Dim tx As Single Dim ty As Single Dim x As Single Dim y As Single Dim ifx As Integer Dim ify As Integer Dim dx As Single Dim dy As Single Dim c1 As Integer Dim c2 As Integer Dim c3 As Integer Dim c4 As Integer Dim i1 As Integer Dim i2 As Integer Dim clr As Integer ' Get from_pic's pixels. hbm = from_pic.Image status = GetObject(hbm, BITMAP_SIZE, bm) from_wid = bm.bmWidthBytes from_hgt = bm.bmHeight ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1) status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0)) ' Get to_pic's pixels. hbm = to_pic.Image status = GetObject(hbm, BITMAP_SIZE, bm) to_wid = bm.bmWidthBytes to_hgt = bm.bmHeight ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1) status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0)) ' Compute the sine and cosine of theta. hyp = Sqr(m * m + 1) sin_theta = m / hyp cos_theta = 1 / hyp ' Make some bounds for to_pic. TransformPoint fx1, fy1, tx1, ty1, b, sin_theta, cos_theta tx2 = tx1 ty2 = ty1 TransformPoint fx1, fy2, tx, ty, b, sin_theta, cos_theta If tx1 > tx Then tx1 = tx If ty1 > ty Then ty1 = ty If tx2 < tx Then tx2 = tx If ty2 < ty Then ty2 = ty TransformPoint fx2, fy1, tx, ty, b, sin_theta, cos_theta If tx1 > tx Then tx1 = tx If ty1 > ty Then ty1 = ty If tx2 < tx Then tx2 = tx If ty2 < ty Then ty2 = ty TransformPoint fx2, fy2, tx, ty, b, sin_theta, cos_theta If tx1 > tx Then tx1 = tx If ty1 > ty Then ty1 = ty If tx2 < tx Then tx2 = tx If ty2 < ty Then ty2 = ty If tx1 < 1 Then tx1 = 1 If tx2 < 1 Then tx2 = 1 If tx1 > to_wid - 1 Then tx1 = to_wid - 1 If tx2 > to_wid - 1 Then tx2 = to_wid - 1 If ty1 < 1 Then ty1 = 1 If ty2 < 1 Then ty2 = 1 If ty1 > to_hgt - 1 Then ty1 = to_hgt - 1 If ty2 > to_hgt - 1 Then ty2 = to_hgt - 1 ' Perform the rotation. For ty = ty1 To ty2 For tx = tx1 To tx2 ' See where the point came from. TransformPoint tx, ty, fx, fy, b, sin_theta, cos_theta ' Skip it if any of the four nearest ' source pixels lie outside the allowed ' source area. ify = Int(fy) ifx = Int(fx) If ifx >= fx1 And ifx < fx2 And _ ify >= fy1 And ify < fy2 Then ' Interpolate using the four nearest ' pixels in from_pic. dy = fy - ify dx = fx - ifx c1 = palentry(from_bytes(ifx, ify)).peRed c2 = palentry(from_bytes(ifx + 1, ify)).peRed c3 = palentry(from_bytes(ifx, ify + 1)).peRed c4 = palentry(from_bytes(ifx + 1, ify + 1)).peRed ' Interpolate in the Y direction. i1 = c1 * (1 - dy) + c3 * dy i2 = c2 * (1 - dy) + c4 * dy ' Interpolate the results in the X direction. clr = i1 * (1 - dx) + i2 * dx to_bytes(tx, ty) = NearestNonstaticGray(clr) End If Next tx Next ty ' Update from_pic. status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0)) to_pic.Refresh End Sub ' *********************************************** ' Load the control's palette so the non-static ' colors are grays. Map the logical palette to ' match the system palette. Convert the image to ' use the non-static grays. ' Set the following module global variables. ' LogPal Image logical palette handle. ' palentry() Image logical palette entries. ' wid Width of image. ' hgt Height of image. ' bytes(1 To wid, 1 To hgt) ' Image pixel values. ' *********************************************** Sub MatchGrayPalette(pic As Control) Dim sys(0 To 255) As PALETTEENTRY Dim i As Integer Dim bm As BITMAP Dim hbm As Integer Dim status As Long Dim x As Integer Dim y As Integer Dim gray As Single Dim dgray As Single Dim c As Integer Dim clr As Integer ' Make sure pic has the foreground palette. pic.ZOrder i = RealizePalette(pic.hdc) DoEvents ' Get the system palette entries. i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0)) ' Get the image pixels. hbm = pic.Image status = GetObject(hbm, BITMAP_SIZE, bm) wid = bm.bmWidthBytes hgt = bm.bmHeight ReDim bytes(1 To wid, 1 To hgt) status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1)) ' Make the logical palette as big as possible. LogPal = pic.Picture.hPal If ResizePalette(LogPal, SysPalSize) = 0 Then Beep MsgBox "Error resizing logical palette.", _ vbExclamation Exit Sub End If ' Blank the non-static colors. For i = 0 To StaticColor1 palentry(i) = sys(i) Next i For i = StaticColor1 + 1 To StaticColor2 - 1 With palentry(i) .peRed = 0 .peGreen = 0 .peBlue = 0 .peFlags = PC_NOCOLLAPSE End With Next i For i = StaticColor2 To 255 palentry(i) = sys(i) Next i i = SetPaletteEntries(LogPal, 0, SysPalSize, palentry(0)) ' Insert the non-static grays. gray = 0 dgray = 255 / (StaticColor2 - StaticColor1 - 2) For i = StaticColor1 + 1 To StaticColor2 - 1 c = gray gray = gray + dgray With palentry(i) .peRed = c .peGreen = c .peBlue = c End With Next i i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) ' Recreate the image using the new colors. For y = 1 To hgt For x = 1 To wid clr = bytes(x, y) With sys(clr) c = (CInt(.peRed) + .peGreen + .peBlue) / 3 End With bytes(x, y) = NearestNonstaticGray(c) Next x Next y status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1)) ' Realize the gray palette. i = RealizePalette(pic.hdc) pic.Refresh End Sub ' ************************************************ ' Return the index of the nonstatic gray closest ' to the given value (assuming the non-static ' colors are a gray scale created by ' MatchGrayPalette). ' ************************************************ Function NearestNonstaticGray(c As Integer) As Integer Dim dgray As Single If c < 0 Then c = 0 ElseIf c > 255 Then c = 255 End If dgray = 255 / (StaticColor2 - StaticColor1 - 2) NearestNonstaticGray = c / dgray + StaticColor1 + 1 End Function ' ************************************************ ' Transform the point (fx, fy) to the point ' (tx, ty) for reflection across the line with Y ' intercept b and making angle with the X axis ' having sine sin_theta and cosine cos_theta. ' ************************************************ 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) Dim x1 As Single Dim y1 As Single Dim x2 As Single Dim y2 As Single Dim x3 As Single Dim y3 As Single Dim x4 As Single Dim y4 As Single ' Translate by (0, -b). x1 = fx y1 = fy - b ' Rotate by angle theta. x2 = x1 * cos_theta + y1 * sin_theta y2 = -x1 * sin_theta + y1 * cos_theta ' Reflect. x3 = x2 y3 = -y2 ' Rotate by angle -theta. x4 = x3 * cos_theta - y3 * sin_theta y4 = x3 * sin_theta + y3 * cos_theta ' Translate by (0, b). tx = x4 ty = y4 + b End Sub Private Sub Form_Load() Dim i As Integer ' Make sure the screen supports palettes. If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then Beep MsgBox "This monitor does not support palettes.", _ vbCritical End End If ' Get system palette size and # static colors. SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE) NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED) StaticColor1 = NumStaticColors \ 2 - 1 StaticColor2 = SysPalSize - NumStaticColors \ 2 ' Make the pictures all use gray palettes. Me.Show DoEvents WaitStart MatchGrayPalette ToPict DoEvents ' Let each image repair its palette if needed. FromPict.ZOrder DoEvents ToPict.ZOrder DoEvents WaitEnd End Sub ' *********************************************** ' Reset the cursors for the form and all the ' picture boxes. ' *********************************************** Sub WaitEnd() MousePointer = vbDefault FromPict.MousePointer = vbDefault ToPict.MousePointer = vbDefault End Sub ' *********************************************** ' Give the form and all the picture boxes an ' hourglass cursor. ' *********************************************** Sub WaitStart() MousePointer = vbHourglass FromPict.MousePointer = vbHourglass ToPict.MousePointer = vbHourglass DoEvents End Sub Private Sub Form_Unload(Cancel As Integer) End End Sub Private Sub mnuFileExit_Click() Unload Me End Sub ' *********************************************** ' Load a new image file. ' *********************************************** Private Sub mnuFileLoad_Click() Dim fname As String ' Allow the user to pick a file. On Error Resume Next FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB" FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly FileDialog.ShowOpen If Err.Number = cdlCancel Then Exit Sub ElseIf Err.Number <> 0 Then Beep MsgBox "Error selecting file.", , vbExclamation Exit Sub End If On Error GoTo 0 fname = Trim$(FileDialog.filename) FileDialog.InitDir = Left$(fname, Len(fname) _ - Len(FileDialog.FileTitle) - 1) ' Load the picture. WaitStart LoadFromPict fname DrawImage WaitEnd End Sub ' *********************************************** ' Load the indicated file and prepare to work ' with its palette. ' *********************************************** Sub LoadFromPict(fname As String) Dim status As Long On Error GoTo LoadFileError FromPict.Picture = LoadPicture(fname) On Error GoTo 0 MatchGrayPalette FromPict Caption = "Reflect [" & fname & "]" Exit Sub LoadFileError: Beep MsgBox "Error loading file " & fname & "." & _ vbCrLf & Error$ Exit Sub End Sub