home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / 256pb2 / 256picbx.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1995-09-06  |  13.7 KB  |  388 lines
  1. VERSION 2.00
  2. Begin Form frm256PicBx 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00C0C0C0&
  5.    BorderStyle     =   1  'Fixed Single
  6.    Caption         =   "256 Color VB Picture Box Demonstration"
  7.    ClientHeight    =   3090
  8.    ClientLeft      =   1080
  9.    ClientTop       =   1425
  10.    ClientWidth     =   7245
  11.    Height          =   3495
  12.    Left            =   1020
  13.    LinkMode        =   1  'Source
  14.    LinkTopic       =   "Form1"
  15.    MaxButton       =   0   'False
  16.    MinButton       =   0   'False
  17.    ScaleHeight     =   3090
  18.    ScaleWidth      =   7245
  19.    Top             =   1080
  20.    Width           =   7365
  21.    Begin PictureBox PicPreviewSource 
  22.       AutoRedraw      =   -1  'True
  23.       BackColor       =   &H00E0E0E0&
  24.       Height          =   18375
  25.       Left            =   360
  26.       ScaleHeight     =   1223
  27.       ScaleMode       =   3  'Pixel
  28.       ScaleWidth      =   1729
  29.       TabIndex        =   0
  30.       Top             =   3720
  31.       Visible         =   0   'False
  32.       Width           =   25965
  33.    End
  34.    Begin PictureBox PicScrollBarFiller 
  35.       BackColor       =   &H00004080&
  36.       Height          =   255
  37.       Left            =   6870
  38.       ScaleHeight     =   225
  39.       ScaleWidth      =   225
  40.       TabIndex        =   13
  41.       Top             =   2730
  42.       Width           =   255
  43.    End
  44.    Begin HScrollBar PicPreviewHScroll 
  45.       Height          =   255
  46.       Left            =   4740
  47.       Max             =   100
  48.       TabIndex        =   12
  49.       TabStop         =   0   'False
  50.       Top             =   2730
  51.       Width           =   2145
  52.    End
  53.    Begin CommandButton pbPreview 
  54.       Caption         =   "&Preview"
  55.       Height          =   345
  56.       Left            =   2790
  57.       TabIndex        =   11
  58.       Top             =   2640
  59.       Width           =   1335
  60.    End
  61.    Begin DriveListBox cbDrives 
  62.       BackColor       =   &H00C0C0C0&
  63.       Height          =   315
  64.       Left            =   150
  65.       TabIndex        =   7
  66.       Top             =   2670
  67.       Width           =   2175
  68.    End
  69.    Begin VScrollBar PicPreviewVScroll 
  70.       Height          =   2115
  71.       Left            =   6870
  72.       TabIndex        =   10
  73.       TabStop         =   0   'False
  74.       Top             =   630
  75.       Width           =   255
  76.    End
  77.    Begin PictureBox PicPreview 
  78.       BackColor       =   &H00E0E0E0&
  79.       Height          =   2115
  80.       Left            =   4740
  81.       ScaleHeight     =   139
  82.       ScaleMode       =   3  'Pixel
  83.       ScaleWidth      =   141
  84.       TabIndex        =   9
  85.       Top             =   630
  86.       Width           =   2145
  87.    End
  88.    Begin FileListBox lbFileList 
  89.       BackColor       =   &H00C0C0C0&
  90.       Height          =   1785
  91.       Left            =   2580
  92.       Pattern         =   "*.bmp"
  93.       TabIndex        =   8
  94.       Top             =   630
  95.       Width           =   1785
  96.    End
  97.    Begin DirListBox lbDirList 
  98.       BackColor       =   &H00C0C0C0&
  99.       Height          =   1785
  100.       Left            =   120
  101.       TabIndex        =   6
  102.       Top             =   630
  103.       Width           =   2175
  104.    End
  105.    Begin CommandButton pbCancel 
  106.       Cancel          =   -1  'True
  107.       Caption         =   "E&XIT"
  108.       Height          =   375
  109.       Left            =   5370
  110.       TabIndex        =   14
  111.       Top             =   90
  112.       Width           =   1005
  113.    End
  114.    Begin Label Label4 
  115.       BackColor       =   &H00C0C0C0&
  116.       Caption         =   "D&rives"
  117.       Height          =   195
  118.       Left            =   150
  119.       TabIndex        =   2
  120.       Top             =   2460
  121.       Width           =   1215
  122.    End
  123.    Begin Label Label3 
  124.       BackColor       =   &H00C0C0C0&
  125.       Caption         =   "&Bitmap Files"
  126.       Height          =   195
  127.       Left            =   2580
  128.       TabIndex        =   5
  129.       Top             =   420
  130.       Width           =   1515
  131.    End
  132.    Begin Label Label2 
  133.       BackColor       =   &H00C0C0C0&
  134.       Caption         =   "&Directories"
  135.       Height          =   195
  136.       Left            =   120
  137.       TabIndex        =   4
  138.       Top             =   420
  139.       Width           =   1635
  140.    End
  141.    Begin Label labDirSelected 
  142.       BackColor       =   &H00C0C0C0&
  143.       Height          =   195
  144.       Left            =   1800
  145.       TabIndex        =   1
  146.       Top             =   120
  147.       Width           =   3315
  148.    End
  149.    Begin Label Label1 
  150.       BackColor       =   &H00C0C0C0&
  151.       Caption         =   "Current Directory:"
  152.       Height          =   195
  153.       Left            =   120
  154.       TabIndex        =   3
  155.       Top             =   120
  156.       Width           =   1635
  157.    End
  158. ' Handle to our dll
  159. Dim hDIBUtil As Integer
  160. ' Handle to a palette created for previewing a bitmap
  161. Dim hPalette As Integer
  162. ' Handle to a global memory area into which a DIB file has been read
  163. ' (for use with DIB utility routines)
  164. Dim hDIBBuffer As Integer
  165. ' A pointer to the actual memory buffer containing the DIB
  166. Dim lpDIBBuffer As Long
  167. Sub cbDrives_Change ()
  168.     lbDirList.Path = cbDrives.Drive
  169. End Sub
  170. Sub Form_Load ()
  171.     OldMousePtr% = Screen.MousePointer
  172.     Screen.MousePointer = HOURGLASS
  173.     'Remove all but Move and Close from the system menu
  174.     Set_ModalDlg_SysMenu frm256PicBx
  175.     'Set up starting directory
  176.     StartingDir$ = CurDir$
  177.     labDirSelected.Caption = StartingDir$
  178.     cbDrives.Drive = StartingDir$
  179.     lbDirList.Path = StartingDir$
  180.     'Set the color of the "filler" between scroll bars
  181.     SBColors$ = GetProfileInfo("Colors", "ScrollBar")
  182.     If (SBColors$ <> "") Then
  183.         Idx% = InStr(SBColors$, " ")
  184.         R% = Val(Left$(SBColors$, Idx% - 1))
  185.         SBColors$ = Right$(SBColors$, Len(SBColors$) - Idx%)
  186.         Idx% = InStr(SBColors$, " ")
  187.         G% = Val(Left$(SBColors$, Idx% - 1))
  188.         SBColors$ = Right$(SBColors$, Len(SBColors$) - Idx%)
  189.         B% = Val(SBColors$)
  190.         PicScrollbarFiller.BackColor = RGB(R%, G%, B%)
  191.     End If
  192.         
  193.     ' Load the DIBUTIL library
  194.     hDIBUtil = LoadLibrary("DIBUTIL.DLL")
  195.     ' Since we haven't yet created a palette, initialize hPalette to
  196.     ' null to indicate this
  197.     hPalette = Null
  198.     Screen.MousePointer = OldMousePtr%
  199. End Sub
  200. Sub Form_Unload (Cancel As Integer)
  201.     ' if hPalette is not 0 then we've created a palette that
  202.     ' should be deleted before we terminate the program
  203.     If (hPalette <> Null) Then
  204.         ReturnVal% = DeleteObject(hPalette)
  205.         If (ReturnVal% = 0) Then
  206.             MsgBox "(Form_Unload) Warning: Could not delete hPalette!"
  207.         End If
  208.     End If
  209.     ' Allow Windows to unload our dll
  210.     FreeLibrary hDIBUtil
  211. End Sub
  212. Function GetProfileInfo (Section$, KeyName$) As String
  213.     Result$ = String$(255, 0)
  214.     ResultLength% = GetProfileString(Section$, KeyName$, "", Result$, 255)
  215.     GetProfileInfo = Left$(Result$, ResultLength%)
  216. End Function
  217. Sub lbDirList_Change ()
  218.     labDirSelected.Caption = UCase$(lbDirList.Path)
  219.     lbFileList.Path = lbDirList.Path
  220. End Sub
  221. Sub lbFileList_DblClick ()
  222.     Call pbPreview_Click
  223. End Sub
  224. Sub lbFileList_PathChange ()
  225.     lbFileList.ListIndex = -1
  226. End Sub
  227. Sub MovePic ()
  228. Dim SrcX, SrcY, DestX, DestY, DestWidth, DestHeight As Integer
  229.     'Set up bitblt parameters
  230.     SrcX = PicPreviewHScroll.Value: SrcY = PicPreviewVScroll.Value
  231.     DestX = 0: DestY = 0
  232.     DestWidth = PicPreview.ScaleWidth
  233.     DestHeight = PicPreview.ScaleHeight
  234.     'In case anyone has changed the palette since we last painted,
  235.     'realize it (again)
  236.     ReturnVal% = RealizePalette(PicPreviewSource.hDC)
  237.     ReturnVal% = RealizePalette(PicPreview.hDC)
  238.     'Blast the new picture into the preview picture box
  239.     APIError% = BitBlt(PicPreview.hDC, DestX, DestY, DestWidth, DestHeight, PicPreviewSource.hDC, SrcX, SrcY, SRCCOPY)
  240.     'If the picture box has AutoRedraw on, it must be refreshed
  241.     If (PicPreview.AutoRedraw) Then PicPreview.Refresh
  242. End Sub
  243. Sub pbCancel_Click ()
  244.     Unload frm256PicBx
  245.     End
  246. End Sub
  247. Sub pbPreview_Click ()
  248. Dim bmpWidth, bmpHeight As Long
  249. Dim ShowFiller As Integer
  250.     'Set an hourglass cursor
  251.     OldMousePtr% = Screen.MousePointer
  252.     Screen.MousePointer = HOURGLASS
  253.     'Clear any existing bitmaps
  254.     PicPreview.Picture = LoadPicture()
  255.     PicPreviewSource.Picture = LoadPicture()
  256.     'Any bitmap files in the listbox?
  257.     If (lbFileList.ListCount < 1) Then
  258.         MsgBox "Please select a Bitmap file before pressing the Preview button"
  259.         GoTo FastExit
  260.     End If
  261.     'If no bitmap file is selected, take the first one
  262.     If lbFileList.ListIndex < 0 Then lbFileList.ListIndex = 0
  263.     FName$ = lbDirList.List(lbDirList.ListIndex)
  264.     If Right$(FName$, 1) <> "\" Then FName$ = FName$ + "\"
  265.     FName$ = FName$ + lbFileList.List(lbFileList.ListIndex)
  266.     'Load the bitmap into memory and get its dimensions
  267.     hDIBBuffer = DIBLoad(FName$)
  268.     If (hDIBBuffer = Null) Then
  269.         MsgBox "Error loading " + FName$ + "!"
  270.         GoTo FastExit
  271.     End If
  272.     lpDIBBuffer = GlobalLock(hDIBBuffer)
  273.     bmpWidth = DIBWidth(lpDIBBuffer)
  274.     bmpHeight = DIBHeight(lpDIBBuffer)
  275.     ReturnVal% = GlobalUnlock(hDIBBuffer)
  276.     'Set up bitblt parameters
  277.     If (bmpWidth > PicPreview.ScaleWidth) Then
  278.         DestWidth = PicPreview.ScaleWidth
  279.     Else
  280.         DestWidth = bmpWidth
  281.     End If
  282.     If (bmpHeight > PicPreview.ScaleHeight) Then
  283.         DestHeight = PicPreview.ScaleHeight
  284.     Else
  285.         DestHeight = bmpHeight
  286.     End If
  287.     'Set up the scroll bars
  288.     ShowFiller = 0
  289.     If DestWidth >= bmpWidth Then
  290.         PicPreviewHScroll.Visible = False
  291.     Else
  292.         PicPreviewHScroll.Visible = True
  293.         PicPreviewHScroll.Min = 0
  294.         PicPreviewHScroll.Max = bmpWidth - DestWidth
  295.         PicPreviewHScroll.SmallChange = DestWidth / 10
  296.         PicPreviewHScroll.LargeChange = DestWidth / 2
  297.         PicPreviewHScroll.Value = 0
  298.         ShowFiller = ShowFiller + 1
  299.         PicPreviewHScroll.Refresh
  300.     End If
  301.     If DestHeight >= bmpHeight Then
  302.         PicPreviewVScroll.Visible = False
  303.     Else
  304.         PicPreviewVScroll.Visible = True
  305.         PicPreviewVScroll.Visible = True
  306.         PicPreviewVScroll.Min = 0
  307.         PicPreviewVScroll.Max = bmpHeight - DestHeight
  308.         PicPreviewVScroll.SmallChange = DestHeight / 10
  309.         PicPreviewVScroll.LargeChange = DestHeight / 2
  310.         PicPreviewVScroll.Value = 0
  311.         PicPreviewVScroll.Refresh
  312.         ShowFiller = ShowFiller + 1
  313.     End If
  314.     If (ShowFiller = 2) Then
  315.         PicScrollbarFiller.Visible = True
  316.     Else
  317.         PicScrollbarFiller.Visible = False
  318.     End If
  319.     'If we have previously created a palette, delete it now
  320.     If (hPalette <> Null) Then
  321.         ReturnVal% = DeleteObject(hPalette)
  322.         If (ReturnVal% = 0) Then
  323.             MsgBox "(pbPreview_Click) Warning: Could not delete hPalette!"
  324.         End If
  325.     End If
  326.     'Create a new palette for this bitmap
  327.     hPalette = CreateDIBPalette(hDIBBuffer)
  328.     ' Make sure DC containing the persistent image has the right palette
  329.     hOldPalette% = SelectPalette(PicPreviewSource.hDC, hPalette, False)
  330.     ReturnVal% = RealizePalette(PicPreviewSource.hDC)
  331.     ' Make sure the picture box DC has the right palette
  332.     hOldPalette% = SelectPalette(PicPreview.hDC, hPalette, False)
  333.     ReturnVal% = RealizePalette(PicPreview.hDC)
  334.     'Lock the memory block
  335.     lpDIBBuffer = GlobalLock(hDIBBuffer)
  336.     ' Create a Device Dependent Bitmap
  337.     hBitmap% = CreateDIBitmap(PicPreviewSource.hDC, lpDIBBuffer, CBM_INIT, FindDIBBits(lpDIBBuffer), lpDIBBuffer, DIB_RGB_INFO)
  338.     ' Create a memory DC from which we can bitblt the image.  Select in and
  339.     ' realize the palette, then select in the ddb
  340.     hCompatDC% = CreateCompatibleDC(PicPreviewSource.hDC)
  341.     'hOldPalette% = SelectPalette(hCompatDC%, hPalette, FALSE)
  342.     'ReturnVal% = RealizePalette(hCompatDC%)
  343.     hPrevBmp% = SelectObject(hCompatDC%, hBitmap%)
  344.     'Blast the image into our hidden picture box
  345.     Success% = BitBlt(PicPreviewSource.hDC, 0, 0, bmpWidth, bmpHeight, hCompatDC%, 0, 0, SRCCOPY)
  346.     'Free up resources we no longer need
  347.     ReturnVal% = DeleteDC(hCompatDC%)
  348.     If (ReturnVal% = 0) Then
  349.         MsgBox "(pbPreview_Click) Warning: Could not delete hComptDC%!"
  350.     End If
  351.     ReturnVal% = DeleteObject(hBitmap%)
  352.     If (ReturnVal% = 0) Then
  353.         MsgBox "(pbPreview_Click) Warning: Could not delete hBitmap%!"
  354.     End If
  355.     'release previously allocated memory
  356.     Success% = GlobalUnlock(hDIBBuffer)
  357.     Success% = GlobalFree(hDIBBuffer)
  358.     hDIBBuffer = Null
  359.     'Now fill in the scrollable picture box
  360.     Call MovePic
  361. FastExit:
  362.     'Restore the cursor
  363.     Screen.MousePointer = OldMousePtr%
  364. End Sub
  365. Sub PicPreviewHScroll_Change ()
  366.     Call MovePic
  367. End Sub
  368. Sub PicPreviewVScroll_Change ()
  369.     Call MovePic
  370. End Sub
  371. Sub Set_ModalDlg_SysMenu (A_Form As Form)
  372.     ' Obtain the handle to the forms System menu
  373.     '
  374.     HSysMenu = GetSystemMenu(A_Form.hWnd, 0)
  375.     ' Remove all but the MOVE and CLOSE options.  The menu items
  376.     ' must be removed starting with the last menu item to prevent
  377.     ' the menu items from taking on new position values as other
  378.     ' menu items are being removed.
  379.     '
  380.     R = RemoveMenu(HSysMenu, 8, MF_BYPOSITION) 'Switch to
  381.     R = RemoveMenu(HSysMenu, 7, MF_BYPOSITION) 'Separator
  382.     R = RemoveMenu(HSysMenu, 5, MF_BYPOSITION) 'Separator
  383.     R = RemoveMenu(HSysMenu, 4, MF_BYPOSITION) 'Maximize
  384.     R = RemoveMenu(HSysMenu, 3, MF_BYPOSITION) 'Minimize
  385.     R = RemoveMenu(HSysMenu, 2, MF_BYPOSITION) 'Size
  386.     R = RemoveMenu(HSysMenu, 0, MF_BYPOSITION) 'Restore
  387. End Sub
  388.