Storing a list of files from a list box

Question

ftl25 0 Junior Poster in Training

13 Years Ago

Hi,

I have the task of creating an export tool - where a list of files are gathered and zipped up and placed into a folder of the user's choosing. So far I have gathered a list of files and put them in a list box for the user to select which ones they want to zip. What I want to know is how do I now obtain the file list (the displayed objects are just strings); do I need to create FileSystemObjects or something like that? I just don't know where to start. I'm not looking for anyone to write code for me, just to advise me what I need to do to get started.

Any help or suggestions appreciated.

visual-basic-6

2 Contributors
3 Replies
191 Views
1 Day Discussion Span
Latest Post 13 Years Ago Latest Post by ftl25

All 3 Replies

AndreRet 526 Senior Poster

13 Years Ago

Yes, you will have to use the file system object. First check if a file exist, if not create it etc. Just the fact that you did not ask for code, but were willing to do it yourself, herewith all the code you need from an app I did a while ago.

'In a module, add the following

Option Explicit

Public Const OLECMDID_SAVEAS = 4
Public Const OLECMDID_PRINT = 6
Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOW = 5

Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const Flags = SWP_NOMOVE Or SWP_NOSIZE

Public Const STILL_ACTIVE = &H103
Public Const PROCESS_QUERY_INFORMATION = &H400

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwAccess As Long, ByVal fInherit As Integer, ByVal hObject As Long) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long

Public IdxB, ColExp, NRow, MaxFil, TopB, LeftB, TopC, LeftC, AssW, Ass, Ass5 As Integer
Public MyPath, Lang As String
Public Mss(399), Msg(399), amma, MyUrl, MyUrlBuf, EditProg As String
Public MDown As Boolean
Public Retl As Long
Public Sw4, NetSW, NoASW, MaxCmd, i, ExpCount, iRen, MaxCmd1 As Integer
Public iEdit As Integer
Public Sub WaitForEdit(FileD As String, Style As VbAppWinStyle)
Dim llProcess As Long
Dim llReturn As Long

llProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(EditProg + Space(1) + Chr$(34) + FileD + Chr$(34), Style))
Do
    GetExitCodeProcess llProcess, llReturn
    Sleep 100
    DoEvents
Loop While llReturn = STILL_ACTIVE

End Sub

'Add a form and the controls as per the code.
Option Explicit

Private m_Path As String
Const DISTANCE = 20
Dim FSO As New Scripting.FileSystemObject
Dim CmdOn(20) As Integer
Sub GO_Add()
Dim l, Tot, LIndex, LIcon As Long
Dim li As ListItem
Dim fldName, b, c, FileB, FilO As String
Dim Iatt, dist As Integer

lvDir.ListItems.Clear
MaxFil = 0
Tot = 0
dist = AssW

If fileDir.ListCount > NRow Then
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3530 - dist
Else
    lvDir.ColumnHeaders(1).Width = lvDir.Width - 3290 - dist
End If

