any idea about VBA code that open, writes data in EXCEL/WORD file???

[overcomer]

Hi,

My problem is i dont know the syntax for opening/writing data/closing excel/word file via vba ms access.. If you know links or sites that could be helpful...

thanks so much...

[MrDeej]

Here is code to write data from query and into Excel

Function sql_til_excel(sqlString As String, navn As String)
 
 
Call Opprett_Spørring("Excel_" & navn & "_liste", sqlString)
Call overfør_spørring_til_excel("Excel_" & navn & "_liste", "Excel_" & navn & "_liste")
Call Slett_temp_spørring("Excel_" & navn & "_liste")
 
 
End Function
Function Opprett_Spørring(Spørringnavn As String, strsql As String)
 
Dim NtLogin As String
 
NtLogin = Environ("Username")
 
  Dim dbs As Database
  Dim strQueryName As String
  Dim qryDef As QueryDef
 
 
  Set dbs = CurrentDb
  strQueryName = "tempqry " & NtLogin & " " & Spørringnavn
 
  Dim q As QueryDef
 
For Each q In dbs.QueryDefs
 
    If q.Name = strQueryName Then
    dbs.QueryDefs.Delete strQueryName
    End If
 
Next
 
Set qryDef = dbs.CreateQueryDef(strQueryName, strsql)
 
 
End Function
 
 
Function Slett_temp_spørring(Spørringnavn As String)
Dim NtLogin As String
 
NtLogin = Environ("Username")
 
DoCmd.DeleteObject acQuery, "tempqry " & NtLogin & " " & Spørringnavn
 
End Function
 
 
Public Function overfør_spørring_til_excel(Template As String, Optional Tempspørring As String, Optional Spørring As String) As String
Dim NtLogin As String
 
NtLogin = Environ("Username")
 
 
Dim appExcel As Excel.Application
   Dim wbk As Excel.Workbook
   Dim wks As Excel.Worksheet
 
   Dim sTemplate As String
   Dim sTempFile As String
   Dim Info As String
 
   Dim dbs As DAO.Database
   Dim rst As DAO.Recordset
   Dim sSql As String
   Dim lRecords As Long
   Dim iRow As Integer
   Dim iCol As Integer
   Dim iFld As Integer
   Dim sOutPut As String
   Const cTabTwo As Byte = 2
   Const cStartRow As Byte = 4
   Const cStartColumn As Byte = 3
 
sOutPut = ahtCommonFileOpenSave(, "Skrivebord", , , , Template & " " & Date & ".xls", Template & " " & Date & ".xls", , False)
If sOutPut = "" Then
Exit Function
End If
 
 
 
 
   Application.SetOption "Error Trapping", 0
 
   sTemplate = CurrentProject.Path & "\templ\" & Template & ".xls"
   If Dir(sOutPut) <> "" Then Kill sOutPut
 
   FileCopy sTemplate, sOutPut
 
   Set appExcel = CreateObject("Excel.Application")
   Set wbk = appExcel.Workbooks.Open(sOutPut)
   Set wks = appExcel.Worksheets(1)
 
   If Not Tempspørring = "" Then
    sSql = "SELECT * From [" & "tempqry " & NtLogin & " " & Tempspørring & "]"
    End If
    If Not Spørring = "" Then
    sSql = "SELECT * From [" & Spørring & "]"
   End If
 
   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset(sSql, dbOpenSnapshot)
   If Not rst.BOF Then rst.MoveFirst
 
   iCol = cStartColumn
   iRow = cStartRow
   rst.MoveLast
   Dim rc As Long
   rc = rst.RecordCount
   rst.MoveFirst
 
 
   If rc > 1000 Then
    svar1 = MsgBox("Du skal til å overføre " & rc & " poster." & vbCrLf & "Vil du fortsette?", vbYesNo, "LogiDose")
        If svar1 = vbNo Then
        On Error Resume Next
        Set wks = Nothing
        Set wbk = Nothing
        appExcel.Quit
        Set appExcel = Nothing
        Set rst = Nothing
        Set dbs = Nothing
        DoCmd.Hourglass False
        Exit Function
        End If
   End If
 
 
   Call Fremdriftsindikator("ja", rc, "Initierer exceloverføring")
   Do Until rst.EOF
      iFld = 0
      lRecords = lRecords + 1
      Call Fremdriftsindikator(, , "Overfører post nr " & lRecords & " av " & rc, , 1)
      For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
         wks.Cells(iRow, iCol) = rst.Fields(iFld)
 
         If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
            wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
         End If
 
         wks.Cells(iRow, iCol).WrapText = False
         iFld = iFld + 1
      Next
 
      wks.Rows(iRow).EntireRow.AutoFit
      iRow = iRow + 1
      rst.MoveNext
   Loop
 
Call Fremdriftsindikator(, , , "ja")
   Application.FollowHyperlink sOutPut
 
 
exit_Here:
   On Error Resume Next
   Set wks = Nothing
   Set wbk = Nothing
   'appExcel.Quit
   Set appExcel = Nothing
   Set rst = Nothing
   Set dbs = Nothing
   DoCmd.Hourglass False
 
End Function

You will also need this module:

Option Compare Database
Global GL_UserName As String
Global GBL_Access_Level As String
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Function init_globals()
GBL_Access_Level = "Ingen"
End Function
 
Public Function Get_Global(gbl_parm)
Select Case gbl_parm
    Case "GBL_Access_Level"
        Get_Global = GBL_Access_Level
End Select
End Function
 
 
 

The function fremdriftsindikator i use for a form with progressbar. This you should just delete or add the code for the progress bar form

Public Function Fremdriftsindikator_v2(Optional åpne As String, Optional maxhoved As Long, Optional maxdel As Long, Optional etiketthoved As String, Optional etikettdel As String, Optional lukk As String, Optional plushoved As Long, Optional plusdel As Long)
 
If åpne = "ja" Then
If Not CurrentProject.AllForms("MAIN progressbar v2").IsLoaded Then
DoCmd.OpenForm "MAIN progressbar v2"
End If
End If
 
 
If Not maxhoved = 0 Then
[Form_MAIN Progressbar v2].ProgressBar_hoved.max = maxhoved
End If
 
If Not maxdel = 0 Then
[Form_MAIN Progressbar v2].Progressbar_del.max = maxdel
End If
 
If Not etiketthoved = "" Then
[Form_MAIN Progressbar v2].etk_hoved.Caption = etiketthoved
End If
 
If Not etikettdel = "" Then
[Form_MAIN Progressbar v2].etk_del.Caption = etikettdel
End If
 
    Dim val As Integer
 
If Not plushoved = 0 Then
 
    val = [Form_MAIN Progressbar v2].ProgressBar_hoved.Value + plushoved
    If val > [Form_MAIN Progressbar v2].ProgressBar_hoved.max Then
        val = [Form_MAIN Progressbar v2].ProgressBar_hoved.max
    End If
 
    [Form_MAIN Progressbar v2].ProgressBar_hoved.Value = val
End If
 
If Not plusdel = 0 Then
    val = plusdel
    If val > [Form_MAIN Progressbar v2].Progressbar_del.max Then
        val = [Form_MAIN Progressbar v2].Progressbar_del.max
    End If
 
    [Form_MAIN Progressbar v2].Progressbar_del.Value = val
End If
 
[Form_MAIN Progressbar v2].Repaint
If lukk = "ja" Then
DoCmd.Close acForm, "MAIN progressbar v2"
End If
End Function
 

[overcomer]

thank u so much... ^_^