Export werkt echter alleen als exel openstaat Check VBA needed

Status
Niet open voor verdere reacties.
E

epetzen

Gebruiker
Lid geworden
24 nov 2007
Berichten
73
L.s.,

Ik heb de volgende VB code voor het exporteren van bepaalde velden per record naar een excel sheet.

Dit functioneert naarbehoren op het moment dat de template file 'open' staat. Als deze gesloten is gebeurd er niets.
Hiernaast vraagt hij na het exporteren onder welke naam ik hem wil opslaan. Hierbij slaat hij de file niet op met de opgegeven naam.

Kan een van jullie VB experts een kijken wat hier fout in de code staat (access en excel 2003)

Many many thanks,


Code: 
Public Function ExportToExcel()
On Error GoTo ErrorHandler
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strWorksheetPath As String
Dim appExcel As Excel.Application
Dim strTemplatePath As String
Dim bks As Excel.Workbooks
Dim rng As Excel.Range
Dim rngStart As Excel.Range
Dim strTemplateFile As String
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim lngCount As Long
Dim strPrompt As String
Dim strTitle As String
Dim strTemplateFileAndPath As String
Dim prps As Object
Dim strSaveName As String
Dim strTestFile As String
Dim strDefault As String
Set appExcel = GetObject(, "Excel.Application")
strTemplatePath = GetWorksheetTemplatesPath
strTemplateFile = "c:\export.xlt"
strTemplateFileAndPath = strTemplatePath & strTemplateFile
strTestFile = Nz(Dir(strTemplateFileAndPath))
Debug.Print "Test file: " & strTestFile
If strTestFile = "" Then
MsgBox strTemplateFileAndPath & " Export.xls niet gevonden; " & "Kan Exel export hierdoor niet maken"
GoTo ErrorHandler
End If
strWorksheetPath = GetWorksheetsPath
Debug.Print "Worksheet; template And Path: " & strTemplateFileAndPath
Set bks = appExcel.Workbooks
Set wkb = bks.Add(strTemplateFileAndPath)
Set wks = wkb.Sheets(1)
wks.Activate
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("query PO2 klein", dbOpenDynaset)
rst.MoveLast
rst.MoveFirst
lngCount = rst.RecordCount
If lngCount = 0 Then
    MsgBox "Geen Records aanwezig"
    GoTo ErrorHandler
Else
strPrompt = "Exporteren van " & lngCount & " records naar Excel"
strTitle = "Exporteren"
MsgBox strPrompt, vbInformation + vbOKOnly, strTitle
End If
Set rngStart = wks.Range("A3")
rngStart.Activate
With rst
Do Until .EOF
rngStart.Activate
rngStart.Value = Nz(![Project])
Set rng = appExcel.ActiveCell.Offset(columnoffset:=1)
rng.Value = Nz(![OpstelpuntId])
Set rng = appExcel.ActiveCell.Offset(columnoffset:=2)
rng.Value = Nz(![Site type])
Set rng = appExcel.ActiveCell.Offset(columnoffset:=3)
rng.Value = Nz(![Plaats])
Set rng = appExcel.ActiveCell.Offset(columnoffset:=4)
rngStart.Activate
Set rngStart = appExcel.ActiveCell.Offset(rowoffset:=1)
.MoveNext
Loop
End With
MsgBox "Alle Records zijn geëxporteerd"
 
Set prps = appExcel.ActiveWorkbook.BuiltinDocumentProperties
strSaveName = strWorksheetPath & prps("Title") & "Export Klein-" & Format(Date, "dd-mm-yy")
Debug.Print "Worksheet save name: " & strSaveName
On Error Resume Next
Kill strSaveName
On Error GoTo ErrorHandler
strPrompt = "Geef de file een naam"
strTitle = "Opslaan"
strDefault = strSaveName
strSaveName = InputBox(prompt:=strPrompt, Title:=strTitle, Default:=strDefault)
wkb.SaveAs FileName:=strSaveName, FileFormat:=xlsWorkbookDefault
appExcel.Visible = True
ErrorHandler:
Exit Function
If Err = 429 Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
Else
MsgBox "error No: " & Err.Number & "; description: " & Err.Description
Resume ErrorHandler
End If
End Function
 
Laatst bewerkt door een moderator:
Even een paar opmerkingen:
- waarom een functie gebruiken als je geen return value geeft?
- waarom early binding toepassen (Dim appExcel As Excel.Application) als je daarna toch late binding gaat gebruiken (Set appExcel = GetObject(, "Excel.Application"))?
- een errorhandler waar je meteen uit gaat gaat niet veel doen, vandaar dat er niets gebeurt (ErrorHandler: Exit Function)
 
Rene,

Zie jij mogelijkheden om hem aan te passen, heb hier best €25,- voor over.
Ik ga namelijk naar het buiteland en het is mij best wat waard dat het hiervoor geimplementeerd is.

Laat het even weten...
 
Aangepast script

Hier is een aangepast stuk code, deze opent het excel-sjabloon c:\export.xlt, exporteert de gegevens uit de query, slaat het bestand op als excelbestand en laat excel zien. Het sjabloon c:\export.xlt moet aanwezig zijn.

Alles gebeurt nu in de root van c:\, hoe je het bepalen van een pad naar het sjabloon en naar het opgeslagen bestand voor ogen had, kon ik niet afleiden.

