I frequently use a scanner for records archiving. I built a quick little DB for the purpose of renaming files, so they are useful to users without needing to give them a database. As an example, I have copies of forms that are used for medical patients. I scan the pages for each patient, which makes a PDF. I then want to rename that file to the patients name, with date or anything else.
Using some code from Dev Ashish's website, I was able to make a nice form that can browse to a directory, list the files, I can pick one, it displays the PDF in a web control object, I can see what the content is and make a new name, which then automatically renames the file. Works great.
There is one little issue.... The list of files is not alphabetical. I am looking for someone to give me a code change that would order those files and the directory list if possible.
Here is the code that I am using for this form:
Option Compare Database
Option Explicit
'-------------------------
----------
----------
-----
' Updated By Mehmet Acikgoz (30 July 1998)
'-------------------------
----------
----------
-----
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of Dev Ashish
'
Dim mstPath As String
Dim mboolRoot As Boolean
Dim mstFilePath As String
Dim mboolClick As Boolean
Dim mboolUp As Boolean
Private Sub cmdNavUp_Click()
Dim stTmp As String
Dim I As Integer
mboolUp = True
If Len(mstPath) = 2 Then
Me!lbxFiles.SetFocus
Me!lbxFiles.RowSource = ""
Me!lblPath.Caption = ""
Me.Caption = "Explorer"
Call sFillRoot
Else
For I = Len(mstPath) To 1 Step 0 - 1
stTmp = Mid$(mstPath, I, 1)
If stTmp = "\" Then
mstPath = Left$(mstPath, I - 1)
Call sNavigate(mstPath)
Me!lbxFiles.Requery
Exit For
End If
Next I
End If
End Sub
Private Sub Command24_Click()
WB.Navigate URL:="c:\"
MsgBox "OK", vbApplicationModal
Name Forms!frmExplorer![Path] As Forms!frmExplorer![NewPath
]
Forms!frmExplorer.Refresh
End Sub
Private Sub Form_Current()
'Navigate to the current record's Web site
'If there's no URL stored in the field, then display Google search engine.
WB.Navigate URL:=Forms!frmExplorer![Pa
th]
End Sub
Private Sub Form_Error(DataErr As Integer, Response As Integer)
DoCmd.Hourglass False
End Sub
Private Sub Form_Open(Cancel As Integer)
Call sFillRoot
Me!lblPath.Caption = ""
End Sub
Private Sub sFillRoot()
Dim strAllDrives As String
Dim strTmp As String, strOut As String
Dim loDir As clsDir
Set loDir = New clsDir
strAllDrives = fGetDrives()
strOut = vbNullString
mboolRoot = True
Do
strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) - 1)
strAllDrives = Mid$(strAllDrives, InStr(strAllDrives, vbNullChar) + 1)
strOut = strOut & strTmp & ";"
Loop While strAllDrives <> ""
'trim strOut
strOut = Left$(strOut, Len(strOut) - 1)
'populate the ListBox
With Me!lbxFolders
.RowSourceType = "Value List"
.RowSource = strOut
End With
Me!cmdNavUp.Enabled = False
Set loDir = Nothing
mstPath = vbNullString
End Sub
Private Sub lbxFiles_AfterUpdate()
'Forms!frmExplorer![WB].Na
vigate2 Forms!frmExplorer![Path]
WB.Navigate URL:=Forms!frmExplorer![Pa
th]
End Sub
Private Sub lbxFiles_DblClick(Cancel As Integer)
Dim varRet
Dim stPath As String
If mstPath = vbNullString Then
stPath = Left$(Me!lbxFolders, Len(Me!lbxFolders) - 1)
Else
stPath = mstPath & "\" & Me!lbxFolders
End If
varRet = fHandleFile(stPath & "\" & Me!lbxFiles, WIN_NORMAL)
End Sub
Private Sub lbxFolders_Click()
If mstPath = vbNullString Then
mstFilePath = Left$(Me!lbxFolders, Len(Me!lbxFolders) - 1)
Else
mstFilePath = mstPath & "\" & Me!lbxFolders
End If
mboolClick = True: mboolUp = False
DoCmd.Hourglass True
Me!lbxFiles.Requery
DoCmd.Hourglass False
End Sub
Private Sub lbxFolders_DblClick(Cancel
As Integer)
Dim stPath As String
Dim stOut As String
Dim stFiles As String
Dim I As Long
If mstPath = vbNullString Then
stPath = Left$(Me!lbxFolders, Len(Me!lbxFolders) - 1)
Else
stPath = mstPath & "\" & Me!lbxFolders
End If
mboolClick = False: mboolUp = False
Me!lbxFiles.RowSource = ""
Call sNavigate(stPath)
End Sub
Sub sNavigate(stPath As String)
Dim stFolders As String
stFolders = fCreateFolderList(stPath)
If stFolders <> vbNullString Then
'Populate Folders List Box
With Me!lbxFolders
.RowSourceType = "Value List"
.RowSource = stFolders
End With
mstPath = stPath
Else
mboolClick = False: mboolUp = False
DoCmd.Hourglass True
Me!lbxFiles.Requery
DoCmd.Hourglass False
End If
Me!cmdNavUp.Enabled = (mboolRoot)
Me.Caption = mstPath & "\ - Explorer"
Me!lblPath.Caption = mstPath & "\"
End Sub
Function fListFill(ctl As Control, varID As Variant, lngRow As Long, _
lngCol As Long, intCode As Integer) As Variant
Static sastFiles() As String
Static slngCount As Long
Static sloclDir As clsDir
Dim I As Long
Dim varRet As Variant
Dim X As Long
Select Case intCode
Case acLBInitialize
Set sloclDir = New clsDir
If Not mstFilePath = vbNullString _
And mboolClick And Not mboolUp Then
With sloclDir
.FillFiles mstFilePath
slngCount = .GetFileCount
If slngCount > 0 Then
ReDim sastFiles(0 To slngCount - 1)
For I = 1 To slngCount
sastFiles(I - 1) = .NameOfFile(I)
Next I
PDF_accSortStringArray sastFiles()
End If
End With
Else
slngCount = 0
End If
varRet = True
Case acLBOpen
varRet = Timer
Case acLBGetRowCount
varRet = slngCount
Case acLBGetValue
If slngCount > 0 And mboolClick And Not mboolUp Then
varRet = sastFiles(lngRow)
Else
varRet = vbNullString
End If
Case acLBEnd
Set sloclDir = Nothing
Erase sastFiles
End Select
fListFill = varRet
End Function
Private Sub Command25_Click()
On Error GoTo Err_Command25_Click
DoCmd.Close
Exit_Command25_Click:
Exit Sub
Err_Command25_Click:
MsgBox Err.Description
Resume Exit_Command25_Click
End Sub
Start Free Trial
