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
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
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
Comment