home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Set_Pictur197824362006.psc / frmMain.frm < prev    next >
Text File  |  2006-03-03  |  7KB  |  195 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "Set Picture"
  5.    ClientHeight    =   1695
  6.    ClientLeft      =   45
  7.    ClientTop       =   330
  8.    ClientWidth     =   1770
  9.    LinkTopic       =   "Form1"
  10.    MaxButton       =   0   'False
  11.    MinButton       =   0   'False
  12.    ScaleHeight     =   1695
  13.    ScaleWidth      =   1770
  14.    StartUpPosition =   1  'CenterOwner
  15.    Begin VB.Frame Frame1 
  16.       Caption         =   "Options"
  17.       Height          =   1575
  18.       Left            =   60
  19.       TabIndex        =   0
  20.       Top             =   60
  21.       Width           =   1635
  22.       Begin VB.PictureBox Picture1 
  23.          AutoRedraw      =   -1  'True
  24.          Height          =   555
  25.          Left            =   120
  26.          Picture         =   "frmMain.frx":0000
  27.          ScaleHeight     =   32
  28.          ScaleMode       =   0  'User
  29.          ScaleWidth      =   32
  30.          TabIndex        =   4
  31.          Top             =   240
  32.          Width           =   555
  33.       End
  34.       Begin VB.OptionButton Option1 
  35.          Caption         =   "Center"
  36.          Height          =   195
  37.          Index           =   0
  38.          Left            =   720
  39.          TabIndex        =   3
  40.          Top             =   180
  41.          Value           =   -1  'True
  42.          Width           =   795
  43.       End
  44.       Begin VB.OptionButton Option1 
  45.          Caption         =   "Tile"
  46.          Height          =   195
  47.          Index           =   1
  48.          Left            =   720
  49.          TabIndex        =   2
  50.          Top             =   420
  51.          Width           =   615
  52.       End
  53.       Begin VB.OptionButton Option1 
  54.          Caption         =   "Stretch"
  55.          Height          =   195
  56.          Index           =   2
  57.          Left            =   720
  58.          TabIndex        =   1
  59.          Top             =   660
  60.          Width           =   855
  61.       End
  62.       Begin VB.Label Label1 
  63.          AutoSize        =   -1  'True
  64.          Caption         =   "Drag the arrow over a window to set its picture."
  65.          Height          =   585
  66.          Left            =   120
  67.          TabIndex        =   5
  68.          Top             =   900
  69.          Width           =   1455
  70.          WordWrap        =   -1  'True
  71.       End
  72.    End
  73. End
  74. Attribute VB_Name = "frmMain"
  75. Attribute VB_GlobalNameSpace = False
  76. Attribute VB_Creatable = False
  77. Attribute VB_PredeclaredId = True
  78. Attribute VB_Exposed = False
  79. Option Explicit
  80.  
  81. Private Const DC% = 1
  82. Private Const WINDOWDC% = 2
  83.  
  84. Private Const CENTER% = 1
  85. Private Const TILE% = 2
  86. Private Const STRETCH% = 3
  87.  
  88. Private Type POINTAPI
  89.     X As Long
  90.     Y As Long
  91. End Type
  92.  
  93. Private Type RECT
  94.     Left As Long
  95.     Top As Long
  96.     Right As Long
  97.     Bottom As Long
  98. End Type
  99.  
  100. Private Type PICTUREPROPERTIES
  101.     pType As Long
  102.     pWidth As Long
  103.     pHeight As Long
  104.     pWidthBytes As Long
  105.     pPlanes As Integer
  106.     pBitsPixel As Integer
  107.     pBits As Long
  108. End Type
  109.  
  110. Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal X&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)
  111. Private Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hdc&)
  112. Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc&)
  113. Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
  114. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  115. Private Declare Function GetDC& Lib "user32" (ByVal hWnd&)
  116. Private Declare Function GetObject& Lib "gdi32" Alias "GetObjectA" (ByVal hObject&, ByVal nCount&, lpObject As Any)
  117. Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
  118. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  119. Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc&, ByVal hObject&)
  120. Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  121. Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  122.  
  123. Dim thWnd&, pt As POINTAPI, sPos%
  124.  
  125. Private Sub Form_Load()
  126.  
  127.     sPos = 1
  128.  
  129. End Sub
  130.  
  131. Private Sub Option1_Click(Index As Integer)
  132.  
  133.     If Option1(Index).Value = True Then sPos = Index + 1
  134.  
  135. End Sub
  136.  
  137. Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  138.  
  139.     Select Case Button
  140.         Case 1
  141.             MousePointer = vbUpArrow
  142.     End Select
  143.  
  144. End Sub
  145.  
  146. Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  147.  
  148.     Select Case Button
  149.         Case 1
  150.             Call GetCursorPos(pt)
  151.             thWnd = WindowFromPoint(pt.X, pt.Y)
  152.             Call SetPicture(thWnd, App.Path + "\picture.jpg", sPos, 2)
  153.             MousePointer = vbDefault
  154.     End Select
  155.  
  156. End Sub
  157.  
  158. Private Sub SetPicture(hWnd&, lpsz$, Optional PicPos% = CENTER, Optional TargetDC% = DC)
  159.  
  160.     Dim hDestDC&, hSrcDC&, hPic&, PicProp As PICTUREPROPERTIES, wR As RECT, Cx&, Cy&
  161.  
  162.     If Dir(lpsz) = vbNullString Then Exit Sub
  163.     Select Case TargetDC
  164.         Case DC
  165.             'Sets the picture to inside of window.
  166.             hDestDC = GetDC(hWnd)
  167.         Case WINDOWDC
  168.             'Sets the picture to all window.
  169.             'Also to caption.
  170.             hDestDC = GetWindowDC(hWnd)
  171.     End Select
  172.     Call GetObject(LoadPicture(lpsz).Handle, Len(PicProp), PicProp)
  173.     hSrcDC = CreateCompatibleDC(hDestDC)
  174.     Call SelectObject(hSrcDC, LoadPicture(lpsz).Handle)
  175.     Call GetWindowRect(hWnd, wR)
  176.     Select Case PicPos
  177.         Case CENTER
  178.             'Sets the picture to center.
  179.             Call BitBlt(hDestDC, ((wR.Right - wR.Left) - PicProp.pWidth) / 2, ((wR.Bottom - wR.Top) - PicProp.pHeight) / 2, PicProp.pWidth, PicProp.pHeight, hSrcDC, 0, 0, vbSrcCopy)
  180.         Case TILE
  181.             'Tiles the picture to window.
  182.             For Cx = 0 To wR.Right - wR.Left Step PicProp.pWidth
  183.                 For Cy = 0 To wR.Bottom - wR.Top Step PicProp.pHeight
  184.                     Call BitBlt(hDestDC, Cx, Cy, PicProp.pWidth, PicProp.pHeight, hSrcDC, 0, 0, vbSrcCopy)
  185.                 Next Cy
  186.             Next Cx
  187.         Case STRETCH
  188.             'Stretchs the picture to window.
  189.             Call StretchBlt(hDestDC, 0, 0, wR.Right - wR.Left, wR.Bottom - wR.Top, hSrcDC, 0, 0, PicProp.pWidth, PicProp.pHeight, vbSrcCopy)
  190.     End Select
  191.     Call DeleteDC(hDestDC)
  192.     Call DeleteDC(hSrcDC)
  193.  
  194. End Sub
  195.