For l = 0 To fileDir.ListCount - 1
  If fileDir.List(l) <> "" Then
     Set li = lvDir.ListItems.Add(, , StrConv(fileDir.List(l), vbProperCase), 3)
     If Right(fileDir.Path, 1) = "\" Then
        b = fileDir.Path + fileDir.List(l)
     Else
        b = fileDir.Path + "\" + fileDir.List(l)
     End If
     On Error Resume Next
     Iatt = GetAttr(b)
     
     Select Case Iatt
         Case 0, 1, 4, 32
            li.SmallIcon = 5
         Case Else
            li.SmallIcon = 6
     End Select
     If InStr(LCase(fileDir.List(l)), ".exe") > 0 Then
        li.SmallIcon = 12
     End If
     li.ListSubItems.Add , , Format(Str(FileLen(b)), "##,##0")
     c = Left(Str(FileDateTime(b)) + Space(9), 19)
     li.ListSubItems.Add , , Left(c, 10)
     li.ListSubItems.Add , , Right(c, 8)
     Tot = Tot + Val(FileLen(b))
     FilO = Space(500)
     Retl = FindExecutable(b, "", FilO)
     FilO = LCase(FilO)
     If FilO <> "" Then
       i = InStr(FilO, ".exe")
       If i > 0 Then FilO = Left(FilO, i + 3)
       li.ListSubItems.Add , , StrConv(Right(FilO, Len(FilO) - InStrRev(FilO, "\")), vbProperCase)
     End If
  End If
Next l
MaxFil = fileDir.ListCount
StatusBar1.Panels(3).Text = Msg(8) + " : " + Format(Str(MaxFil), "##,##0")
StatusBar1.Panels(4).Text = Msg(9) + " : " + Format(Str(Tot), "##,##0")
End Sub





Sub GO_Cancel()
fileDir.Path = ""
lvDir.ListItems.Clear
End Sub

Sub GO_Exit()
Dim fl As Integer

If ExpCount = 1 Then
   If Ass = 1 Then
      Ass = 0
      Width = Width - AssW
   End If
   SaveSetting App.Title, "Settings", "MainLeft", Me.Left
   SaveSetting App.Title, "Settings", "MainTop", Me.Top
   SaveSetting App.Title, "Settings", "MainWidth", Me.Width
   SaveSetting App.Title, "Settings", "MainHeight", Me.Height
   On Error Resume Next
   Kill App.Path + "\Aida.Tmp"
   End
Else
   ExpCount = ExpCount - 1
   fl = FreeFile
   Open App.Path + "\Aida.Tmp" For Output As #fl
   Print #fl, ExpCount
   Close #fl
   Me.Hide
End If

End Sub

Sub GO_Lang()
Dim Maxmsg, i As Integer

Maxmsg = 100
If Lang = "1ST" Then
   For i = 1 To Maxmsg
      Msg(i) = Mss(i)
   Next i
Else
   For i = Maxmsg + 1 To 2 * Maxmsg
      Msg(i - Maxmsg) = Mss(i)
   Next i
End If

For i = 1 To MaxCmd
   Toolbar.Buttons(i).ToolTipText = Msg(19 + i)
Next i
mnuFile.Caption = Msg(40)
mnuNew.Caption = Msg(41)
mnuExit.Caption = Msg(42)
mnuFolder.Caption = Msg(43)
mnuRename.Caption = Msg(44)
mnuEdit.Caption = Msg(22)
mnuPrograms.Caption = Msg(50)
mnuWeb.Caption = Msg(51)
mnuHelp.Caption = Msg(80)
mnuHelpAida.Caption = Msg(81)
mnuAbout.Caption = Msg(82)
lvDir.ColumnHeaders(1).Text = Msg(4)
lvDir.ColumnHeaders(2).Text = Msg(5)
lvDir.ColumnHeaders(3).Text = Msg(6)
lvDir.ColumnHeaders(4).Text = Msg(7)
lvDir.ColumnHeaders(5).Text = Msg(10)
End Sub

Sub New_Exp()
Dim Exp As frmMain
Dim fl As Integer

ExpCount = ExpCount + 1
fl = FreeFile
Open App.Path + "\Aida.Tmp" For Output As #fl
Print #fl, ExpCount
Close #fl

Set Exp = New frmMain
Exp.Show

End Sub

Property Get Path() As String
    Path = m_Path
End Property





Sub Read_CFG()
Dim i, fl, m As Integer
Dim a, b As String

fl = FreeFile
m = 0
i = 0
On Error GoTo NoMessage
Open App.Path + "\Aida.Txt" For Input As #fl
While Not EOF(fl)
   Line Input #fl, a
   If a <> "" Then
      a = LTrim$(RTrim$(a))
      If Left$(a, 1) <> "[" Or Left$(a, 1) <> "'" Then
         If Left$(a, 1) = Chr$(34) Then
            m = m + 1
            Mss(m) = Mid$(a, 2, Len(a) - 2)
         Else
            i = InStr(a, "=")
           If i > 0 Then
               b = UCase(Left(a, i - 1))
               If b = "LANGUAGE" Then
                  Lang = UCase(Right(a, Len(a) - i))
               End If
          End If
         End If
      End If
   End If
Wend
Close #fl
Exit Sub

NoMessage:
Beep
MsgBox "ERROR! [" + App.Path + "\Aida.Txt] messages file doesn't exist!"
End

End Sub

Private Sub Cmd_Click(Index As Integer)

Select Case Index
    Case 1
       GO_Exit
    Case 3
       If Sw4 = 0 Then
          Sw4 = 1
          Load frmMe
          frmMe.Show 0
       Else
          Sw4 = 0
          Unload frmMe
          Set frmMe = Nothing
       End If
    Case 4
       New_Exp
End Select

End Sub

Private Sub Cmd_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

End Sub




Private Sub Cmd_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Index = 3 Then MDown = False
End Sub

Private Sub Form_Load()
Dim fl, Itop, Ileft, Iwidth, Ih, i As Integer
Dim a, MyPath As String

MaxCmd = 6
MaxCmd1 = 10
MyPath = CurDir
AssW = 1600
Ass = 0

'---------------------
cbSize.Top = -(2 * DISTANCE)
cbSize.Left = -10
Picture1.Left = DISTANCE
Picture1.Top = CoolBar.Height - (2 * DISTANCE)
Picture1.Width = 3230
lblPath.Top = Picture1.Top
Text.Top = Picture1.Top
cbSize.Width = Picture1.Width
Text.Width = 1700
tvwDir.Left = DISTANCE - 10
tvwDir.Top = lblPath.Top + lblPath.Height + DISTANCE
lvDir.Top = tvwDir.Top
CoolBar.Left = DISTANCE
CoolBar.Top = 0
CoolBar1.Left = CoolBar.Left
CoolBar1.Top = CoolBar.Top
Web.Top = CoolBar.Height - (2 * DISTANCE)
Web.Left = DISTANCE
'---------------------
On Error GoTo NoA
ChDir "A:"
ChDir MyPath
NoARes:
On Error GoTo 0

fl = FreeFile
On Error GoTo NoExp
Open App.Path + "\Aida.Tmp" For Input As #fl
Input #fl, ExpCount
Close #fl
NoExpRes:
On Error GoTo 0
Read_CFG
lvDir.ColumnHeaders.Add , , , lvDir.Width - 3090
lvDir.ColumnHeaders.Add , , , 1300
lvDir.ColumnHeaders.Add , , , 1050
lvDir.ColumnHeaders.Add , , , 850
lvDir.ColumnHeaders.Add , , , AssW
lvDir.ColumnHeaders(1).Alignment = lvwColumnLeft
lvDir.ColumnHeaders(2).Alignment = lvwColumnRight
lvDir.ColumnHeaders(3).Alignment = lvwColumnCenter
lvDir.ColumnHeaders(4).Alignment = lvwColumnCenter
GO_Lang
Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000) + (ExpCount - 1) * 300
Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000) + (ExpCount - 1) * 200
Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 8500)
Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)

