L
Livin
This is code I had working a few years back in Excel 2000 & XP using SQL
2000. Now I'm needing the code again but using SQL Express 2005 and with
Excel 2003 and it seems to have broken, I think.
I've setup SQL Express 2005 with the Table "Logos" with Columns imgLogo &
txtLogo
I'm trying to take files from a folder and place the text name and the image
itself into the database.
I was doing this with CopyLogosToDataBase() - but this seems to fail to get
the file names at all now - i.e. it returns no files in the search... it
worked perfecting in Excel 2000 (a few years back).
I have replaced CopyLogosToDataBase() with GetAllFiles() &
GetAllFilesInDir() & InsertLogoToDataBase() - they run in this order. The
new GetAllFiles* functions get the file names properly and the Insert
function is the core of the CopyLogos sub which inserts into the SQL DB.
Any help you guru's can give a born-again noobie is highly appreciated!
thanks,
Aaron
MODULE...
Public cnnODBC, cnnDatabase, cnnTable, cnnUserID, cnnPassword As String
Public cnn1 As ADODB.Connection
Public logoTable As String
Public rsUnit As ADODB.Recordset
Sub Aaron()
cnnODBC = "r2\sqlexpress" 'Server Name
cnnDatabase = "lrhist" 'Database Name
cnnTable = "tbLrmstr" 'Table Name
cnnUserID = "sa" 'Database User ID
cnnPassword = "sa" 'Database User Password
logoTable = "Logos" 'Table with Logo data
End Sub
Sub OpenSQLDB()
Dim strCnn As String
Dim logoTable As String
Call Aaron 'Change to function for specific settings (above)
Set cnn1 = New ADODB.Connection
' Open connection
strCnn = "Provider=sqloledb;Data Source=" & cnnODBC & ";Initial
Catalog=" & cnnDatabase & _
";User Id=" & cnnUserID & ";Password=" & cnnPassword & ""
cnn1.Open strCnn
End Sub
Sub SetFirstTime()
Range("isFirstTime") = True
End Sub
Function InsertLogoToDataBase(ByVal FileName As String) As Variant
If Right(FileName, 4) = ".bmp" Then
Dim strStream As ADODB.stream
Call OpenSQLDB
Set strStream = New ADODB.stream
strStream.Type = adTypeBinary
strStream.Open
Set rsUnit = New ADODB.Recordset
rsUnit.Open logoTable, cnn1, adOpenStatic, adLockPessimistic
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveFirst
End If
FileName = Left(FileName, Len(FileName) - 4)
v = InStrRev(FileName, "\")
FileName = Right(FileName, Len(FileName) - v)
rsUnit.Fields("txtLogo") = FileName
strStream.LoadFromFile ActiveWorkbook.Path & "\" & FileName & ".BMP"
rsUnit.Fields("imgLogo").Value = strStream.Read
rsUnit.Update
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveNext
End If
Range("isFirstTime") = False
End If
End Function
Sub GetAllFiles()
Dim varFileArray As Variant
Dim lngI As Long
Dim strDirName As String
Const NO_FILES_IN_DIR As Long = 9
Const INVALID_DIR As Long = 13
On Error GoTo Test_Err
strDirName = ActiveWorkbook.Path
varFileArray = GetAllFilesInDir(strDirName)
For lngI = 0 To UBound(varFileArray)
'MsgBox varFileArray(lngI)
InsertLogoToDataBase (varFileArray(lngI))
Next lngI
Test_Err:
Select Case Err.Number
Case NO_FILES_IN_DIR
MsgBox "The directory named '" & strDirName _
& "' contains no files."
Case INVALID_DIR
MsgBox "'" & strDirName & "' is not a valid directory."
Case 0
Case Else
MsgBox "Error #" & Err.Number & " - " & Err.Description
End Select
End Sub
Function GetAllFilesInDir(ByVal strDirPath As String) As Variant
' Loop through the directory specified in strDirPath and save each
' file name in an array, then return that array to the calling
' procedure.
' Return False if strDirPath is not a valid directory.
Dim strTempName As String
Dim varFiles() As Variant
Dim lngFileCount As Long
On Error GoTo GetAllFiles_Err
' Make sure that strDirPath ends with a "\" character.
If Right$(strDirPath, 1) <> "\" Then
strDirPath = strDirPath & "\"
End If
' Make sure strDirPath is a directory.
If GetAttr(strDirPath) = vbDirectory Then
strTempName = Dir(strDirPath, vbDirectory)
Do Until Len(strTempName) = 0
' Exclude ".", "..".
If (strTempName <> ".") And (strTempName <> "..") Then
' Make sure we do not have a sub-directory name.
If (GetAttr(strDirPath & strTempName) _
And vbDirectory) <> vbDirectory Then
' Increase the size of the array
' to accommodate the found filename
' and add the filename to the array.
ReDim Preserve varFiles(lngFileCount)
varFiles(lngFileCount) = strTempName
lngFileCount = lngFileCount + 1
End If
End If
' Use the Dir function to find the next filename.
strTempName = Dir()
Loop
' Return the array of found files.
GetAllFilesInDir = varFiles
End If
GetAllFiles_End:
Exit Function
GetAllFiles_Err:
GetAllFilesInDir = False
Resume GetAllFiles_End
End Function
Sub CopyLogosToDataBase()
'OLD CODE
Dim strStream As ADODB.stream
Call OpenSQLDB
Set strStream = New ADODB.stream
strStream.Type = adTypeBinary
strStream.Open
Set rsUnit = New ADODB.Recordset
rsUnit.Open logoTable, cnn1, adOpenStatic, adLockPessimistic
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveFirst
End If
Dim lngCount As Long
Dim FileName As String
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeAllFiles
.LookIn = ActiveWorkbook.Path
.FileName = "*.bmp"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" files found."
For lngCount = 1 To .FoundFiles.Count
FileName = .FoundFiles.Item(lngCount)
If Right(FileName, 4) = ".bmp" Then
FileName = Left(FileName, Len(FileName) - 4)
v = InStrRev(FileName, "\")
FileName = Right(FileName, Len(FileName) - v)
MsgBox FileName, vbOKOnly, "Adding Logo Name"
rsUnit.Fields("txtLogo") = FileName
strStream.LoadFromFile ActiveWorkbook.Path & "\" &
FileName & ".BMP"
rsUnit.Fields("imgLogo").Value = strStream.Read
rsUnit.Update
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveNext
End If
End If
Next lngCount
End If
End With
Range("isFirstTime") = False
End Sub
2000. Now I'm needing the code again but using SQL Express 2005 and with
Excel 2003 and it seems to have broken, I think.
I've setup SQL Express 2005 with the Table "Logos" with Columns imgLogo &
txtLogo
I'm trying to take files from a folder and place the text name and the image
itself into the database.
I was doing this with CopyLogosToDataBase() - but this seems to fail to get
the file names at all now - i.e. it returns no files in the search... it
worked perfecting in Excel 2000 (a few years back).
I have replaced CopyLogosToDataBase() with GetAllFiles() &
GetAllFilesInDir() & InsertLogoToDataBase() - they run in this order. The
new GetAllFiles* functions get the file names properly and the Insert
function is the core of the CopyLogos sub which inserts into the SQL DB.
Any help you guru's can give a born-again noobie is highly appreciated!
thanks,
Aaron
MODULE...
Public cnnODBC, cnnDatabase, cnnTable, cnnUserID, cnnPassword As String
Public cnn1 As ADODB.Connection
Public logoTable As String
Public rsUnit As ADODB.Recordset
Sub Aaron()
cnnODBC = "r2\sqlexpress" 'Server Name
cnnDatabase = "lrhist" 'Database Name
cnnTable = "tbLrmstr" 'Table Name
cnnUserID = "sa" 'Database User ID
cnnPassword = "sa" 'Database User Password
logoTable = "Logos" 'Table with Logo data
End Sub
Sub OpenSQLDB()
Dim strCnn As String
Dim logoTable As String
Call Aaron 'Change to function for specific settings (above)
Set cnn1 = New ADODB.Connection
' Open connection
strCnn = "Provider=sqloledb;Data Source=" & cnnODBC & ";Initial
Catalog=" & cnnDatabase & _
";User Id=" & cnnUserID & ";Password=" & cnnPassword & ""
cnn1.Open strCnn
End Sub
Sub SetFirstTime()
Range("isFirstTime") = True
End Sub
Function InsertLogoToDataBase(ByVal FileName As String) As Variant
If Right(FileName, 4) = ".bmp" Then
Dim strStream As ADODB.stream
Call OpenSQLDB
Set strStream = New ADODB.stream
strStream.Type = adTypeBinary
strStream.Open
Set rsUnit = New ADODB.Recordset
rsUnit.Open logoTable, cnn1, adOpenStatic, adLockPessimistic
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveFirst
End If
FileName = Left(FileName, Len(FileName) - 4)
v = InStrRev(FileName, "\")
FileName = Right(FileName, Len(FileName) - v)
rsUnit.Fields("txtLogo") = FileName
strStream.LoadFromFile ActiveWorkbook.Path & "\" & FileName & ".BMP"
rsUnit.Fields("imgLogo").Value = strStream.Read
rsUnit.Update
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveNext
End If
Range("isFirstTime") = False
End If
End Function
Sub GetAllFiles()
Dim varFileArray As Variant
Dim lngI As Long
Dim strDirName As String
Const NO_FILES_IN_DIR As Long = 9
Const INVALID_DIR As Long = 13
On Error GoTo Test_Err
strDirName = ActiveWorkbook.Path
varFileArray = GetAllFilesInDir(strDirName)
For lngI = 0 To UBound(varFileArray)
'MsgBox varFileArray(lngI)
InsertLogoToDataBase (varFileArray(lngI))
Next lngI
Test_Err:
Select Case Err.Number
Case NO_FILES_IN_DIR
MsgBox "The directory named '" & strDirName _
& "' contains no files."
Case INVALID_DIR
MsgBox "'" & strDirName & "' is not a valid directory."
Case 0
Case Else
MsgBox "Error #" & Err.Number & " - " & Err.Description
End Select
End Sub
Function GetAllFilesInDir(ByVal strDirPath As String) As Variant
' Loop through the directory specified in strDirPath and save each
' file name in an array, then return that array to the calling
' procedure.
' Return False if strDirPath is not a valid directory.
Dim strTempName As String
Dim varFiles() As Variant
Dim lngFileCount As Long
On Error GoTo GetAllFiles_Err
' Make sure that strDirPath ends with a "\" character.
If Right$(strDirPath, 1) <> "\" Then
strDirPath = strDirPath & "\"
End If
' Make sure strDirPath is a directory.
If GetAttr(strDirPath) = vbDirectory Then
strTempName = Dir(strDirPath, vbDirectory)
Do Until Len(strTempName) = 0
' Exclude ".", "..".
If (strTempName <> ".") And (strTempName <> "..") Then
' Make sure we do not have a sub-directory name.
If (GetAttr(strDirPath & strTempName) _
And vbDirectory) <> vbDirectory Then
' Increase the size of the array
' to accommodate the found filename
' and add the filename to the array.
ReDim Preserve varFiles(lngFileCount)
varFiles(lngFileCount) = strTempName
lngFileCount = lngFileCount + 1
End If
End If
' Use the Dir function to find the next filename.
strTempName = Dir()
Loop
' Return the array of found files.
GetAllFilesInDir = varFiles
End If
GetAllFiles_End:
Exit Function
GetAllFiles_Err:
GetAllFilesInDir = False
Resume GetAllFiles_End
End Function
Sub CopyLogosToDataBase()
'OLD CODE
Dim strStream As ADODB.stream
Call OpenSQLDB
Set strStream = New ADODB.stream
strStream.Type = adTypeBinary
strStream.Open
Set rsUnit = New ADODB.Recordset
rsUnit.Open logoTable, cnn1, adOpenStatic, adLockPessimistic
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveFirst
End If
Dim lngCount As Long
Dim FileName As String
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeAllFiles
.LookIn = ActiveWorkbook.Path
.FileName = "*.bmp"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" files found."
For lngCount = 1 To .FoundFiles.Count
FileName = .FoundFiles.Item(lngCount)
If Right(FileName, 4) = ".bmp" Then
FileName = Left(FileName, Len(FileName) - 4)
v = InStrRev(FileName, "\")
FileName = Right(FileName, Len(FileName) - v)
MsgBox FileName, vbOKOnly, "Adding Logo Name"
rsUnit.Fields("txtLogo") = FileName
strStream.LoadFromFile ActiveWorkbook.Path & "\" &
FileName & ".BMP"
rsUnit.Fields("imgLogo").Value = strStream.Read
rsUnit.Update
If Range("isFirstTime") = True Then
rsUnit.AddNew
Else
rsUnit.MoveNext
End If
End If
Next lngCount
End If
End With
Range("isFirstTime") = False
End Sub