Sorry Sir,
I failed to do it. I dont where i am making the mistake. First I opened
your
mentioned site, copy the code, paste in a new standard module, save it
,
named it "New1".
Then opened the second new module pasted the rest of the code you have
written here. save it , named it "New2"
Made an AutoExec and call the code from RunCode method . But it did not
work.
The changes I did i have highlighted /shown below (in *** sign) ,
please
note and advise my mistake. The rest changes was the line break up
problem
only, which I did it.
Regards.
:
Irshad,
I've been too lazy to post this code to my website, so I'll post it
here.
You need to place the code into a standard module. You'll also need
the
code
found at
http://www.pacificdb.com.au/MVP/Code/GetFileName.htm, which
you
should also place into a standard module.
Add the following function to a standard module (probably best to put
it
in
the same module as the main code shown below). It assumes your icon
directory is called \Icons, which is a subdirectory of the folder in
which
the database resides:
Public Function IconsExist() As Boolean
Dim sPath As String
sPath = CurrentProject.Path & "\Icons\"
If (PathIsDirectory(sPath) = False) Or Len(Dir(sPath, vbNormal)) =
0
Then
Call UnpackFile
End If
End Sub
**** instead of End Sub, I put End Function. I could trace these, As
it
was in red color.
You can call this function from a macro on startup.
1. Create a macro called "AutoExec".
2. Add a RunCode action, specifying IconsExist() as the Function Name.
Private Const BLOCK_SIZE = 32768
Private Const TABLE_NAME = "tblBLOB"
Public Declare Function PathIsDirectory Lib "shlwapi.dll" _
Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
Public Function CreateTable() As Boolean
Dim db As Database
Dim sSQL As String
On Error GoTo Proc_Err
Set db = CurrentDb
Start:
CreateTable = True
sSQL = "CREATE TABLE " & TABLE_NAME & " " _
& "(ID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " _
& "FileName TEXT NOT NULL CONSTRAINT FileName UNIQUE , " _
& "Destination TEXT(255) NOT NULL , " _
& "File LongBINARY);"
db.Execute sSQL, dbFailOnError
Proc_Exit:
On Error Resume Next
Set db = Nothing
Exit Function
Proc_Err:
CreateTable = False
If (Err.Number = 3010) Then
DoCmd.Beep
If vbYes = MsgBox("Table '" & TABLE_NAME & "' exists -
DELETE?",
_
vbDefaultButton2 + vbYesNo) Then
DoCmd.DeleteObject acTable, TABLE_NAME
Resume Start
End If
End If
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description,
vbOKOnly + vbExclamation, "Error"
Resume Proc_Exit
End Function
'**************************************************************
' FUNCTION: StoreFile()
'
' PURPOSE:
' Stores a binary file in a table.
'
' AUTHOR:
' Unknown, but modified from code taken from MSDN Online
'
http://support.microsoft.com/default.aspx?scid=kb;en-us;103257
'
' OPTIONAL ARGUMENT:
' vFileName - The path and filename of the file to store.
'
' IMPORTANT NOTE:
' This function stores the filename and destination path separately,
' based on the file's original location. The UnpackFile() function
' names the unpacked file according to the name stored in the table,
' and places it in the folder specified in the same table.
'
' RETURN:
' True if successful - False if not.
'**************************************************************
Public Function StoreFile(Optional vFileName As Variant) As Boolean
Dim db As Database
Dim rs As DAO.Recordset
Dim iBlocks As Integer
Dim iFileNo As Integer
Dim iCtr As Integer
Dim lFileLen As Long
Dim lRemainder As Long
Dim sData As String
Dim vRetVal As Variant
Dim sFileName As String
Dim lFlags As Long
On Error GoTo Proc_Err
StoreFile = True
Set db = CurrentDb
'Check that the table exists, and if not, create it
If IsNull(DLookup("[Name]", "MSysObjects", "[Name]=""" &
TABLE_NAME &
"""")) Then
CreateTable
End If
Set rs = db.OpenRecordset(TABLE_NAME, dbOpenDynaset)
If Err.Number = 3078 Then CreateTable
If IsMissing(vFileName) Then
lFlags = gfnNOCHANGEDIR + gfnPATHMUSTEXIST + gfnFILEMUSTEXIST
+
gfnSHAREAWARE + gfnEXPLORER + gfnLONGNAMES
**** here the second line was broken, so i brought all to the previous
line,
then also red highlight was there then I added a + sign in between and
it
was
ok, like below :
lFlags = gfnNOCHANGEDIR + gfnPATHMUSTEXIST + gfnFILEMUSTEXIST + _
gfnSHAREAWARE + gfnEXPLORER + gfnLONGNAMES
*****
vFileName = GetFileName(, lFlags, "Select file to store",
Access.hWndAccessApp, CurrentProject.Path, gfnALLFILES)
If Len(Nz(vFileName, "")) = 0 Then
DoCmd.Beep
MsgBox "Operation cancelled by user.", vbOKOnly +
vbInformation,
"No filename supplied"
GoTo Proc_Exit
Else
sFileName = CStr(vFileName)
End If
Else
sFileName = CStr(vFileName)
End If
' Open the source file.
iFileNo = FreeFile
Open sFileName For Binary Access Read As iFileNo
' Get the length of the file.
lFileLen = LOF(iFileNo)
If lFileLen = 0 Then
StoreFile = False
GoTo Proc_Exit
End If
' Calculate the number of blocks to read and leftover bytes.
iBlocks = lFileLen \ BLOCK_SIZE
lRemainder = lFileLen Mod BLOCK_SIZE
' Put the record in edit mode.
rs.AddNew
' Read the leftover data, writing it to the table.
sData = String$(lRemainder, 32)
Get iFileNo, , sData
rs!File.AppendChunk sData
' Read the remaining blocks of data, writing them to the table.
sData = String$(BLOCK_SIZE, 32)
For iCtr = 1 To iBlocks
Get iFileNo, , sData
rs!File.AppendChunk (sData)
Next iCtr
rs!FileName = Dir(sFileName, vbNormal)
rs!Destination = Replace(sFileName, rs!FileName, "")
rs.Update
Proc_Exit:
On Error Resume Next
Close iFileNo
StoreFile = lFileLen
rs.Close
Set rs = Nothing
Set db = Nothing
Exit Function
Proc_Err:
DoCmd.Beep
MsgBox "Error storing " & sFileName & "." & vbCrLf & _
Err.Number & vbCrLf & vbCrLf & Err.Description, _
vbOKOnly + vbExclamation, "Could not store file"
StoreFile = False
Resume Proc_Exit
Resume
End Function
'**************************************************************
' FUNCTION: UnpackFile()
'
' PURPOSE:
' Unloads a binary file from a table field, and restores it to disk.
' If no file is specified, this function unpacks all the files found
in
the table
'
' AUTHOR:
' Unknown, but modified from code taken from MSDN Online
'
http://support.microsoft.com/default.aspx?scid=kb;en-us;103257
'
' OPTIONAL ARGUMENT:
' vFileName - The filename (as stored in the table) of the file to
unpack.
'
' RETURN:
' True if successful - False if not.
'**************************************************************
Function UnpackFile(Optional vFileName As Variant) As Boolean
Dim db As Database
Dim rs As DAO.Recordset
Dim iBlocks As Integer
Dim iFileNo As Integer
Dim iCtr As Integer
Dim lFileLen As Long
Dim lRemainer As Long
Dim sData As String
Dim sSQL As String
Dim sFileName As String
On Error GoTo Err_UnpackFile
UnpackFile = True
'Select the file, if specified, or the whole table
sSQL = "SELECT * FROM " & TABLE_NAME
If Not IsMissing(vFileName) Then
sSQL = sSQL & " WHERE FileName = """ & vFileName & """"
End If
Set db = CurrentDb
Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
Do While Not rs.EOF
'Make sure the destination path exists
If (PathIsDirectory(rs!Destination) = False) Then
MkDir rs!Destination
End If
'Get the size of the file.
lFileLen = rs!File.FieldSize()
' Calculate number of blocks to write, plus any remaining
bytes.
iBlocks = lFileLen \ BLOCK_SIZE
lRemainer = lFileLen Mod BLOCK_SIZE
'Open the destination file.
iFileNo = FreeFile
sFileName = rs!Destination & rs!FileName
Open sFileName For Binary As iFileNo
'Write the remaining data to the output file.
sData = rs!File.GetChunk(0, lRemainer)
Put iFileNo, , sData
' Write the remaining blocks of data to the output file.
For iCtr = 1 To iBlocks
' Reads a chunk and writes it to output file.
sData = rs!File.GetChunk((iCtr - 1) * BLOCK_SIZE +
lRemainer,
BLOCK_SIZE)
Put iFileNo, , sData
Next iCtr
Close iFileNo
rs.MoveNext
Loop
Proc_Exit:
On Error Resume Next
Close iFileNo
rs.Close
Set rs = Nothing
Set db = Nothing
Exit Function
Err_UnpackFile:
DoCmd.Beep
MsgBox "Error unpacking " & rs!FileName & "." & vbCrLf & _
Err.Number & vbCrLf & vbCrLf & Err.Description, _
vbOKOnly + vbExclamation, "Could not unpack file"
UnpackFile = False
Resume Proc_Exit
Resume
End Function
Regards,
Graham R Seach
Microsoft Access MVP
Sydney, Australia
---------------------------
I have copied and posted the below just for fast reference, that this
was
answered, but I could not understand how to do it. I find this as
very
important, there I want to understand the method and implement it.
As I am not good in VB, if any of the profession has succeded to do
this,
please advise me the steps and the code - the complete code, how to
call
the
code and from where so that I can also keep my application Icon in
the
database. So that when the application is opened, it will take the
reference
from there and set the database Icon.
Thanks and regards to all.
What you might feel like doing, depending on your level of
expertise
(and
inclination), is to take the code at
http://support.microsoft.com/?kbid=103257 and modify it to build a
module
to store the icon in a database table. You could then check for the
existance of the icon every time the database is launched, and if
not
found, unpack it from the table to a specific folder, and then set
the
AppIcon accordingly at runtime.
I use this very method with almost every database I build.
Unfortunately,
I'm interstate at present, and don't have *that* code with me, so I
can't
give it to you.
Regards,
Graham R Seach
Microsoft Access MVP
Sydney, Australia
Cheers Graham,
I thought as much
Unfortunately the way the application
works,
there
is a "template directory" with a blank master database & backend
database. People copy the master database (and client when
multiuser)
populate with data from Word the off they go with their own
database.
The
users arent really to interested in the icon to be honest, they
just
take
the master mdb populate it and off they go. It was just a nice
finishing
touch to distinguish it from other databases.
Ho Hum...
Thanks anyway
Rod
Rod,
No, you can't embed it. You'll have to distribute it with the
database.
Regards,
Graham R Seach
Microsoft Access MVP
Sydney, Australia
Hello Everyone
I want to change the application icon that appears when my
database
backend starts up. I know that this can be done from the startup
options, unfortunately my application is used locally and across
networks over the world (how scary is that!!). What seems to
happen
is
that when you link the application icon to a specific location,
it
takes some time to realise that the location is not valid, hence
a
slow
startup and an inconsistent icon. Is there a way to embed the
icon
so
that it is local to the mdb?
Regards
Rod
