|
here is the entire code for the project......
------------------------------------------------------------------------------------------
Option Explicit
Const MODULE_NAME As String = "Multi"
Const ID_TOT = 1
Const ID_PC1 = 2
Const ID_PC = 1
Const ID_FS = 2
Const ID_FS1 = 1
Const ID_FS2 = 2
Const TOT_RESET = "Total :- "
Dim CB As CodeBook
Dim WithEvents m_Drg As cDrag_Drop '** attach drag drop function to listbox
'*************************************************************
'Created on: 04/22/08
'Procedure: private Method CreateTaskPanel
'*************************************************************
Private Sub CreateTaskPanel()
'/* Begin Error Handler
On Error GoTo HandleError
Call mProcStack.EnterProc("CreateTaskPanel", MODULE_NAME)
Dim Group As TaskPanelGroup
Dim Item As TaskPanelGroupItem
Set Group = TaskP1.Groups.Add(ID_PC, "Print Counter")
Group.Tooltip = "Total Print Counter"
Group.IconIndex = 1
Group.Items.Add ID_TOT, TOT_RESET, xtpTaskItemTypeText
Group.Items.Item(ID_TOT).Bold = True
Group.Items.Item(ID_TOT).SetMargins 35, 0, 0, 0
Set Item = Group.Items.Add(ID_PC1, "", xtpTaskItemTypeControl)
Set Item.Control = Picture1
Item.SetMargins 45, 10, 0, 0
PC1.BackColor = Item.BackColor
Picture1.BackColor = Item.BackColor
Set Group = TaskP1.Groups.Add(ID_FS, " File Search")
Group.Tooltip = "Search Files"
Group.IconIndex = 2
Group.SetIconPadding 4, 0, 0, 0
Group.Expanded = False <-------------------------------------- the error comes from here.......if i disable this line then the error goes away.
Set Item = Group.Items.Add(ID_FS1, "", xtpTaskItemTypeControl)
Set Item.Control = Picture2
Picture2.BackColor = Item.BackColor
Label1.BackColor = Item.BackColor
Set Item = Group.Items.Add(ID_FS2, "Add Path", xtpTaskItemTypeLink)
Item.SetMargins 40, 8, 0, 0
TaskP1.SetImageList ImageList1
'/* End Error Handler
CreateTaskPanel_Done:
Call mProcStack.ExitProc("CreateTaskPanel")
Exit Sub
HandleError:
Process_Error MODULE_NAME, Err, "CreateTaskPanel"
Resume CreateTaskPanel_Done
End Sub
'*************************************************************
'Created on: 04/23/08
'Procedure: Private Method AddPrint
'*************************************************************
Private Function AddPrint(FN As String) As Integer
'/* Begin Error Handler
On Error GoTo HandleError
Call mProcStack.EnterProc("AddPrint", MODULE_NAME)
Dim Pos As Integer
Dim Tmp As String
Dim SingleTmp As String
Pos = InStrRev(FN, "=")
Pos = Pos + 1
Do
Tmp = Mid(FN, Pos, 1)
If Tmp <> " " Then
If IsNumeric(Tmp) = True Then
SingleTmp = SingleTmp + Tmp
Else
Exit Do
End If
End If
Pos = Pos + 1
Loop While Pos <= Len(FN)
AddPrint = Val(SingleTmp)
'/* End Error Handler
AddPrint_Done:
Call mProcStack.ExitProc("AddPrint")
Exit Function
HandleError:
Process_Error MODULE_NAME, Err, "AddPrint"
Resume AddPrint_Done
End Function
'*************************************************************
'Created on: 04/22/08
'Procedure: Private Method count
'*************************************************************
Private Sub CountPrint()
'/* Begin Error Handler
On Error GoTo HandleError
Call mProcStack.EnterProc("CountPrint", MODULE_NAME)
Dim i As Integer
Dim TCount As Integer
Dim FdrCount As Integer
Dim TmpCount As Integer
Dim FdrTmp As String
Dim fName As String
TCount = 0
FdrCount = 0
i = 1
Do
With ListView1
With .ListItems(i)
If .SubItems(2).Text = True Then
TCount = TCount + AddPrint(.Text)
Else
FdrTmp = CB.Search(.SubItems(1).Text, "*.jpg", True, rtnFILE)
If FdrTmp <> "" Then
Do
fName = CB.StripDelimitedItem(FdrTmp, ";", False)
TmpCount = AddPrint(fName)
TCount = TCount + TmpCount
FdrCount = FdrCount + TmpCount
Loop While Len(FdrTmp) > 0
If PC1.Value = xtpChecked Then
If Right$(Trim$(.Text), 1) <> "=" Then
fName = .SubItems(1).Text & "=" & FdrCount
Else
fName = .SubItems(1).Text & FdrCount
End If
CB.Rename .SubItems(1).Text, fName
FdrCount = 0
End If
End If
End If
i = i + 1
End With
End With
Loop While i <= ListView1.ListItems.Count
TaskP1.Groups.Item(1).Items.Item(ID_TOT).Caption = TOT_RESET & TCount & " Sheets"
'/* End Error Handler
CountPrint_Done:
Call mProcStack.ExitProc("CountPrint")
Exit Sub
HandleError:
Process_Error MODULE_NAME, Err, "CountPrint"
Resume CountPrint_Done
End Sub
'*************************************************************
'Created on: 04/22/08
'Procedure: Private Method Form_Load
'*************************************************************
Private Sub Form_Load()
'/* Begin Error Handler
On Error GoTo HandleError
Call mProcStack.EnterProc("Form_Load", MODULE_NAME)
Dim cReg As cRegistry
Set CB = New CodeBook
Set m_Drg = New cDrag_Drop
Set cReg = New cRegistry
With cReg '** create registry entries
.ClassKey = HKEY_CURRENT_USER
.SectionKey = "Software\Multi-Op\Paths"
If .KeyExists = False Then .CreateKey
End With
CreateTaskPanel '** creating the task panel
sForm.Show '** load search paths in the beginning
sForm.Hide
'/* End Error Handler
Form_Load_Done:
Call mProcStack.ExitProc("Form_Load")
Exit Sub
HandleError:
Process_Error MODULE_NAME, Err, "Form_Load"
Resume Form_Load_Done
End Sub
'*************************************************************
'Created on: 04/23/08
'Procedure: Private Method Form_Resize
'*************************************************************
Private Sub Form_Resize()
If Me.WindowState = vbMinimized Then TrayIcon1.MinimizeToTray Me.hwnd
End Sub
'*************************************************************
'Created on: 04/22/08
'Procedure: Private Method Form_Unload
'*************************************************************
Private Sub Form_Unload(Cancel As Integer)
'/* Begin Error Handler
On Error GoTo HandleError
Call mProcStack.EnterProc("Form_Unload", MODULE_NAME)
If m_Drg.DragHwnd <> 0 Then m_Drg.StopDrag
Unload sForm
'/* End Error Handler
Form_Unload_Done:
Call mProcStack.ExitProc("Form_Unload")
Exit Sub
HandleError:
Process_Error MODULE_NAME, Err, "Form_Unload"
Resume Form_Unload_Done
End Sub
'*************************************************************
'Created on: 04/25/08
'Procedure: Private Method ListView1_ItemDblClick
'*************************************************************
Private Sub ListView1_ItemDblClick(Button As Integer, Item As ciaXPListView30.tListItemInfo, ItemIndex As Long)
If ListView1.CtrlKeyStatus = False Then
CB.ExecuteFile ListView1.ListItems(ItemIndex).SubItems(1).Text, essSW_MAXIMIZE
Else
CB.ExecuteFile ListView1.ListItems(ItemIndex).SubItems(1).Text, essSW_MAXIMIZE, , , "edit"
End If
End Sub
Private Sub ListView1_KeyDown(KeyCode As Integer, Shift As Integer)
Dim Result As Integer
Dim Tmp As String
Dim delRes As Long
Dim cFile(0) As String
Tmp = ListView1.ListItems(ListView1.SelectedIndex).SubItems(1).Text
If KeyCode = 46 Then
Result = MsgBox("Do You Want To Delete?", vbInformation + vbSystemModal + vbYesNo, "Delete File")
CB.StripDelimitedItem Tmp, "\", True
If Result = 6 Then
delRes = CB.DeleteFiles(Tmp, ListView1.ListItems(ListView1.SelectedIndex).Text, True, True, True, True)
If delRes = 0 Then ListView1.ItemsDeleteSelected
End If
End If
If ListView1.CtrlKeyStatus = True And KeyCode = vbKeyC Then
cFile(0) = Tmp
CB.ClipboardCopyFiles cFile
End If
End Sub
'*************************************************************
'Created on: 04/22/08
'Procedure: Private Method m_Drg_FilesDroped
'*************************************************************
Private Sub m_Drg_FilesDroped()
'/* Begin Error Handler
On Error GoTo HandleError
Call mProcStack.EnterProc("m_Drg_FilesDroped", MODULE_NAME)
Dim i As Integer
Dim colX As cColumn
Dim itmX As cListItem
Dim fName As String
Dim FileOK As Boolean
i = 0
ListView1.BeginUpdate
ListView1.ClearAll
ListView1.Columns.Add " File Names", , 150
ListView1.Columns.Add " Paths", , 290
ListView1.Columns.Add "", , 0
Do
If CB.FileExists(m_Drg.FileName(i)) = True Then
fName = CB.GetFileNameFromPath(m_Drg.FileName(i))
FileOK = True
Else
If CB.FolderExists(m_Drg.FileName(i)) = True Then
fName = CB.StripDelimitedItem(CB.TrimNull(m_Drg.FileName(i)), "\", True)
FileOK = False
End If
End If
With ListView1
With .ListItems
Set itmX = .Add(fName)
itmX.SubItems(1).Text = m_Drg.FileName(i)
itmX.SubItems(2).Text = FileOK
End With
End With
i = i + 1
Loop While i < m_Drg.FileCount
ListView1.EndUpdate
ListView1.Sort 1, LVSortOrderAscending
CountPrint
'/* End Error Handler
m_Drg_FilesDroped_Done:
Call mProcStack.ExitProc("m_Drg_FilesDroped")
Exit Sub
HandleError:
Process_Error MODULE_NAME, Err, "m_Drg_FilesDroped"
Resume m_Drg_FilesDroped_Done
End Sub
'*************************************************************
'Created on: 04/24/08
'Procedure: Private Method SearchBox_KeyPress
'*************************************************************
Private Sub SearchBox_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then SearchBtn_Click
End Sub
'*************************************************************
'Created on: 04/25/08
'Procedure: Private Method SearchFiles
'*************************************************************
Private Sub SearchFiles()
Dim i As Integer
Dim sFound As String
Dim sTmp As String
Dim itmX As cListItem
i = 1
sFound = ""
ListView1.ClearAll
ListView1.Columns.Add " File Names", , 150
ListView1.Columns.Add " Paths", , 290
Do
With sForm.sListView
If .ListItems(i).Checked = True Then
sString.Caption = CB.CompactPath(.ListItems(i).SubItems(2).Text, sString.Width - 1, Me.hDC)
sFound = CB.Search(.ListItems(i).SubItems(2).Text, "*" & Trim$(SearchBox.Text) & "*", True, rtnFILE)
If Trim(sFound) <> "" Then
ListView1.BeginUpdate
Do
sTmp = CB.StripDelimitedItem(sFound, ";", False)
Set itmX = ListView1.ListItems.Add(CB.GetFileNameFromPath(sTmp))
itmX.SubItems(1).Text = sTmp
Loop While Len(sFound) > 0
ListView1.EndUpdate
End If
If CB.SearchBrk = True Then Exit Do
End If
End With
i = i + 1
Loop While i <= sForm.sListView.ListItems.Count
End Sub
'*************************************************************
'Created on: 04/24/08
'Procedure: Private Method SearchBtn_Click
'*************************************************************
Private Sub SearchBtn_Click()
If Trim(SearchBox.Text) = "" Then Exit Sub
If sForm.sListView.CheckedCount = 0 Then
MsgBox "No Path Selected To Search!", vbCritical + vbOKOnly, "Search"
Exit Sub
End If
SearchBtn.Enabled = False
SearchBox.Locked = True
TaskP1.Groups.Item(ID_FS).Items(ID_FS2).Enabled = False
Label1.Visible = True
sString.Visible = True
CancelBtn.Enabled = True
SearchFiles
If CB.SearchBrk = False Then CancelBtn_Click
End Sub
'*************************************************************
'Created on: 04/24/08
'Procedure: Private Method CancelBtn_Click
'*************************************************************
Private Sub CancelBtn_Click()
SearchBtn.Enabled = True
TaskP1.Groups.Item(ID_FS).Items(ID_FS2).Enabled = True
Label1.Visible = False
sString.Visible = False
CancelBtn.Enabled = False
SearchBox.Locked = False
CB.SearchBrk = True
End Sub
'*************************************************************
'Created on: 04/23/08
'Procedure: Private Method TaskP1_GroupExpanding
'*************************************************************
Private Sub TaskP1_GroupExpanding(ByVal Group As XtremeTaskPanel.ITaskPanelGroup, ByVal Expanding As Boolean, Cancel As Boolean)
If Expanding = False Then
If Group.Id = ID_PC Then
TaskP1.Groups(ID_FS).Expanded = True
Else
TaskP1.Groups(ID_PC).Expanded = True
End If
Else
If Group.Id = ID_PC Then
m_Drg.DragHwnd = ListView1.hwnd
m_Drg.StartDrag
ListView1.AllowColumnSorting = False
ListView1.ClearAll
TaskP1.Groups(ID_FS).Expanded = False
ElseIf Group.Id = ID_FS Then
m_Drg.StopDrag
ListView1.AllowColumnSorting = True
ListView1.ClearAll
TaskP1.Groups(ID_PC).Expanded = False
End If
End If
End Sub
'*************************************************************
'Created on: 04/24/08
'Procedure: Private Method TaskP1_ItemClick
'*************************************************************
Private Sub TaskP1_ItemClick(ByVal Item As XtremeTaskPanel.ITaskPanelGroupItem)
If Item.Id = ID_FS2 Then sForm.Show 1
End Sub
'*************************************************************
'Created on: 04/23/08
'Procedure: Private Method TrayIcon1_Click
'*************************************************************
Private Sub TrayIcon1_Click()
TrayIcon1.MaximizeFromTray Me.hwnd
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------
this is the main form of my project..........
hope this helps......
thanx
angel
-------------
Platform:- VB6 SP6
OS:- XP SP3
Product:- xtreme suite 11.2.2
|