Application Title bar for each accdr file. (1 Viewer)

Ajit Singh

Registered User
Joined
Jul 11, 2013
Messages
34
Am using below code to create accdr files with filename as cost center number. Now I need to have filename i.e. cost center number at the application title bar of each accdr file.

Please help
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Dim appAccess As New Access.Application
sLocalPath = "h:\Global\Programs-Global\Cost Center Reporting Tool\Testing\Template.accdb"
sLocalsPath = "h:\Global\Programs-Global\Cost Center Reporting Tool\Testing\Output\" & Me.Combo8 & ".accdr"
With appAccess
.AutomationSecurity = 1 'MsoAutomationSecurityLow
.UserControl = True
.SysCmd 603, sLocalPath, sLocalsPath

End With
.MoveNext
Loop
.Close
End With

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 

Mihail

Registered User
Joined
Jan 22, 2011
Messages
2,373
Code:
Private Sub Combo8_Click()
Dim sLocalPath As String
Dim sLocalsPath As String
Dim appAccess As New Access.Application
    sLocalPath = "h:\Global\Programs-Global\Cost Center Reporting Tool\Testing\Template.accdb"
'    sLocalPath = "C:\Documents and Settings\Camelia\Desktop\Access\Teste\WelFare\Welfare.mdb"

    sLocalsPath = "h:\Global\Programs-Global\Cost Center Reporting Tool\Testing\Output\" & Me.Combo8 & ".accdr"
'    sLocalsPath = "C:\Documents and Settings\Camelia\Desktop\Access\Teste\WelFare\" & Me.Combo8 & ".accdr"

Dim strActualTitle As String, strNewTitle As String
    Dim proTitle As Property

    With OpenDatabase(Name:=sLocalPath)
        'store actual title of the .mdb (.accdb)
        strActualTitle = .Name
        
        'Create new title
        strNewTitle = Me.Combo8
        
        'Change the title
        Set proTitle = .CreateProperty("AppTitle", dbText, strNewTitle)
        Call .Properties.Append(proTitle)
        .Properties("AppTitle").Value = strNewTitle
        
        'close the DB
        Call .Close
    End With
    
    'Create .accdr
    With appAccess
        .AutomationSecurity = 1 'MsoAutomationSecurityLow
        .UserControl = True
        .SysCmd 603, sLocalPath, sLocalsPath
    End With
    
    'Restore the old title for the .mdb (.accdb)
    With OpenDatabase(Name:=sLocalPath)
        Set proTitle = .CreateProperty("AppTitle", dbText, strActualTitle)
        .Properties("AppTitle").Value = strActualTitle
        
        'close the DB
        Call .Close
    End With
End Sub
 

Ajit Singh

Registered User
Joined
Jul 11, 2013
Messages
34
Thank you for the instant reply......


am encountering an error on line code "Call .Properties.Append(proTitle)" at the time to preparing the second file.

"Run time error 3367.....Cannot append. An object with that name already exists in the collection."

Please help
 

Mihail

Registered User
Joined
Jan 22, 2011
Messages
2,373
Code:
Private Sub Combo8_Click()
On Error GoTo ErrorHandler

Dim sLocalPath As String
Dim sLocalsPath As String
Dim appAccess As New Access.Application
'    sLocalPath = "h:\Global\Programs-Global\Cost Center Reporting Tool\Testing\Template.accdb"
    sLocalPath = "C:\Documents and Settings\Camelia\Desktop\Access\Teste\WelFare\Welfare.mdb"

'    sLocalsPath = "h:\Global\Programs-Global\Cost Center Reporting Tool\Testing\Output\" & Me.Combo8 & ".accdr"
    sLocalsPath = "C:\Documents and Settings\Camelia\Desktop\Access\Teste\WelFare\" & Me.Combo8 & ".accdr"

Dim strActualTitle As String, strNewTitle As String
    Dim proTitle As Property

    With OpenDatabase(Name:=sLocalPath)
        'store actual title of the .mdb (.accdb)
        strActualTitle = .Name
        
        'Create new title
        strNewTitle = Me.Combo8
        
        'Change the title
        Set proTitle = .CreateProperty("AppTitle", dbText, strNewTitle)
        Call .Properties.Append(proTitle)
        .Properties("AppTitle").Value = strNewTitle
        
        'close the DB
        Call .Close
    End With
    
    'Create .accdr
    With appAccess
        .AutomationSecurity = 1 'MsoAutomationSecurityLow
        .UserControl = True
        .SysCmd 603, sLocalPath, sLocalsPath
    End With
    
    'Restore the old title for the .mdb (.accdb)
    With OpenDatabase(Name:=sLocalPath)
        Set proTitle = .CreateProperty("AppTitle", dbText, strActualTitle)
        .Properties("AppTitle").Value = strActualTitle
        
        'close the DB
        Call .Close
    End With

Ex:

Exit Sub

ErrorHandler:
    Select Case Err.Number
        Case 3367
            Resume Next
        Case Else
            MsgBox (Err.Number & ": " & Err.Description)
            Resume Ex
    End Select
End Sub
 

Mihail

Registered User
Joined
Jan 22, 2011
Messages
2,373
Note please that this is an "instant" solution.
A true solution is to remove the property from the DB, but I can't do my best now, one day before the new year, because I have drink some "PALINKA", a Romanian drink that is, in my opinion, better than any whisky I ever drink.
So, my friend, take a break until the new year will come, and will see.

Happy New Year
and All the Best
 

Ajit Singh

Registered User
Joined
Jul 11, 2013
Messages
34
It worked as a wonder !!!!!!!!!!

Thank you so much and enjoy your drink.

Wish you a very happy new year to you and to your family.

Thanks
 

vedika

Registered User
Joined
Jan 24, 2019
Messages
11
Thanks for this code and help. I was getting same problem luckily got answer in this forum.
 

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

Top Bottom