Code: 
Public Function ExportToExcel()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strWorksheetPath As String
    Dim appExcel As Object
    Dim strTemplatePath As String
    Dim bks As Object
    Dim rng As Object
    Dim rngStart As Object
    Dim strTemplateFile As String
    Dim wkb As Object
    Dim wks As Object
    Dim lngCount As Long
    Dim strPrompt As String
    Dim strTitle As String
    Dim strTemplateFileAndPath As String
    Dim prps As Object
    Dim strSaveName As String
    Dim strTestFile As String
    Dim strDefault As String
    Set appExcel = CreateObject("Excel.Application")
    strTemplatePath = GetWorksheetTemplatesPath
    strTemplateFile = "c:\export.xlt"
    strTemplateFileAndPath = strTemplatePath & strTemplateFile
    strTestFile = Nz(Dir(strTemplateFileAndPath))
    Debug.Print "Test file: " & strTestFile
    If strTestFile = "" Then
        MsgBox strTemplateFileAndPath & " Export.xls niet gevonden; " & "Kan Exel export hierdoor niet maken"
        Exit Function
    End If
    strWorksheetPath = GetWorksheetsPath
    Debug.Print "Worksheet; template And Path: " & strTemplateFileAndPath
    Set bks = appExcel.Workbooks
    Set wkb = bks.Add(strTemplateFileAndPath)
    Set wks = wkb.Sheets(1)
    wks.Activate
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("query PO2 klein", dbOpenDynaset)
    rst.MoveLast
    rst.MoveFirst
    lngCount = rst.RecordCount
    If lngCount = 0 Then
        MsgBox "Geen Records aanwezig"
        Exit Function
    Else
        strPrompt = "Exporteren van " & lngCount & " records naar Excel"
        strTitle = "Exporteren"
        MsgBox strPrompt, vbInformation + vbOKOnly, strTitle
    End If
    Set rngStart = wks.Range("A3")
    rngStart.Activate
    With rst
        Do Until .EOF
            rngStart.Activate
            rngStart.Value = Nz(![Project])
            Set rng = appExcel.ActiveCell.Offset(columnoffset:=1)
            rng.Value = Nz(![OpstelpuntId])
            Set rng = appExcel.ActiveCell.Offset(columnoffset:=2)
            rng.Value = Nz(![Site type])
            Set rng = appExcel.ActiveCell.Offset(columnoffset:=3)
            rng.Value = Nz(![Plaats])
            Set rng = appExcel.ActiveCell.Offset(columnoffset:=4)
            rngStart.Activate
            Set rngStart = appExcel.ActiveCell.Offset(rowoffset:=1)
            .MoveNext
        Loop
    End With
    MsgBox "Alle Records zijn geëxporteerd"
    strSaveName = "c:\export" & Format(Date, "yyyymmdd") & ".xls"
    If Not Dir(strSaveName) = "" Then Kill strSaveName
    appExcel.ActiveWorkbook.SaveAs strSaveName
    appExcel.Visible = True
End Function
 
Laatst bewerkt door een moderator:
werkt prima,1 aandachtpuntje nog..

Sesam,

Werkt prima er is echter een mogelijkheid waardoor hij een fotmeldinge geeft.

Indien je reeds een export hebt openstaan en nogmaals de module uitvoert geeft hij de foutmelding:

fout 70 toegang geweigerd

en loopt hij vast op:

If Not Dir(strSaveName) = "" Then Kill strSaveName

Kan hij hier naar een msgbox gaan, bijvoorbeeld "sluit eerst de ander export file af" en daarna naar end function bijvoorbeeld.

Thanks,
 
@epetzen ik wil je verzoeken om dit even te lezen. Heb nu al twee posts aangepast van je.
 
Errorhandler

Dat kun je oplossen door er weer een foutafhandeling omheen te zette, bijvoorbeeld iets als dit:

Bovenaan: on error goto err_ExportToExcel

Onderaan:
Code: 
exit_ExportToExcel:
   exit function
err_ExportToExcel:
   select case err
   case 70
      MsgBox "sluit eerst de ander export file af",70
      exit_ExportToExcel
   case else
      MsgBox "error No: " & Err.Number & "; description: " & Err.Description
      exit_ExportToExcel
   end select
 
Laatst bewerkt door een moderator:
sesam zei:
Dat kun je oplossen door er weer een foutafhandeling omheen te zette, bijvoorbeeld iets als dit:

Bovenaan: on error goto err_ExportToExcel

Onderaan:
Code: 
exit_ExportToExcel:
   exit function
err_ExportToExcel:
   select case err
   case 70
      MsgBox "sluit eerst de ander export file af",70
      exit_ExportToExcel
   case else
      MsgBox "error No: " & Err.Number & "; description: " & Err.Description
      exit_ExportToExcel
   end select
Klik om te vergroten...
@sesam, voor jou geldt ook post 8
 
Wat doe ik dan fout

Wat is het probleem Michel? Bij post 8 staat iets over duidelijke titels.
 
sesam zei:
Wat is het probleem Michel? Bij post 8 staat iets over duidelijke titels.
Klik om te vergroten...
Excuses, mijn fout. Het gaat er om dat VBA code tussen de code tags geplaatst dienen te worden.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan