title image


Smiley Unterformular nach Excel exportieren (per Automation)
So, jetzt hab ich es zusammengebaut:



Dim oExcel As Excel.Application, RS As DAO.Recordset, UFO As Form, Ctl As CONTROL, I As Long, J As Long

Dim Captions(100) As String, FldNames(100) As String, CO As Long, CW As Long, CH As Boolean, Z As Long

Set UFO = Me!ufrmAccess2ExcelUFO.Form

Set RS = UFO.RecordsetClone



' Feldnamen in Reihenfolge bringen

For I = 1 To 100

For Each Ctl In UFO.Controls

On Error Resume Next

CO = 0: CH = False: CW = 0

CO = Ctl.Properties!ColumnOrder

CW = Ctl.Properties!ColumnWidth

CH = Ctl.Properties!ColumnHidden

On Error GoTo 0

' nur nicht-ausgeblendete Spalten berücksichtigen:

If I = CO And Not CH And CW > 0 Then

J = J + 1

FldNames(J) = Ctl.ControlSource

End If

Next Ctl

Next I



' zu den Feldnamen die Spaltenüberschriften ermitteln

For I = 1 To J

Captions(I) = FldNames(I)

' Debug.Print FldNames(I)

For Each Ctl In UFO.Controls

If Ctl.ControlType = acLabel And Ctl.Parent.Name = FldNames(I) Then

Captions(I) = Ctl.Caption

End If

Next Ctl

Next I



' Excel öffnen

On Error Resume Next

Err.Clear

Set oExcel = GetObject(, "Excel.Application ")

If oExcel Is Nothing Then Set oExcel = CreateObject("Excel.Application")

On Error GoTo 0

With oExcel

.Visible = True

.Workbooks.Add



' Spaltenüberschriften darstellen

For I = 1 To J

.Cells(1, I) = Captions(I)

Next I



' Überschriftszeile formatieren

.Range(.Cells(1, 1), .Cells(1, J)).Select

With .Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With .Selection.Interior

.ColorIndex = 15

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With



' Daten ausgeben

Z = 1

If RS.RecordCount > 0 Then

RS.MoveFirst

Do Until RS.EOF

Z = Z + 1

' Durch alle Spalten

For I = 1 To J

.Cells(Z, I) = RS(FldNames(I))

Next I

RS.MoveNext

Loop

End If



' Spaltenbreiten anpassen

For I = 1 To J

.Columns(I).EntireColumn.AutoFit

Next I

RS.Close



' Speichern

If Not IsNull(Me!FNname) Then .ActiveWorkbook.SaveAs FileName:=CStr(Me!FName)

.Quit

End With



... wobei das ganze ja eigentlich genauso gut auch per Zwischenablage funktioniert ;=)



Gruß aus dem Norden
Reinhard


Bitte immer die Access-Version angeben!
DB-Wiki


Wie man Fragen richtig stellt

YaccessAccess-FAQUnd ansonsten: Wikipedia




geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: