home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Planet Source Code Jumbo …e CD Visual Basic 1 to 7
/
6_2008-2009.ISO
/
data
/
zips
/
SearchMySt2118966302008.psc
/
frmSearch.frm
< prev
next >
Wrap
Text File
|
2008-06-30
|
13KB
|
444 lines
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmSearch
Caption = "Search VB"
ClientHeight = 6015
ClientLeft = 60
ClientTop = 345
ClientWidth = 10590
Icon = "frmSearch.frx":0000
LinkTopic = "Form1"
ScaleHeight = 6015
ScaleWidth = 10590
Begin VB.CheckBox chkRemAttr
Caption = "Remove VB Attributes When Viewing"
Height = 255
Left = 5160
TabIndex = 8
Top = 240
Width = 3135
End
Begin MSComctlLib.ImageList ImageList1
Left = 5040
Top = 2760
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 6
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmSearch.frx":08CA
Key = "cls"
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmSearch.frx":0E64
Key = "ctl"
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmSearch.frx":13FE
Key = "frm"
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmSearch.frx":1998
Key = "bas"
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmSearch.frx":1F32
Key = "Up"
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmSearch.frx":24CC
Key = "Dn"
EndProperty
EndProperty
End
Begin VB.CommandButton cmdSrch
Caption = "Search"
Height = 285
Left = 3480
TabIndex = 7
Top = 0
Width = 855
End
Begin VB.CheckBox chkT
Caption = "Controls"
Height = 255
Index = 3
Left = 7800
TabIndex = 6
Tag = "ctl"
Top = 0
Width = 975
End
Begin VB.CheckBox chkT
Caption = "Cls Mods"
Height = 255
Index = 2
Left = 6720
TabIndex = 5
Tag = "cls"
Top = 0
Width = 1335
End
Begin VB.CheckBox chkT
Caption = "Bas Mods"
Height = 255
Index = 1
Left = 5520
TabIndex = 4
Tag = "bas"
Top = 0
Width = 1335
End
Begin VB.CheckBox chkT
Caption = "Forms"
Height = 255
Index = 0
Left = 4680
TabIndex = 3
Tag = "frm"
Top = 0
Value = 1 'Checked
Width = 1335
End
Begin VB.CommandButton cmdAll
Caption = "Show All Records"
Height = 255
Left = 9000
TabIndex = 2
Top = 0
Width = 1455
End
Begin VB.TextBox txtSrch
Height = 285
Left = 0
TabIndex = 0
Top = 0
Width = 3375
End
Begin MSComctlLib.ListView LV
Height = 5535
Left = 0
TabIndex = 1
Top = 480
Width = 10455
_ExtentX = 18441
_ExtentY = 9763
View = 3
LabelEdit = 1
Sorted = -1 'True
MultiSelect = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
OLEDragMode = 1
FullRowSelect = -1 'True
_Version = 393217
SmallIcons = "ImageList1"
ColHdrIcons = "ImageList1"
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
OLEDragMode = 1
NumItems = 5
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "Name"
Object.Width = 2646
ImageKey = "Up"
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "Type"
Object.Width = 1323
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "Date"
Object.Width = 4939
EndProperty
BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 3
Text = "Size"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(5) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 4
Text = "Path"
Object.Width = 6703
EndProperty
End
Begin VB.Menu LVPop
Caption = ""
Visible = 0 'False
Begin VB.Menu LVArr
Caption = "View Selected File"
Index = 0
End
Begin VB.Menu LVArr
Caption = "Copy To..."
Index = 1
End
Begin VB.Menu LVArr
Caption = "Delete From Database"
Index = 2
End
End
End
Attribute VB_Name = "frmSearch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Program needs a reference to
' Microsoft DAO Object Library (dao360.dll)
'If it shows as missing reference, you
' may need to register it,
' Start|Run|regsvr32.exe c:\[path]\dao360.dll
'Possible Locations:
'C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll
'C:\WINDOWS\ServicePackFiles\i386
'Download site
'http://www.domainpunch.com/support/articles/dao.php
'Do NOT need MS Access installed
'Note you can also drag files to an open
' VB Ide Project Window, see the
' LV_OLEStartDrag routine below
Option Explicit
Private DBPath As String
Private DB As DAO.Database
Private RecCnt As Long
Private LVRatios As Variant
Private Sub Form_Load()
Init
Show
DoEvents
If RecCnt = 0 Then
MsgBox "No records in the database." & vbNewLine & _
"Run the included BuildMyStuff vbp to add records"
Unload Me
Else
LV.ColumnHeaders(5).Text = "Path (Database has " & RecCnt & " records)"
End If
End Sub
Private Sub Init()
DBPath = App.Path & "\Ref.mdb"
Set DB = OpenDatabase(DBPath)
RecCnt = DBRecCnt
Set oIni = New cIni
oIni.Path = App.Path & "\Search.ini"
LVRatios = Array(, 0.142, 0.1, 0.164, 0.136, 0.45)
LoadSettings
End Sub
Private Sub LoadSettings()
Dim i As Long
With oIni
.Section = "Main Settings"
.Key = "FLeft": Left = .Value
.Key = "FTop": Top = .Value
.Key = "FWidth": Width = .Value
.Key = "FHeight": Height = .Value
For i = 0 To 3
.Key = "FType" & i: chkT(i).Value = .Value
Next
.Key = "FAttr": chkRemAttr.Value = .Value
End With
End Sub
Private Sub SaveSettings()
Dim i As Long
With oIni
.Section = "Main Settings"
.Key = "FLeft": .Value = Left
.Key = "FTop": .Value = Top
.Key = "FWidth": .Value = Width
.Key = "FHeight": .Value = Height
For i = 0 To 3
.Key = "FType" & i: .Value = chkT(i).Value
Next
.Key = "FAttr": .Value = chkRemAttr.Value
End With
End Sub
Private Sub Form_Resize()
Dim i As Long
If WindowState <> vbMinimized Then
'listview column width ratios
LV.Move 0, 480, ScaleWidth, ScaleHeight
For i = 1 To LV.ColumnHeaders.Count
LV.ColumnHeaders(i).Width = LVRatios(i) * LV.Width
Next
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSettings
Set oIni = Nothing
DB.Close
Set DB = Nothing
End Sub
Private Sub cmdAll_Click()
LoadRS DB.OpenRecordset("Main")
End Sub
Private Sub cmdSrch_Click()
If Len(txtSrch.Text) Then
DoSearch
End If
End Sub
Private Sub LV_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Dim i As Long
For i = 1 To LV.ColumnHeaders.Count
LV.ColumnHeaders(i).Icon = 0
Next
With LV
.SortKey = ColumnHeader.Index - 1
.SortOrder = .SortOrder Xor 1
LV.ColumnHeaders(ColumnHeader.Index).Icon = IIf(.SortOrder = lvwAscending, "Up", "Dn")
End With
End Sub
Private Sub LV_ItemClick(ByVal Item As MSComctlLib.ListItem)
Caption = Item.SubItems(4)
End Sub
Private Sub LV_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim LI As ListItem
If Button = vbRightButton Then
Set LI = LV.HitTest(x, y)
If Not LI Is Nothing Then
LI.Selected = True
LVArr(0).Enabled = LVSelCount(LV) < 2
PopupMenu LVPop
End If
End If
End Sub
Private Sub LV_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
Dim i As Long
For i = 1 To LV.ListItems.Count
With LV.ListItems(i)
If .Selected Then
Data.Files.Add .SubItems(4)
End If
End With
Next
Data.SetData , vbCFFiles
End Sub
Private Sub LVArr_Click(Index As Integer)
Select Case Index
Case 0 'view
DoView LV.SelectedItem
Case 1 'copy
DoCopy
Case 2 'delete
DoDelete
End Select
End Sub
Private Sub DoDelete()
Dim i As Long
Dim RS As Recordset
For i = LV.ListItems.Count To 1 Step -1
With LV.ListItems(i)
If .Selected Then
Set RS = DB.OpenRecordset("Select * From Main Where Index = " & Val(.Key))
RS.Delete
LV.ListItems.Remove i
End If
End With
Next
End Sub
Private Sub DoView(LI As ListItem)
Dim Frm As Form
Dim RS As Recordset
Set RS = DB.OpenRecordset("Select * From Main Where Index = " & Val(LI.Key))
Set Frm = New frmView
Frm.Caption = RS!Path
If chkRemAttr.Value = vbChecked Then
Frm.Text = StripAttr(RS!Text)
Else
Frm.Text = RS!Text
End If
Frm.Search = txtSrch.Text
Frm.Show vbModal
End Sub
Private Sub txtSrch_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
DoSearch
End If
End Sub
Private Sub DoSearch()
Dim RS As Recordset
Dim SQL As String
Dim Srch As String
Srch = Quote("*" & txtSrch.Text & "*")
SQL = "Select * From Main Where (Text Like " & Srch & " Or Name Like " & Srch & ")" & _
" And (" & TypeSQL & ")"
Set RS = DB.OpenRecordset(SQL)
If RS.EOF Then
Caption = "Nothing Found"
Exit Sub
End If
LoadRS RS
End Sub
Private Function TypeSQL() As String
Dim i As Long
For i = 0 To 3
If chkT(i).Value = vbChecked Then
If Len(TypeSQL) Then
TypeSQL = TypeSQL & "Or Type = " & Quote(chkT(i).Tag)
Else
TypeSQL = TypeSQL & " Type = " & Quote(chkT(i).Tag)
End If
TypeSQL = TypeSQL & " "
End If
Next
End Function
Private Sub LoadRS(RS As Recordset)
Dim i As Long
Screen.MousePointer = vbHourglass
LV.ListItems.Clear
RS.MoveLast: RS.MoveFirst
For i = 1 To RS.RecordCount
With LV.ListItems.Add
.Selected = False
.Text = RS!Name
.SubItems(1) = RS!Type
.SmallIcon = CStr(RS!Type)
.SubItems(2) = Format$(RS!Date, "yyyy-mm-dd hh-nn-ss")
.SubItems(3) = Format$(RS!Size, "@@@@@@@")
.SubItems(4) = RS!Path
.Key = RS!Index & "k"
End With
RS.MoveNext
Next
Screen.MousePointer = vbDefault
Caption = LV.ListItems.Count & " Items Found"
End Sub
Private Sub DoCopy()
Dim RS As Recordset
Dim BF As String, i As Long
BF = BrowseForFolderByPath("C:\VB6", hWnd, "Select Folder")
If Len(BF) = 0 Then Exit Sub
For i = 1 To LV.ListItems.Count
With LV.ListItems(i)
If .Selected Then
Set RS = DB.OpenRecordset("Select Path From Main Where Index = " & Val(.Key))
FileCopy RS!Path, QualifyPath(BF) & FileTitle(RS!Path)
End If
End With
Next
End Sub
Private Function DBRecCnt() As Long
Dim RS As Recordset
Set RS = DB.OpenRecordset("Main")
If Not RS.EOF Then
RS.MoveLast: RS.MoveFirst
DBRecCnt = RS.RecordCount
End If
RS.Close
End Function