fileDir.ReadOnly = True
fileDir.Archive = True
fileDir.Normal = True
fileDir.System = True
fileDir.Hidden = True
StatusBar1.Panels(1) = Format(Date, "dddd, mmm d yyyy")
StatusBar1.Panels(2) = Format(Time, "h:m:s")
fileDir.Pattern = "*.*"
Text.Text = fileDir.Pattern
DirRefresh
Me.Show
EditProg = Space(500)
Retl = FindExecutable(App.Path + "\Aida.Txt", "", EditProg)
i = InStr(EditProg, Chr$(0))
If i <> 0 Then
   EditProg = Left$(EditProg, i - 1)
End If
Exit Sub


NoExp:
ExpCount = 1
fl = FreeFile
Open App.Path + "\Aida.Tmp" For Output As #fl
Print #fl, ExpCount
Close #fl
Resume NoExpRes

NoA:
Resume NoARes
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
GO_Exit
End Sub


Private Sub Form_Resize()
Dim tvwTop As Single
Dim dist As Integer
    
If WindowState = 1 Then Exit Sub
dist = AssW
CoolBar.Width = ScaleWidth - DISTANCE * 2
CoolBar1.Width = CoolBar.Width
tvwDir.Width = ScaleWidth / 2.8
tvwDir.Height = ScaleHeight - 1120
lvDir.Width = ScaleWidth - tvwDir.Width - DISTANCE
lvDir.Height = tvwDir.Height
lvDir.Left = tvwDir.Width + DISTANCE
Text.Left = ScaleWidth - Text.Width - DISTANCE
lblPath.Left = cbSize.Width + DISTANCE
lblPath.Width = ScaleWidth - Text.Width - cbSize.Width - 2 * DISTANCE
StatusBar1.Panels(1).Width = tvwDir.Width / 2
StatusBar1.Panels(2).Width = tvwDir.Width / 2
StatusBar1.Panels(3).Width = lvDir.Width / 2
StatusBar1.Panels(4).Width = lvDir.Width / 2
NRow = tvwDir.Height / 280
Picture2.Left = CoolBar.Width - Picture2.Width - 80
Picture3.Left = CoolBar1.Width - Picture3.Width
Web.Top = CoolBar.Height - (2 * DISTANCE)
Web.Left = DISTANCE
Web.Width = ScaleWidth - 20
Web.Height = ScaleHeight - CoolBar.Height - StatusBar1.Height + 40
Text1.Width = ScaleWidth - MaxCmd1 * 480 - Picture3.Width
Text1.Left = Toolbar1.ButtonWidth * MaxCmd1 + 50
dist = AssW
If MaxFil = 0 Then
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3290 - dist
ElseIf fileDir.ListCount > NRow Then
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3530 - dist
 Else
  lvDir.ColumnHeaders(1).Width = lvDir.Width - 3490 - dist
End If

End Sub

Private Sub DirRefresh()
Dim Ico As Integer
Dim DName As String
    
Dim dr As Scripting.Drive
Dim ntw As Scripting.Drive
Dim rootNode As node, nd As node, locNode As node, ntwNode As node, aNode As node
 
Set rootNode = tvwDir.Nodes.Add(, , "\\Desktop", Msg(1), 9)
Set locNode = tvwDir.Nodes.Add(rootNode.Key, tvwChild, "\\MyComputer", Msg(15), 1)
Set ntwNode = tvwDir.Nodes.Add(rootNode.Key, tvwChild, "\\Network", Msg(16), 7)
rootNode.EnsureVisible
rootNode.Expanded = True

For Each dr In FSO.Drives
    If UCase(dr.Path) = "A:" And NoASW = 1 Then
       Set nd = tvwDir.Nodes.Add(locNode.Key, tvwChild, , "A:Floppy", 10)
       GoTo Dopo
    End If
    Err.Clear
    Retl = GetDriveType(dr.Path)
    If Retl = 4 Then
       NetSW = 1
       On Error GoTo GotErr
       Set nd = tvwDir.Nodes.Add(ntwNode.Key, tvwChild, dr.Path & "\", dr.Path & " " & dr.VolumeName, 2)
       nd.Sorted = True
       If Err = 0 Then AddDummyChild nd
    Else
       On Error GoTo GotErr
       If Retl = 5 Then
          Ico = 8
          DName = dr.VolumeName
          cbSize.AddItem dr.Path + Space(1) + Msg(13) + Right(Space(16) + Format(dr.AvailableSpace, " ##,##0"), 16)
       ElseIf Retl = 2 Then
          Ico = 10
          If dr.VolumeName <> "" Then
             DName = dr.VolumeName
          Else
             DName = "Floppy"
          End If
          cbSize.AddItem dr.Path + Space(1) + Msg(13) + Right(Space(16) + Format(dr.AvailableSpace, " ##,##0"), 16)
       Else
          Ico = 2
          DName = dr.VolumeName
          cbSize.AddItem dr.Path + Space(1) + Msg(13) + Right(Space(16) + Format(dr.AvailableSpace, " ##,##0"), 16)
       End If
       Set nd = tvwDir.Nodes.Add(locNode.Key, tvwChild, dr.Path & "\", dr.Path & " " & DName, Ico)
       nd.Sorted = True
       If Err = 0 Then AddDummyChild nd
    End If
GotErrRes:
    On Error GoTo 0
Dopo:
    Next
cbSize.ListIndex = 0
locNode.Expanded = True
If NetSW = 1 Then ntwNode.Expanded = True
Exit Sub

GotErr:
If Err = 71 Then
   Resume GotErrRes
Else
   Beep
   End
End If
End Sub

Sub AddDummyChild(nd As node)
If nd.Children = 0 Then
   tvwDir.Nodes.Add nd.Index, tvwChild, , "***"
End If
End Sub

Private Sub lblPath_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To MaxCmd
   CmdOn(i) = 0
Next i
End Sub

Private Sub lvDir_Click()
If Right(fileDir.Path, 1) = "\" Then
   lblPath.Caption = fileDir.Path + lvDir.SelectedItem.Text
Else
   lblPath.Caption = fileDir.Path + "\" + lvDir.SelectedItem.Text
End If
End Sub

Private Sub lvDir_DblClick()'Listview control
Dim b As String

If Right(fileDir.Path, 1) = "\" Then
   b = fileDir.Path + lvDir.SelectedItem.Text
Else
   b = fileDir.Path + "\" + lvDir.SelectedItem.Text
End If
Retl = ShellExecute(hwnd, "Open", b, "", "", SW_SHOWNORMAL)
End Sub

Private Sub lvDir_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)'listview

If Button = 2 Then
 ' SourceFile = fileDir.Path + "\" + lvDir.SelectedItem.Text
  '  If SourceFile = "" Then Exit Sub
    
    ' save values for later
   ' Set SourceTreeView = TreeView1(Index)
  '  ShiftState = Shift
 '   lvDir.OLEDrag
End If
End Sub

Private Sub lvDir_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)'Listview
'Dim b As String

'If lvDir.SelectedItem.index <> IdxB Then
'   IdxB = lvDir.SelectedItem.index
'If lvDir.ListItems.Count > 0 Then

'If Right(fileDir.Path, 1) = "\" Then
'   lblPath.Caption = fileDir.Path + lvDir.SelectedItem.Text
'Else
'   lblPath.Caption = fileDir.Path + "\" + lvDir.SelectedItem.Text
'End If
'End If
'End If
End Sub

Private Sub mnuAbout_Click()
If Sw4 = 0 Then
   Sw4 = 1
   Load frmMe
   frmMe.Show 0
Else
   Sw4 = 0
   Unload frmMe
   Set frmMe = Nothing
End If
End Sub

Private Sub mnuEdit_Click()
WaitForEdit App.Path + "\Aida.Txt", vbNormalFocus
Read_CFG
GO_Lang
End Sub

Private Sub mnuExit_Click()
GO_Exit
End Sub

Private Sub mnuFolder_Click()
Dim MyDir, NewDir As String

If MyPath = "" Then
   Retl = MsgBox(Msg(70), 48)
Else
   NewDir = InputBox("", Msg(71))
   If NewDir <> "" Then
      MkDir MyPath + "\" + NewDir
   End If
   On Error Resume Next
   Retl = Shell(App.Path + "\" + App.EXEName + ".exe", vbNormalFocus)
   End
End If
End Sub

Private Sub mnuHelp_Click()
Dim frm As New frmEdit
Load frm
frm.Show
End Sub

Private Sub mnuNew_Click()
New_Exp
End Sub

Private Sub mnuRename_Click()
Dim NewDir As String

If MyPath = "" Then
   Retl = MsgBox(Msg(70), 48)
Else
   NewDir = InputBox("", Msg(71), MyPath)
   If NewDir <> "" Then
      Name MyPath As NewDir
      On Error Resume Next
      Retl = Shell(App.Path + "\" + App.EXEName + ".exe", vbNormalFocus)
      End
    End If
End If
End Sub

Private Sub Text_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
   KeyAscii = 0
   lblPath.Caption = fileDir.Path
   fileDir.Pattern = Text.Text
  ' Text.Text = fileDir.Pattern
   GO_Add
End If
End Sub

Private Sub Text_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To MaxCmd
   CmdOn(i) = 0
Next i
End Sub

Private Sub Text1_Click()
'Web.Navigate Text1.List(Text1.ListIndex)
End Sub

Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    'Web.Navigate Text1.Text
End If
End Sub

Private Sub tvwDir_Click()'Treeview control
Dim node As node
Dim buffer As String * 512
Dim dist As Integer

MaxFil = 0
MyPath = tvwDir.SelectedItem.Key
m_Path = MyPath

If tvwDir.SelectedItem.Text = Msg(1) Then
  
ElseIf tvwDir.SelectedItem.Text = Msg(14) Or tvwDir.SelectedItem.Text = Msg(15) Or tvwDir.SelectedItem.Text = Msg(16) Then
   lvDir.ListItems.Clear
   dist = AssW
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3290 - dist
Else
   fileDir.Path = m_Path
   lblPath.Caption = fileDir.Path
   GO_Add
End If
End Sub

Private Sub tvwDir_Collapse(ByVal node As MSComctlLib.node)'Treeview control
'Caption = tvwDir.Nodes(1).Key
'Refres
'MyPath = node.Key
' ColExp = 1
End Sub

Private Sub tvwDir_Expand(ByVal node As MSComctlLib.node) 'Treeview control
Dim nd As node

If node.Children = 0 Or node.Children > 1 Then Exit Sub
If node.Child.Text <> "***" Then Exit Sub
tvwDir.Nodes.Remove node.Child.Index
AddSubdirs node
  
End Sub

Private Sub AddSubdirs(ByVal node As MSComctlLib.node)
Dim fld As Scripting.Folder
Dim nd As node

On Error GoTo LFine
For Each fld In FSO.GetFolder(node.Key).SubFolders
    Set nd = tvwDir.Nodes.Add(node, tvwChild, fld.Path, fld.Name, 3)
    nd.Sorted = True
    nd.ExpandedImage = 4
    On Error Resume Next
    If fld.SubFolders.Count Then AddDummyChild nd
Next
LFine:
End Sub

Reply to this topic

Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.

AndreRet 526 Senior Poster · Answer 1 · 2010-10-07T17:22:26+00:00

Yes, you will have to use the file system object. First check if a file exist, if not create it etc. Just the fact that you did not ask for code, but were willing to do it yourself, herewith all the code you need from an app I did a while ago.

'In a module, add the following

Option Explicit

Public Const OLECMDID_SAVEAS = 4
Public Const OLECMDID_PRINT = 6
Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOW = 5

Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const Flags = SWP_NOMOVE Or SWP_NOSIZE

Public Const STILL_ACTIVE = &H103
Public Const PROCESS_QUERY_INFORMATION = &H400

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwAccess As Long, ByVal fInherit As Integer, ByVal hObject As Long) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long

Public IdxB, ColExp, NRow, MaxFil, TopB, LeftB, TopC, LeftC, AssW, Ass, Ass5 As Integer
Public MyPath, Lang As String
Public Mss(399), Msg(399), amma, MyUrl, MyUrlBuf, EditProg As String
Public MDown As Boolean
Public Retl As Long
Public Sw4, NetSW, NoASW, MaxCmd, i, ExpCount, iRen, MaxCmd1 As Integer
Public iEdit As Integer
Public Sub WaitForEdit(FileD As String, Style As VbAppWinStyle)
Dim llProcess As Long
Dim llReturn As Long

llProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(EditProg + Space(1) + Chr$(34) + FileD + Chr$(34), Style))
Do
    GetExitCodeProcess llProcess, llReturn
    Sleep 100
    DoEvents
Loop While llReturn = STILL_ACTIVE

End Sub

'Add a form and the controls as per the code.
Option Explicit

Private m_Path As String
Const DISTANCE = 20
Dim FSO As New Scripting.FileSystemObject
Dim CmdOn(20) As Integer
Sub GO_Add()
Dim l, Tot, LIndex, LIcon As Long
Dim li As ListItem
Dim fldName, b, c, FileB, FilO As String
Dim Iatt, dist As Integer

lvDir.ListItems.Clear
MaxFil = 0
Tot = 0
dist = AssW

If fileDir.ListCount > NRow Then
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3530 - dist
Else
    lvDir.ColumnHeaders(1).Width = lvDir.Width - 3290 - dist
End If

For l = 0 To fileDir.ListCount - 1
  If fileDir.List(l) <> "" Then
     Set li = lvDir.ListItems.Add(, , StrConv(fileDir.List(l), vbProperCase), 3)
     If Right(fileDir.Path, 1) = "\" Then
        b = fileDir.Path + fileDir.List(l)
     Else
        b = fileDir.Path + "\" + fileDir.List(l)
     End If
     On Error Resume Next
     Iatt = GetAttr(b)
     
     Select Case Iatt
         Case 0, 1, 4, 32
            li.SmallIcon = 5
         Case Else
            li.SmallIcon = 6
     End Select
     If InStr(LCase(fileDir.List(l)), ".exe") > 0 Then
        li.SmallIcon = 12
     End If
     li.ListSubItems.Add , , Format(Str(FileLen(b)), "##,##0")
     c = Left(Str(FileDateTime(b)) + Space(9), 19)
     li.ListSubItems.Add , , Left(c, 10)
     li.ListSubItems.Add , , Right(c, 8)
     Tot = Tot + Val(FileLen(b))
     FilO = Space(500)
     Retl = FindExecutable(b, "", FilO)
     FilO = LCase(FilO)
     If FilO <> "" Then
       i = InStr(FilO, ".exe")
       If i > 0 Then FilO = Left(FilO, i + 3)
       li.ListSubItems.Add , , StrConv(Right(FilO, Len(FilO) - InStrRev(FilO, "\")), vbProperCase)
     End If
  End If
Next l
MaxFil = fileDir.ListCount
StatusBar1.Panels(3).Text = Msg(8) + " : " + Format(Str(MaxFil), "##,##0")
StatusBar1.Panels(4).Text = Msg(9) + " : " + Format(Str(Tot), "##,##0")
End Sub





Sub GO_Cancel()
fileDir.Path = ""
lvDir.ListItems.Clear
End Sub

Sub GO_Exit()
Dim fl As Integer

If ExpCount = 1 Then
   If Ass = 1 Then
      Ass = 0
      Width = Width - AssW
   End If
   SaveSetting App.Title, "Settings", "MainLeft", Me.Left
   SaveSetting App.Title, "Settings", "MainTop", Me.Top
   SaveSetting App.Title, "Settings", "MainWidth", Me.Width
   SaveSetting App.Title, "Settings", "MainHeight", Me.Height
   On Error Resume Next
   Kill App.Path + "\Aida.Tmp"
   End
Else
   ExpCount = ExpCount - 1
   fl = FreeFile
   Open App.Path + "\MyFIle.Tmp" For Output As #fl
   Print #fl, ExpCount
   Close #fl
   Me.Hide
End If

End Sub

Sub GO_Lang()
Dim Maxmsg, i As Integer

Maxmsg = 100
If Lang = "1ST" Then
   For i = 1 To Maxmsg
      Msg(i) = Mss(i)
   Next i
Else
   For i = Maxmsg + 1 To 2 * Maxmsg
      Msg(i - Maxmsg) = Mss(i)
   Next i
End If

For i = 1 To MaxCmd
   Toolbar.Buttons(i).ToolTipText = Msg(19 + i)
Next i
mnuFile.Caption = Msg(40)
mnuNew.Caption = Msg(41)
mnuExit.Caption = Msg(42)
mnuFolder.Caption = Msg(43)
mnuRename.Caption = Msg(44)
mnuEdit.Caption = Msg(22)
mnuPrograms.Caption = Msg(50)
mnuWeb.Caption = Msg(51)
mnuHelp.Caption = Msg(80)
mnuHelpAida.Caption = Msg(81)
mnuAbout.Caption = Msg(82)
lvDir.ColumnHeaders(1).Text = Msg(4)
lvDir.ColumnHeaders(2).Text = Msg(5)
lvDir.ColumnHeaders(3).Text = Msg(6)
lvDir.ColumnHeaders(4).Text = Msg(7)
lvDir.ColumnHeaders(5).Text = Msg(10)
End Sub

Sub New_Exp()
Dim Exp As frmMain
Dim fl As Integer

ExpCount = ExpCount + 1
fl = FreeFile
Open App.Path + "\MyFile.Tmp" For Output As #fl
Print #fl, ExpCount
Close #fl

Set Exp = New frmMain
Exp.Show

End Sub

Property Get Path() As String
    Path = m_Path
End Property

Sub Read_CFG()
Dim i, fl, m As Integer
Dim a, b As String

fl = FreeFile
m = 0
i = 0
On Error GoTo NoMessage
Open App.Path + "\MyFile.Txt" For Input As #fl
While Not EOF(fl)
   Line Input #fl, a
   If a <> "" Then
      a = LTrim$(RTrim$(a))
      If Left$(a, 1) <> "[" Or Left$(a, 1) <> "'" Then
         If Left$(a, 1) = Chr$(34) Then
            m = m + 1
            Mss(m) = Mid$(a, 2, Len(a) - 2)
         Else
            i = InStr(a, "=")
           If i > 0 Then
               b = UCase(Left(a, i - 1))
               If b = "LANGUAGE" Then
                  Lang = UCase(Right(a, Len(a) - i))
               End If
          End If
         End If
      End If
   End If
Wend
Close #fl
Exit Sub

NoMessage:
Beep
MsgBox "ERROR! [" + App.Path + "\MyFile.Txt] messages file doesn't exist!"
End

End Sub

Private Sub Cmd_Click(Index As Integer)

Select Case Index
    Case 1
       GO_Exit
    Case 3
       If Sw4 = 0 Then
          Sw4 = 1
          Load frmMe
          frmMe.Show 0
       Else
          Sw4 = 0
          Unload frmMe
          Set frmMe = Nothing
       End If
    Case 4
       New_Exp
End Select
End Sub

Private Sub Cmd_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Index = 3 Then MDown = False
End Sub

Private Sub Form_Load()
Dim fl, Itop, Ileft, Iwidth, Ih, i As Integer
Dim a, MyPath As String

MaxCmd = 6
MaxCmd1 = 10
MyPath = CurDir
AssW = 1600
Ass = 0

'---------------------
cbSize.Top = -(2 * DISTANCE)
cbSize.Left = -10
Picture1.Left = DISTANCE
Picture1.Top = CoolBar.Height - (2 * DISTANCE)
Picture1.Width = 3230
lblPath.Top = Picture1.Top
Text.Top = Picture1.Top
cbSize.Width = Picture1.Width
Text.Width = 1700
tvwDir.Left = DISTANCE - 10
tvwDir.Top = lblPath.Top + lblPath.Height + DISTANCE
lvDir.Top = tvwDir.Top
CoolBar.Left = DISTANCE
CoolBar.Top = 0
CoolBar1.Left = CoolBar.Left
CoolBar1.Top = CoolBar.Top
Web.Top = CoolBar.Height - (2 * DISTANCE)
Web.Left = DISTANCE
'---------------------
On Error GoTo NoA
ChDir "A:"
ChDir MyPath
NoARes:
On Error GoTo 0

fl = FreeFile
On Error GoTo NoExp
Open App.Path + "\MyFile.Tmp" For Input As #fl
Input #fl, ExpCount
Close #fl
NoExpRes:
On Error GoTo 0
Read_CFG
lvDir.ColumnHeaders.Add , , , lvDir.Width - 3090
lvDir.ColumnHeaders.Add , , , 1300
lvDir.ColumnHeaders.Add , , , 1050
lvDir.ColumnHeaders.Add , , , 850
lvDir.ColumnHeaders.Add , , , AssW
lvDir.ColumnHeaders(1).Alignment = lvwColumnLeft
lvDir.ColumnHeaders(2).Alignment = lvwColumnRight
lvDir.ColumnHeaders(3).Alignment = lvwColumnCenter
lvDir.ColumnHeaders(4).Alignment = lvwColumnCenter
GO_Lang
Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000) + (ExpCount - 1) * 300
Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000) + (ExpCount - 1) * 200
Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 8500)
Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)

