How do you access the Application Icon path in MS Access 2003 programmatically?
It's a custom property ("AppIcon") of the database object.
Set dbs = CurrentDb
sAppIconPath = dbs.Properties("AppIcon")
Note - you will get an error if the property doesn;t exist.
This code from the Access Help shows how to create the property:
Example
The following example shows how to change the AppIcon and AppTitle properties in a Microsoft Access database (.mdb). If the properties haven't already been set or created, you must create them and append them to the Properties collection by using the CreateProperty method.
Sub cmdAddProp_Click()
Dim intX As Integer
Const DB_Text As Long = 10
intX = AddAppProperty("AppTitle", DB_Text, "My Custom Application")
intX = AddAppProperty("AppIcon", DB_Text, "C:\Windows\Cars.bmp")
CurrentDb.Properties("UseAppIconForFrmRpt") = 1
Application.RefreshTitleBar
End Sub
Function AddAppProperty(strName As String, _
varType As Variant, varValue As Variant) As Integer
Dim dbs As Object, prp As Variant
Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo AddProp_Err
dbs.Properties(strName) = varValue
AddAppProperty = True
AddProp_Bye:
Exit Function
AddProp_Err:
If Err = conPropNotFoundError Then
Set prp = dbs.CreateProperty(strName, varType, varValue)
dbs.Properties.Append prp
Resume
Else
AddAppProperty = False
Resume AddProp_Bye
End If
End Function
Related
Happy Anniversary and all the best for this community
I am trying to learn the use of DoCmd.TransferSpreadsheet to export queries and charts to Excel
In my Database, I have two forms to export in each one a query to Excel and create a Chart
In each Form, the user selects a value in a textbox and an image is displayed on the Form
In Form frm_createxlstacked, the user picks two dates and click a command button to export the query to Excel and creates an xlClustered Chart. This VBA code works fine.
This is VBA code for createxlstacked
Private Sub cmbexpqry_stacked_Click()
Dim wb As Object
Dim xl As Object
Dim sExcelWB As String
Dim ws As Worksheet
Dim r As Range
Dim ch As Object ''Excel.Chart
Dim mychart As ChartObject
Dim myMax, myMin As Double
Dim qry_createxlstacked As Object
Dim fullPhotoPath As String
If IsNull(Me.cbxclstacked.Value) Then Exit Sub
Dim wb As Object, xl As Object, ch As Object, mychart As ChartObject
Dim fullPhotoPath As String
fullPhotoPath = Add_PlotMap(Form_frm_createxlstacked.cbxclstacked.Value)
Set xl = CreateObject("excel.application")
On Error Resume Next
Kill TrailingSlash(CurrentProject.Path) & Form_frm_createxlstacked.cbxxlstacked.Value & "qry_createxlstacked.xlsx"
Err.Clear
On Error GoTo 0
sExcelWB = TrailingSlash(CurrentProject.Path) & "qry_createxlstacked.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_createxlstacked.xlsx", sExcelWB, True
Set wb = xl.Workbooks.Open(sExcelWB)
Set ws = wb.Sheets("qry_createxlstacked.xlsx")
Set ch = ws.Shapes.AddChart.Chart
Set mychart = ws.ChartObjects("Chart 1")
ws.Shapes.AddPicture fullPhotoPath, msoFalse, msoCTrue, r.Left, r.Top, 500, 250
With ch
.ChartType = xlColumnClustered
.SeriesCollection(2).AxisGroup = 2
.SeriesCollection(2).ChartType = xlLineMarkers
.ChartGroups(1).GapWidth = 69
.ChartArea.Height = 250
.ChartArea.Width = 550
End with
wb.Save
xl.Visible = True
xl.UserControl = True
Set ws = Nothing
Set wb = Nothing
End Sub
In Form frm_creategannt, the user picks two dates and click a command button to export query to Excel and creates an xlClustered Chart, but, VBA displays:
Run-time error '3011'. The Microsoft Office Access database engine could not find the object 'qry_creategantt.xlsx'. Make sure that the object exists and that you...
This is VBA code
Private Sub cmbexpqry_gantt_Click()
If IsNull(Me.cmbexpqry_gantt) Then Exit Sub
Dim wb As Object
Dim xl As Object
Dim sExcelWB As String
Dim ws As Worksheet
Dim r As Range
Dim ch As Object ''Excel.Chart
Dim mychart As ChartObject
Dim qry_creategantt As Object
Dim fullPhotoPath As String
fullPhotoPath = Add_PlotMap(Form_frm_creategantt.cbxcreategantt.Value)
Set xl = CreateObject("excel.application")
On Error Resume Next
Kill TrailingSlash(CurrentProject.Path) & Form_frm_creategantt.cbxcreategantt.Value & "qry_creategantt.xlsx"
Err.Clear
On Error GoTo 0
sExcelWB = TrailingSlash(CurrentProject.Path) & "qry_creategantt.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_creategantt.xlsx", sExcelWB, True
Set wb = xl.Workbooks.Open(sExcelWB)
Set ws = wb.Sheets("qry_creategantt.xlsx")
Set ch = ws.Shapes.AddChart.Chart
Set mychart = ws.ChartObjects("Chart 1")
ws.Shapes.AddPicture fullPhotoPath, msoFalse, msoCTrue, r.Left, r.Top, 500, 250
With ch
.ChartType = xlBarStacked
End With
wb.Save
xl.Visible = True
xl.UserControl = True
Set ws = Nothing
Set wb = Nothing
End Sub
The error is '3011' occurs in this line:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, qry_creargantt.xlsx", sExcelWB, True
I compared one by one each line of codes.
Also, I checked the Queries for each form.
I need to fix Run-time error '3011' to start testing VBA code to create Gantt Chart
In my opinion, I found no error, but I am stuck
I appreciate your reply, suggestion and effort in code with error.
If the error is occuring on the DoCmd.TransferSpreadsheet line as you indicate, then the error is very clear.
You have told Microsoft Access to run the query named qry_creategantt.xlsx (in order to export that data to Excel) and that query does not exist in your database.
Check the spelling of the Query in the Queries list, and in your code. In your question above, where you restate that line of code as where the error occurs, you spelled the query name differently: qry_creargantt.xlsx. Which spelling is correct? That may be your problem.
It's not possible to call a query ".anything" the . is an illegal character in an access query name.
So carefully check the name of your query you are referring to. Because it isn't qry_creategantt.xlsx
I am exporting a recordset from an access query to an Excel Workbook. The export goes fine, and my syntax prompts the user for a filename/location just as I need. However, the file is not actually saved. Am I missing a step in the process or what code changes need to take place in order to have this function?
Sub ETE()
Dim ExcelApp As Object, wbOutput As Object, wsOutput As Object, bExcelOpened As Boolean
Dim db As DAO.Database, rs As DAO.Recordset, targetRow As Long
Dim targetPath As String, fd As FileDialog, Title As String, saveInfo As Variant
DoCmd.Hourglass True
Set ExcelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Error_Handler
Set ExcelApp = CreateObject("Excel.Application")
bExcelOpened = False
Else
bExcelOpened = True
End If
On Error GoTo Error_Handler
ExcelApp.ScreenUpdating = False
ExcelApp.Visible = False
Set wbOutput = ExcelApp.Workbooks.Add()
Set wsOutput = wbOutput.Sheets(1)
Set db = CurrentDb
Set rs = db.OpenRecordset("qryTakeDataToExcel", dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then
'Write the data to Excel
End If
End With
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.AllowMultiSelect = False
.Title = "Select Save Location And File Name"
.InitialFileName = "File_" & Format(Now(), "mmddyyyy") & ".xlsx"
If .Show = True Then
wbOutput.SaveAs FileName:=fd.InitialFileName, FileFormat:=50
wbOutput.Close
End If
End With
End Sub
Your filedialog code is not working as expected, and because of that, you're not getting a valid file name and location.
If you want to return the file name picked, you should use .SelectedItems(1), not .InitialFileName. .InitialFileName sets an initial value and doesn't return the full path.
If .Show = True Then
wbOutput.SaveAs FileName:=.SelectedItems(1), FileFormat:=50
wbOutput.Close
End If
This would've probably been easier to catch if you'd have used a valid error handler. Use On Error GoTo 0 to use the default error handler.
I'm looking for some advice on Microsoft Access VBA - Basically, I have been asked to create a button on a form, upon this button being clicked it will display a box asking for a folder name (I can manually type in, then click 'Ok') which will then create a subfolder in a public folder within Outlook/Exchange 2013.
Any information / advice on this would be fantastic. I have tried some examples on the Internet but my VBA knowledge doesn't allow me to amend the code for my needs.
No doubt this code can be tidied up. It will create a folder called 'New One' within the Inbox.
You'll need to update the code to point to the correct folder and ask for the new name.
Sub CreateFolder()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object
Dim sFolder As String
sFolder = "Mailbox - Bill Gates\Inbox"
Set oOutlook = CreateObject("Outlook.Application")
Set nNameSpace = oOutlook.GetNameSpace("MAPI")
Set oFolder = GetFolderPath(sFolder)
oFolder.Folders.Add "New One" 'Add the 'New One' folder to the Inbox.
End Sub
'----------------------------------------------------------------------------------
' Procedure : GetFolderPath
' Author : Diane Poremsky
' Date : 09/06/2015
' Original : http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
' Purpose :
'-----------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Object 'Outlook.Folder
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object 'Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
Set oOutlook = CreateObject("Outlook.Application")
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
FoldersArray = Split(FolderPath, "\")
Set oFolder = oOutlook.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Object
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Use the Shell command in VBA. You can execute DOS commands to make folders.
https://msdn.microsoft.com/en-us/library/office/gg278437%28v=office.15%29.aspx
I have a Subform/Subreport control displayed on a Form in an Access 2010 database, and I use it to display both Forms and Reports. I have a few event handlers in which I need to know whether a Report is currently loaded into the Subform/Subreport control, or if it's a Form that's loaded. I have tried all of the following to no avail.
Any of the following conditions
If IsEmpty(NavigationSubform.Form) Then '...
If IsNull(NavigationSubform.Form) Then '...
If IsOject(NavigationSubform.Form) Then '...
If NavigationSubform.Form Is Nothing Then '...
If NavigationSubform.Form Is Null Then '...
If Nz(NavigationSubform.Form) Then '...
If (Not NavigationSubform.Form) = -1 Then '... This is a trick I use to check for uninitialized arrays
Results in
Run-time error '2467':
The expression you entered refers to an object that is closed or doesn't exist.
Is there some way that I can check whether a Subform/Subreport control currently has a Form or Report loaded without intentionally causing an error?
I don't believe that there is a way to reliably perform the check without error trapping, so you may want to wrap the code in a Public Function and put it into a regular VBA Module:
Public Function CheckSubformControlContents(ctl As SubForm) As String
Dim obj As Object, rtn As String
rtn = "None"
On Error Resume Next
Set obj = ctl.Form
If Err.Number = 0 Then
rtn = "Form"
Else
On Error Resume Next
Set obj = ctl.Report
If Err.Number = 0 Then
rtn = "Report"
End If
End If
Set obj = Nothing
On Error GoTo 0
CheckSubformControlContents = rtn
End Function
Then your form code can simply call CheckSubformControlContents(Me.NavigationSubform).
Here are two functions that work in Access 2013 for determining if a name is a Report or a Form.
Once that is determined the IsLoaded function of AllForms or AllReports can be used. Note that dbs is an object and rpt or frm are AccessObjects not forms or reports
Public Function IsForm(FormName As String) As Boolean
Dim dbs As Object
Dim frm As AccessObject
Set dbs = Application.CurrentProject
IsForm = False
For Each frm In Application.CurrentProject.AllForms
If frm.Name = FormName Then
IsForm = True
Exit For
End If
Next frm
Set frm = Nothing
Set dbs = Nothing
End Function
Public Function IsReport(ReportName As String) As Boolean
Dim dbs As Object
Dim rpt As AccessObject
Set dbs = Application.CurrentProject
IsReport = False
For Each rpt In Application.CurrentProject.AllReports
If rpt.Name = ReportName Then
IsReport = True
Exit For
End If
Next rpt
Set rpt = Nothing
Set dbs = Nothing
End Function
Here is a program that uses the above functions:
Public Sub EnumerateTaggedControls(ReportName As String, MyTag As String)
Dim dbs As Object
Dim rpt As Report
Dim frm As Form
Dim col As Controls
Dim ctl As Control
Dim left As Integer
Dim top As Integer
Dim width As Integer
Dim height As Integer
Dim tag As String
Dim i As Integer
Const format1 As String = "0000 "
Set dbs = Application.CurrentProject
If IsForm(ReportName) Then
If dbs.AllForms(ReportName).IsLoaded Then
DoCmd.OpenForm ReportName, acViewDesign
Set frm = Forms(ReportName)
Set col = frm.Controls
End If
Else
If dbs.AllReports(ReportName).IsLoaded Then
DoCmd.OpenReport ReportName, acViewDesign
Set rpt = Reports(ReportName)
Set col = rpt.Controls
Else
Debug.Print ReportName & " is not a loaded form or report."
Exit Sub
End If
End If
Set dbs = Nothing
Debug.Print Tab(53); "Left Top Width Height"
For Each ctl In col
With ctl
left = .Properties("Left")
top = .Properties("Top")
width = .Properties("Width")
height = .Properties("Height")
tag = Nz(.Properties("Tag"), vbNullString)
If MyTag = "" Then
i = 1
Else
i = InStr(1, tag, MyTag)
End If
If i > 0 Then
Debug.Print .Name & ">"; Tab(33); tag; Tab(53); Format(left, format1) & Format(top, format1) & Format(width, format1) & Format(height, format1)
End If
End With
Next ctl
Debug.Print "====================================================="
Set ctl = Nothing
Set rpt = Nothing
Set col = Nothing
Set frm = Nothing
End Sub
I hope this meets your requirements.
I have created a data base that comes in an installer that runs as an epos system.
On installing it on other computers, I get a large number of errors all saying that something is missing. the file runs perfectly on my computer, but the errors stop anything from working on other computers....
the errors are as follows. each has its own popup box.
broken reference to excel.exe version 1.7 or missing.
acwztool.accde missing
npctrl.dll v4.1 missing
contactpicker.dll v1.0 missing
cddbcontolwinamp.dll v1.0 missing
cddbmusicidwinamp.dll v1.0 missing
colleagueimport.dll v1.0 missing
srstsh64.dll missing
I feel like this may because I altered the module vba library referencing so that I could run a vba code that uses excel, unfortunatly i have forgotten which librarys i have added
if it helps, the code that I added which required new references is below
Public Sub SalesImage_Click()
Dim rst As ADODB.Recordset
' Excel object variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Dim i As Integer
On Error GoTo HandleErr
' excel aplication created
Set xlApp = New Excel.Application
' workbook created
Set xlBook = xlApp.Workbooks.Add
' set so only one worksheet exists
xlApp.DisplayAlerts = False
For i = xlBook.Worksheets.Count To 2 Step -1
xlBook.Worksheets(i).Delete
Next i
xlApp.DisplayAlerts = True
' reference the first worksheet
Set xlSheet = xlBook.ActiveSheet
' naming the worksheet
xlSheet.name = conSheetName
' recordset creation
Set rst = New ADODB.Recordset
rst.Open _
Source:=conQuery, _
ActiveConnection:=CurrentProject.Connection
With xlSheet
' the field names are imported into excel and bolded
With .Cells(1, 1)
.Value = rst.Fields(0).name
.Font.Bold = True
End With
With .Cells(1, 2)
.Value = rst.Fields(1).name
.Font.Bold = True
End With
' Copy all the data from the recordset into the spreadsheet.
.Range("A2").CopyFromRecordset rst
' Format the data the numbering system has been extended to encompas up to 9,999,999 sales to cover all posibilities of sales since the last stock take
.Columns(1).AutoFit
With .Columns(2)
.NumberFormat = "#,###,###"
.AutoFit
End With
End With
' Create the chart.
Set xlChart = xlApp.Charts.Add
With xlChart
.ChartType = xl3DBarClustered
.SetSourceData xlSheet.Cells(1, 1).CurrentRegion
.PlotBy = xlColumns
.Location _
Where:=xlLocationAsObject, _
name:=conSheetName
End With
'the reference must be regotten as it is lost
With xlBook.ActiveChart
.HasTitle = True
.HasLegend = False
With .ChartTitle
.Characters.Text = conSheetName & " Chart"
.Font.Size = 16
.Shadow = True
.Border.LineStyle = xlSolid
End With
With .ChartGroups(1)
.GapWidth = 20
.VaryByCategories = True
End With
.Axes(xlCategory).TickLabels.Font.Size = 8
.Axes(xlCategoryScale).TickLabels.Font.Size = 8
End With
With xlBook.ActiveChart
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Product"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Sales"
End With
'format the size and possition of the chart
With xlBook.ActiveChart
.Parent.Width = 800
.Parent.Height = 550
.Parent.Left = 0
.Parent.Top = 0
End With
'this displays the chart in excel. excel must be closed by the user to return to the till system
xlApp.Visible = True
ExitHere:
On Error Resume Next
'this cleans the excel file
rst.Close
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
HandleErr:
MsgBox Err & ": " & Err.Description, , "There has been an error!"
Resume ExitHere
End Sub
Deployment should be less troublesome if you remove your project's Excel reference and use late binding for Excel objects.
A downside is you lose the benefit of Intellisense during development with late binding. However it's very easy to switch between early binding during development and late binding for production. Simply change the value of a compiler constant.
In the module's Declarations section ...
#Const DevStatus = "PROD" 'PROD or DEV
Then within the body of a procedure ...
#If DevStatus = "DEV" Then
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
#Else ' assume PROD (actually anything other than DEV)
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Set xlApp = CreateObject("Excel.Application")
#End If
With late binding your code will need to use the values of Excel constants rather than the constants names. Or you can define the named constants in the #Else block for production use then continue to use them by name in your code.
I don't know what all those other reference are. Suggest you take a copy of your project, remove all those references and see what happens when you run Debug->Compile from the VB Editor's main menu. Leave any unneeded references unchecked. And try late binding for the rest. I use only 3 references in production versions of Access applications: VBA; Access; and DAO.