home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CommonDial18020462001.psc / frmButton.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2001-04-07  |  7.7 KB  |  205 lines
  1. VERSION 5.00
  2. Begin VB.Form frmButton 
  3.    BorderStyle     =   0  'None
  4.    Caption         =   "Form2"
  5.    ClientHeight    =   360
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   1125
  9.    LinkTopic       =   "Form2"
  10.    ScaleHeight     =   360
  11.    ScaleWidth      =   1125
  12.    ShowInTaskbar   =   0   'False
  13.    Begin VB.CheckBox Check1 
  14.       Caption         =   "    INCLUDE SUBFOLDERS"
  15.       BeginProperty Font 
  16.          Name            =   "Small Fonts"
  17.          Size            =   6
  18.          Charset         =   0
  19.          Weight          =   400
  20.          Underline       =   0   'False
  21.          Italic          =   0   'False
  22.          Strikethrough   =   0   'False
  23.       EndProperty
  24.       Height          =   375
  25.       Left            =   0
  26.       TabIndex        =   1
  27.       Top             =   0
  28.       Visible         =   0   'False
  29.       Width           =   1095
  30.    End
  31.    Begin VB.Timer Timer1 
  32.       Enabled         =   0   'False
  33.       Interval        =   100
  34.       Left            =   1440
  35.       Top             =   0
  36.    End
  37.    Begin VB.CommandButton Command1 
  38.       Caption         =   "Create"
  39.       Height          =   345
  40.       Left            =   0
  41.       TabIndex        =   0
  42.       Top             =   0
  43.       Width           =   1125
  44.    End
  45. Attribute VB_Name = "frmButton"
  46. Attribute VB_GlobalNameSpace = False
  47. Attribute VB_Creatable = False
  48. Attribute VB_PredeclaredId = True
  49. Attribute VB_Exposed = False
  50. 'This form is a workaround to insert a button/checkbox
  51. 'on the Browse for Folder window.
  52. 'Win 2K compliant FileExists
  53. Private Const INVALID_HANDLE_VALUE = -1
  54. Private Const MAX_PATH = 260
  55. Private Type FILETIME
  56.     dwLowDateTime As Long
  57.     dwHighDateTime As Long
  58. End Type
  59. Private Type WIN32_FIND_DATA
  60.     dwFileAttributes As Long
  61.     ftCreationTime As FILETIME
  62.     ftLastAccessTime As FILETIME
  63.     ftLastWriteTime As FILETIME
  64.     nFileSizeHigh As Long
  65.     nFileSizeLow As Long
  66.     dwReserved0 As Long
  67.     dwReserved1 As Long
  68.     cFileName As String * MAX_PATH
  69.     cAlternate As String * 14
  70. End Type
  71. Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
  72. Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
  73. Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
  74. Private Declare Sub keybd_event Lib "User32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
  75. Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
  76. Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwnd As Long) As Long
  77. Const KEYEVENTF_KEYUP = &H2
  78. Dim R As RECT
  79. Dim owner As Long
  80. Dim Initpath As String
  81. Dim Newboy As Boolean
  82. Dim Message As String
  83. Private Function FileExists(sSource As String) As Boolean
  84. If Right(sSource, 2) = ":\" Then
  85.     Dim allDrives As String
  86.     allDrives = Space$(64)
  87.     Call GetLogicalDriveStrings(Len(allDrives), allDrives)
  88.     FileExists = InStr(1, allDrives, Left(sSource, 1), 1) > 0
  89.     Exit Function
  90.     If Not sSource = "" Then
  91.         Dim WFD As WIN32_FIND_DATA
  92.         Dim hFile As Long
  93.         hFile = FindFirstFile(sSource, WFD)
  94.         FileExists = hFile <> INVALID_HANDLE_VALUE
  95.         Call FindClose(hFile)
  96.     Else
  97.         FileExists = False
  98.     End If
  99. End If
  100. End Function
  101. Private Sub Check1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  102. LockWindowUpdate BFhwnd
  103. Timer1.Enabled = False
  104. 'stop the timer so this form can temporarily have focus
  105. End Sub
  106. Private Sub Check1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  107. Call SetWindowPos(BFhwnd, Me.hwnd, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, wFlags)
  108. Timer1.Enabled = True
  109. End Sub
  110. Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  111. Timer1.Enabled = False
  112. 'stop the timer so this form can temporarily have focus
  113. 'the timer gets restarted by the GoNew sub
  114. End Sub
  115. Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  116. GoNew
  117. End Sub
  118. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  119. 'return the check value to the UserControl
  120. LetsRecurse = Check1.Value
  121. End Sub
  122. Private Sub Timer1_Timer()
  123. 'Keeps this form positioned over the Browse For Folder dialog
  124. Dim z As Long
  125. LockWindowUpdate 0
  126. z = GetWindowRect(BFhwnd, R)
  127. If z <> 0 Then
  128.     Me.Visible = True
  129.     Me.Left = (R.Left + 16) * Screen.TwipsPerPixelX
  130.     'the butTop value was established by  the 'BrowseCallbackProc' function
  131.     Me.Top = (R.Top + butTop) * Screen.TwipsPerPixelY
  132.     'position this form above the dialog but not above anything else
  133.     'in case a window is opened on top of the dialog
  134.     Call SetWindowPos(BFhwnd, Me.hwnd, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, wFlags)
  135. End If
  136. End Sub
  137. Public Function Browse(ownerform As Long, Create As Boolean, Recurse As Boolean, Optional iniitdir As String, Optional YourMessage As String) As String
  138. Dim temppath As String
  139. Message = YourMessage
  140. If Message = "" Then Message = "Select a Folder"
  141. Initpath = iniitdir
  142. If Initpath = "" Then Initpath = "c:\"
  143. owner = ownerform
  144. If Create Or Recurse Then
  145. againplease:
  146.     Timer1.Enabled = True
  147.     Command1.Visible = Create
  148.     Check1.Visible = Recurse
  149.     temppath = BrowseForFolder(Initpath, owner, Message)
  150.     If Newboy = True Then
  151.     'A new folder needs to be created
  152.         If FileExists(temppath + "\" + Initpath) Then
  153.             Me.Visible = False
  154.             MsgBox "A Folder of that name already exists." + vbCrLf + "Please enter a different name", vbExclamation, "Bobo Enterprises Folder Browser"
  155.             Initpath = temppath
  156.             Newboy = False
  157.             'If it exists then relaunch dialog at the
  158.             'last selected folder
  159.             GoTo againplease
  160.         End If
  161.         Initpath = temppath + "\" + Initpath
  162.         MkDir Initpath
  163.         Newboy = False
  164.         GoTo againplease
  165.     End If
  166.     Browse = StripTerminator(temppath)
  167.     Unload Me
  168.     'Just the standard Browse dialog required so launch it and bail out now
  169.     Browse = StripTerminator(BrowseForFolder(Initpath, owner, Message))
  170.     Unload Me
  171. End If
  172. End Function
  173. Private Sub GoNew()
  174. LockWindowUpdate BFhwnd
  175. Initpath = InputBox("Enter a name for your new folder", "Create Folder")
  176. If Initpath = "" Then
  177.     Call SetWindowPos(BFhwnd, Me.hwnd, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, wFlags)
  178.     Timer1.Enabled = True
  179.     Exit Sub
  180. End If
  181. Call SetWindowPos(BFhwnd, Me.hwnd, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, wFlags)
  182. Timer1.Enabled = True
  183. 'establish the current location of the dialog so we can
  184. 'launch the new dialog in the same location
  185. getBFSizePos BFhwnd
  186. Arestart = True
  187. 'Simulate the 'OK' button being pressed in order to
  188. 'close the current dialog retrieving selected path,
  189. 'so we can make a new folder and then relaunch the dialog
  190. 'with the new folder as the selected initial directory
  191. keybd_event vbKeyReturn, 0, 0, 0
  192. keybd_event vbKeyReturn, 0, KEYEVENTF_KEYUP, 0
  193. Newboy = True
  194. End Sub
  195. Private Function StripTerminator(ByVal strString As String) As String
  196. 'gets rid of any null characters at the end of the returned path
  197.     Dim intZeroPos As Integer
  198.     intZeroPos = InStr(strString, Chr$(0))
  199.     If intZeroPos > 0 Then
  200.         StripTerminator = Left$(strString, intZeroPos - 1)
  201.     Else
  202.         StripTerminator = strString
  203.     End If
  204. End Function
  205.