fileDir.ReadOnly = True
fileDir.Archive = True
fileDir.Normal = True
fileDir.System = True
fileDir.Hidden = True
StatusBar1.Panels(1) = Format(Date, "dddd, mmm d yyyy")
StatusBar1.Panels(2) = Format(Time, "h:m:s")
fileDir.Pattern = "*.*"
Text.Text = fileDir.Pattern
DirRefresh
Me.Show
EditProg = Space(500)
Retl = FindExecutable(App.Path + "\MyFile.Txt", "", EditProg)
i = InStr(EditProg, Chr$(0))
If i <> 0 Then
   EditProg = Left$(EditProg, i - 1)
End If
Exit Sub


NoExp:
ExpCount = 1
fl = FreeFile
Open App.Path + "\MyFile.Tmp" For Output As #fl
Print #fl, ExpCount
Close #fl
Resume NoExpRes

NoA:
Resume NoARes
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
GO_Exit
End Sub


Private Sub Form_Resize()
Dim tvwTop As Single
Dim dist As Integer
    
If WindowState = 1 Then Exit Sub
dist = AssW
CoolBar.Width = ScaleWidth - DISTANCE * 2
CoolBar1.Width = CoolBar.Width
tvwDir.Width = ScaleWidth / 2.8
tvwDir.Height = ScaleHeight - 1120
lvDir.Width = ScaleWidth - tvwDir.Width - DISTANCE
lvDir.Height = tvwDir.Height
lvDir.Left = tvwDir.Width + DISTANCE
Text.Left = ScaleWidth - Text.Width - DISTANCE
lblPath.Left = cbSize.Width + DISTANCE
lblPath.Width = ScaleWidth - Text.Width - cbSize.Width - 2 * DISTANCE
StatusBar1.Panels(1).Width = tvwDir.Width / 2
StatusBar1.Panels(2).Width = tvwDir.Width / 2
StatusBar1.Panels(3).Width = lvDir.Width / 2
StatusBar1.Panels(4).Width = lvDir.Width / 2
NRow = tvwDir.Height / 280
Picture2.Left = CoolBar.Width - Picture2.Width - 80
Picture3.Left = CoolBar1.Width - Picture3.Width
Web.Top = CoolBar.Height - (2 * DISTANCE)
Web.Left = DISTANCE
Web.Width = ScaleWidth - 20
Web.Height = ScaleHeight - CoolBar.Height - StatusBar1.Height + 40
Text1.Width = ScaleWidth - MaxCmd1 * 480 - Picture3.Width
Text1.Left = Toolbar1.ButtonWidth * MaxCmd1 + 50
dist = AssW
If MaxFil = 0 Then
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3290 - dist
ElseIf fileDir.ListCount > NRow Then
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3530 - dist
 Else
  lvDir.ColumnHeaders(1).Width = lvDir.Width - 3490 - dist
