Форумы HiProg.com - MS ACCESS, VBA, VB

 

Ответить на сообщение

Вернуться к теме

Вы отвечаете на сообщение:

ник: dmsrv803

Private Sub AddMicrosoftQuery(fName As String)
Dim tempName As String, strSQL As String, fPath As String
Dim sourceWB As Workbook, targetWB As Workbook, tgWsheet As Worksheet, srWsheet As Worksheet

fPath = CurrentProject.Path & "\Reports\"
tempName = "insurance template.xls"

Call CloseExcelApplication

Set exclApp = CreateObject("Excel.Application")
 With exclApp
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = False
        .AutomationSecurity = msoAutomationSecurityLow
        Set targetWB = .Workbooks.Add
        Set sourceWB = .Workbooks.Open(fPath & "Templates\" & tempName, , ReadOnly)
        Set srWsheet = sourceWB.Worksheets("Ëèñò1")
        Set tgWsheet = targetWB.Worksheets("Ëèñò1")
        srWsheet.Cells.Copy (tgWsheet.Cells(1, "A"))
        sourceWB.Close SaveChanges:=False
  End With
  
fPath = CurrentProject.Path
With tgWsheet.QueryTables.Add(Connection:=Array(Array("ODBC;DSN=Áàçà äàííûõ MS Access;DBQ=" & fPath & "\EU.mdb;DefaultDir=" & fPath & _
        ";DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeou"), Array("t=5;")), Destination:=Range("A2"))
        
        .CommandText = Array("SELECT Nom_Dogovora, Valuta, Clt_Name, Data_Dogovora, Data_Okon_DL, Manager_FIO, " & _
        "'Íîìåð øàññè (Ðàìà)', Model, Marka, Òèï, InsuranceCompany, InsuranceNumber, " & _
        "DateBegin, DateEnd, Expr1001 " & _
        "FROM '" & fPath & "\EU'.InsuranceTempTable InsuranceTempTable")
        
        .Name = "Çàïðîñ èç Áàçà äàííûõ MS Access"
        .FieldNames = False
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
    
    tgWsheet.QueryTables(1).Refresh
    targetWB.SaveAs (fPath & "\" & GetUniqueFileName(fName, fPath))
    exclApp.Visible = True
End Sub

Private Sub CloseExcelApplication()
Dim iiX As Integer, iiY As Integer

If exclApp Is Nothing Then Exit Sub

With exclApp
    iiY = .Workbooks.Count
    For iiX = 1 To iiY
        .ActiveWorkbook.Close (False)
    Next
    .Quit
End With
End Sub


Мне кажется, что все дело в запросе, который выводит данные в Excel. Если его не использовать то проблем не возникает.


Ваше имя:

Пароль:
Цитировать: [quote][/quote] Код: [code][/code]
Жирный: [b][/b] Наклонный: [i][/i]
URL: [url][/url] 

Сообщение:

 Размер файла не более 50 Кбт. Большие файлы можно размещать на www.slil.ru

Прикрепить:

 

Для вставки смайлов в текст щелкните по значку.