End If
End Sub

Private Sub DirRefresh()
Dim Ico As Integer
Dim DName As String
    
Dim dr As Scripting.Drive
Dim ntw As Scripting.Drive
Dim rootNode As node, nd As node, locNode As node, ntwNode As node, aNode As node
 
Set rootNode = tvwDir.Nodes.Add(, , "\\Desktop", Msg(1), 9)
Set locNode = tvwDir.Nodes.Add(rootNode.Key, tvwChild, "\\MyComputer", Msg(15), 1)
Set ntwNode = tvwDir.Nodes.Add(rootNode.Key, tvwChild, "\\Network", Msg(16), 7)
rootNode.EnsureVisible
rootNode.Expanded = True

For Each dr In FSO.Drives
    If UCase(dr.Path) = "A:" And NoASW = 1 Then
       Set nd = tvwDir.Nodes.Add(locNode.Key, tvwChild, , "A:Floppy", 10)
       GoTo Dopo
    End If
    Err.Clear
    Retl = GetDriveType(dr.Path)
    If Retl = 4 Then
       NetSW = 1
       On Error GoTo GotErr
       Set nd = tvwDir.Nodes.Add(ntwNode.Key, tvwChild, dr.Path & "\", dr.Path & " " & dr.VolumeName, 2)
       nd.Sorted = True
       If Err = 0 Then AddDummyChild nd
    Else
       On Error GoTo GotErr
       If Retl = 5 Then
          Ico = 8
          DName = dr.VolumeName
          cbSize.AddItem dr.Path + Space(1) + Msg(13) + Right(Space(16) + Format(dr.AvailableSpace, " ##,##0"), 16)
       ElseIf Retl = 2 Then
          Ico = 10
          If dr.VolumeName <> "" Then
             DName = dr.VolumeName
          Else
             DName = "Floppy"
          End If
          cbSize.AddItem dr.Path + Space(1) + Msg(13) + Right(Space(16) + Format(dr.AvailableSpace, " ##,##0"), 16)
       Else
          Ico = 2
          DName = dr.VolumeName
          cbSize.AddItem dr.Path + Space(1) + Msg(13) + Right(Space(16) + Format(dr.AvailableSpace, " ##,##0"), 16)
       End If
       Set nd = tvwDir.Nodes.Add(locNode.Key, tvwChild, dr.Path & "\", dr.Path & " " & DName, Ico)
       nd.Sorted = True
       If Err = 0 Then AddDummyChild nd
    End If
GotErrRes:
    On Error GoTo 0
Dopo:
    Next
cbSize.ListIndex = 0
locNode.Expanded = True
If NetSW = 1 Then ntwNode.Expanded = True
Exit Sub

GotErr:
If Err = 71 Then
   Resume GotErrRes
Else
   Beep
   End
End If
End Sub

Sub AddDummyChild(nd As node)
If nd.Children = 0 Then
   tvwDir.Nodes.Add nd.Index, tvwChild, , "***"
End If
End Sub

Private Sub lblPath_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To MaxCmd
   CmdOn(i) = 0
Next i
End Sub

Private Sub lvDir_Click()
If Right(fileDir.Path, 1) = "\" Then
   lblPath.Caption = fileDir.Path + lvDir.SelectedItem.Text
Else
   lblPath.Caption = fileDir.Path + "\" + lvDir.SelectedItem.Text
End If
End Sub

Private Sub lvDir_DblClick()'Listview control
Dim b As String

If Right(fileDir.Path, 1) = "\" Then
   b = fileDir.Path + lvDir.SelectedItem.Text
Else
   b = fileDir.Path + "\" + lvDir.SelectedItem.Text
End If
Retl = ShellExecute(hwnd, "Open", b, "", "", SW_SHOWNORMAL)
End Sub

Private Sub lvDir_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)'listview

If Button = 2 Then
 ' SourceFile = fileDir.Path + "\" + lvDir.SelectedItem.Text
  '  If SourceFile = "" Then Exit Sub
    
    ' save values for later
   ' Set SourceTreeView = TreeView1(Index)
  '  ShiftState = Shift
 '   lvDir.OLEDrag
End If
End Sub

Private Sub lvDir_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)'Listview
'Dim b As String

'If lvDir.SelectedItem.index <> IdxB Then
'   IdxB = lvDir.SelectedItem.index
'If lvDir.ListItems.Count > 0 Then

'If Right(fileDir.Path, 1) = "\" Then
'   lblPath.Caption = fileDir.Path + lvDir.SelectedItem.Text
'Else
'   lblPath.Caption = fileDir.Path + "\" + lvDir.SelectedItem.Text
'End If
'End If
'End If
End Sub

Private Sub mnuAbout_Click()
If Sw4 = 0 Then
   Sw4 = 1
   Load frmMe
   frmMe.Show 0
Else
   Sw4 = 0
   Unload frmMe
   Set frmMe = Nothing
End If
End Sub

Private Sub mnuEdit_Click()
WaitForEdit App.Path + "\Aida.Txt", vbNormalFocus
Read_CFG
GO_Lang
End Sub

Private Sub mnuExit_Click()
GO_Exit
End Sub

Private Sub mnuFolder_Click()
Dim MyDir, NewDir As String

If MyPath = "" Then
   Retl = MsgBox(Msg(70), 48)
Else
   NewDir = InputBox("", Msg(71))
   If NewDir <> "" Then
      MkDir MyPath + "\" + NewDir
   End If
   On Error Resume Next
   Retl = Shell(App.Path + "\" + App.EXEName + ".exe", vbNormalFocus)
   End
End If
End Sub

Private Sub mnuHelp_Click()
Dim frm As New frmEdit
Load frm
frm.Show
End Sub

Private Sub mnuNew_Click()
New_Exp
End Sub

Private Sub mnuRename_Click()
Dim NewDir As String

If MyPath = "" Then
   Retl = MsgBox(Msg(70), 48)
Else
   NewDir = InputBox("", Msg(71), MyPath)
   If NewDir <> "" Then
      Name MyPath As NewDir
      On Error Resume Next
      Retl = Shell(App.Path + "\" + App.EXEName + ".exe", vbNormalFocus)
      End
    End If
End If
End Sub

Private Sub Text_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
   KeyAscii = 0
   lblPath.Caption = fileDir.Path
   fileDir.Pattern = Text.Text
  ' Text.Text = fileDir.Pattern
   GO_Add
End If
End Sub

Private Sub Text_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To MaxCmd
   CmdOn(i) = 0
Next i
End Sub

Private Sub Text1_Click()
'Web.Navigate Text1.List(Text1.ListIndex)
End Sub

Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    'Web.Navigate Text1.Text
End If
End Sub

Private Sub tvwDir_Click()'Treeview control
Dim node As node
Dim buffer As String * 512
Dim dist As Integer

MaxFil = 0
MyPath = tvwDir.SelectedItem.Key
m_Path = MyPath

If tvwDir.SelectedItem.Text = Msg(1) Then
  
ElseIf tvwDir.SelectedItem.Text = Msg(14) Or tvwDir.SelectedItem.Text = Msg(15) Or tvwDir.SelectedItem.Text = Msg(16) Then
   lvDir.ListItems.Clear
   dist = AssW
   lvDir.ColumnHeaders(1).Width = lvDir.Width - 3290 - dist
Else
   fileDir.Path = m_Path
   lblPath.Caption = fileDir.Path
   GO_Add
End If
End Sub

Private Sub tvwDir_Collapse(ByVal node As MSComctlLib.node)'Treeview control
'Caption = tvwDir.Nodes(1).Key
'Refres
'MyPath = node.Key
' ColExp = 1
End Sub

Private Sub tvwDir_Expand(ByVal node As MSComctlLib.node) 'Treeview control
Dim nd As node

If node.Children = 0 Or node.Children > 1 Then Exit Sub
If node.Child.Text <> "***" Then Exit Sub
tvwDir.Nodes.Remove node.Child.Index
AddSubdirs node
  
End Sub

Private Sub AddSubdirs(ByVal node As MSComctlLib.node)
Dim fld As Scripting.Folder
Dim nd As node

On Error GoTo LFine
For Each fld In FSO.GetFolder(node.Key).SubFolders
    Set nd = tvwDir.Nodes.Add(node, tvwChild, fld.Path, fld.Name, 3)
    nd.Sorted = True
    nd.ExpandedImage = 4
    On Error Resume Next
    If fld.SubFolders.Count Then AddDummyChild nd
Next
LFine:
End Sub

ftl25 0 Junior Poster in Training · Answer 2 · 2010-10-07T19:59:51+00:00

Wow, thanks so much, I'll try to adapt that to what I'm trying to do and let you know the result. Much appreciated!

Storing a list of files from a list box

Recommended Answers Collapse Answers

All 3 Replies

Recommended Answers