Autor: Losch

 

Option Compare Database
Option Explicit

‚— API-Konstanten

Private Const WM_COMMAND = &H111
Private Const WM_LBUTTONUP = &H202

Private Const MF_INSERT = &H0&
Private Const MF_CHANGE = &H80&
Private Const MF_APPEND = &H100&
Private Const MF_DELETE = &H200&
Private Const MF_REMOVE = &H1000&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_SEPARATOR = &H800&
Private Const MF_ENABLED = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
Private Const MF_UNCHECKED = &H0&
Private Const MF_CHECKED = &H8&
Private Const MF_USECHECKBITMAPS = &H200&
Private Const MF_STRING = &H0&
Private Const MF_BITMAP = &H4&
Private Const MF_OWNERDRAW = &H100&
Private Const MF_POPUP = &H10&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_UNHILITE = &H0&
Private Const MF_HILITE = &H80&
Private Const MF_SYSMENU = &H2000&
Private Const MF_HELP = &H4000&
Private Const MF_MOUSESELECT = &H8000&

Private Const TPM_LEFTBUTTON = &H0&
Private Const TPM_RIGHTBUTTON = &H2&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_CENTERALIGN = &H4&
Private Const TPM_RIGHTALIGN = &H8&

‚—API-Strukturen
Type tPoint
X As Long
Y As Long
End Type

Type tRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Type tMsg
hWnd As Long
Message As Long
wParam As Long
lParam As Long
Time As Long
P As tPoint
End Type

‚—API-Deklarationen
Declare Function CreatePopupMenu Lib „user32“ () As Long
Declare Function AppendMenu Lib „user32“ Alias „AppendMenuA“ (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Declare Function DestroyMenu Lib „user32“ (ByVal hMenu As Long) As Long
Declare Function TrackPopUpMenu Lib „user32“ Alias „TrackPopupMenu“ (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As Long, lprc As tRect) As Long
Declare Function GetMessage Lib „user32“ Alias „GetMessageA“ (lpMsg As tMsg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Declare Function GetCursorPos Lib „user32“ (lpPoint As tPoint) As Long

Function DoPopup(strEntries As String) As Integer
Dim hMenu As Long, hWnd As Long, strX As String
Dim intCnt As Integer
Dim CurrPos As tPoint, aRect As tRect, aMsg As tMsg
Dim Result As Variant

intCnt = 1
hMenu = CreatePopupMenu()
If Right$(strEntries, 1) <> „|“ Then strEntries = strEntries + „|“
While strEntries <> „“
strX = Left$(strEntries, InStr(strEntries, „|“) – 1)
strEntries = Mid$(strEntries, InStr(strEntries, „|“) + 1)
If strX = „=“ Then ‚Separator…
Result = AppendMenu(hMenu, MF_SEPARATOR, 0, „“)
ElseIf Left$(strX, 1) = „>“ Then ‚Neue Spalte…
strX = Mid$(strX, 2)
Result = AppendMenu(hMenu, MF_MENUBARBREAK, intCnt, strX)
intCnt = intCnt + 1
ElseIf Left$(strX, 1) = „~“ Then ‚Deaktiviert…
strX = Mid$(strX, 2)
Result = AppendMenu(hMenu, MF_GRAYED, intCnt, strX)
intCnt = intCnt + 1
ElseIf Left$(strX, 1) = „+“ Then ‚Mit Häkchen…
strX = Mid$(strX, 2)
Result = AppendMenu(hMenu, MF_ENABLED + MF_CHECKED, intCnt, strX)
intCnt = intCnt + 1
Else ‚Normaler Eintrag…
Result = AppendMenu(hMenu, MF_ENABLED, intCnt, strX)
intCnt = intCnt + 1
End If
Wend

GetCursorPos CurrPos ‚Aktuelle Cursorposition?
hWnd = Screen.ActiveForm.hWnd ‚Handle auf das Formular
Result = TrackPopUpMenu(hMenu, TPM_LEFTALIGN, CurrPos.X, CurrPos.Y, 0, hWnd, aRect)
Result = GetMessage(aMsg, hWnd, WM_COMMAND, WM_LBUTTONUP)

If aMsg.Message = WM_COMMAND Then
DoPopup = aMsg.wParam
Else
DoPopup = 0
End If

Result = DestroyMenu(hMenu)

End Function

 

 

Option Compare Database
Option Explicit

Public objOutlApp As Outlook.Application
Function InitOutlook() As Boolean

On Error Resume Next
InitOutlook = False ‚Default: Keine Verbindung
Set objOutlApp = GetObject(, „Outlook.Application“)
If Err <> 0 Or objOutlApp Is Nothing Then
Err = 0
Set objOutlApp = CreateObject(„Outlook.Application“)
If Err <> 0 Or objOutlApp Is Nothing Then
Beep
MsgBox „Verbindung zu Outlook kann nicht aufgebaut werden: “ & _
Err.Description, vbOKOnly + vbCritical, „Problem:“
Exit Function
End If ‚Err<> 0…
End If ‚Err<> 0…

InitOutlook = True

End Function

Function ResetOutlook() As Boolean

On Error Resume Next
ResetOutlook = False ‚Default: Keine Verbindung
If Not objOutlApp Is Nothing Then
Set objOutlApp = Nothing
ResetOutlook = True
End If

End Function

 

Option Compare Database
Option Explicit

Type tRECT
lngX1 As Long
lngY1 As Long
lngX2 As Long
lngY2 As Long
End Type

Declare Function GetParent Lib „user32“ (ByVal Hwnd As Long) As Long

Declare Function GetWindowRect Lib „user32“ (ByVal Hwnd As Long, _
lpRect As tRECT) As Boolean

Declare Function MoveWindow Lib „user32“ (ByVal Hwnd As Long, _
ByVal X As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal brepaint As Boolean) As Boolean
Sub FormPosSave(F As Form)
Dim rectForm As tRECT
Dim rectParent As tRECT
Dim strDBName As String, strSection As String
Dim hWndParent As Long
Dim R As Variant

‚Datenbank-Name ermitteln
strDBName = CurrentDb.Name ‚Laufwerk:\Pfad\Dateiname.Erw
strDBName = NameOnly(strDBName) ‚Laufwerk/Pfad und Erweiterung raus…

‚Handle des Access-Fensters ermitteln
‚hWndParent = Application.hWndAccessApp
hWndParent = GetParent(F.Hwnd)

‚Koordinaten des Formulars bestimmen
R = GetWindowRect(F.Hwnd, rectForm)
If Not R Then
MsgBox „Fehler beim Auslesen der Fensterposition…“, vbCritical, „FormPosSave“
Exit Sub ‚Keine weiteren Aktionen…
End If

‚Koordinaten des Access-Fensters
R = GetWindowRect(hWndParent, rectParent)
If Not R Then
MsgBox „Fehler beim Auslesen der Fensterposition…“, vbCritical, „FormPosSave“
Exit Sub ‚Keine weiteren Aktionen…
End If

‚Werte in Registry speichern
strSection = strDBName & „\“ & F.Name
SaveSetting „FormPos“, strSection, „X1“, rectForm.lngX1 – rectParent.lngX1
SaveSetting „FormPos“, strSection, „Y1“, rectForm.lngY1 – rectParent.lngY1
SaveSetting „FormPos“, strSection, „X2“, rectForm.lngX2 – rectParent.lngX1
SaveSetting „FormPos“, strSection, „Y2“, rectForm.lngY2 – rectParent.lngY1

End Sub

Sub FormPosSet(F As Form)
Dim rectForm As tRECT
Dim strDBName As String, strSection As String
Dim lngBreite As Integer
Dim lngHoehe As Integer
Dim R As Variant

‚Datenbank-Name ermitteln
strDBName = CurrentDb.Name ‚Laufwerk:\Pfad\Dateiname.Erw
strDBName = NameOnly(strDBName) ‚Laufwerk/Pfad und Erweiterung raus…

‚Position/Größe aus Registry lesen
strSection = strDBName & „\“ & F.Name
With rectForm
.lngX1 = Val(GetSetting(„FormPos“, strSection, „X1“, „0“))
If .lngX1 = 0 Then Exit Sub ‚Keine/Ungültige Settings…
.lngY1 = Val(GetSetting(„FormPos“, strSection, „Y1“, „0“))
If .lngY1 = 0 Then Exit Sub ‚Keine/Ungültige Settings…
.lngX2 = Val(GetSetting(„FormPos“, strSection, „X2“, „0“))
If .lngX2 = 0 Then Exit Sub ‚Keine/Ungültige Settings…
.lngY2 = Val(GetSetting(„FormPos“, strSection, „Y2“, „0“))
If .lngY2 = 0 Then Exit Sub ‚Keine/Ungültige Settings…
lngBreite = .lngX2 – .lngX1
lngHoehe = .lngY2 – .lngY1
‚und setzen…
R = MoveWindow(F.Hwnd, .lngX1, .lngY1, lngBreite, lngHoehe, 1)
End With

End Sub

Function NameOnly(strFile As String) As String
Dim L%, X$

NameOnly = „“
X$ = strFile
If InStr(X$, „\“) <> 0 Then
L = Len(X$)
While Mid$(X$, L, 1) <> „\“ And L > 0
L = L – 1
Wend
If L = 1 Then Exit Function
X$ = Mid$(X$, L + 1)
End If

If InStr(X$, „.“) <> 0 Then
L = Len(X$)
While Mid$(X$, L, 1) <> „.“ And L > 0
L = L – 1
Wend
If L = 1 Then Exit Function
X$ = Left$(X$, L – 1)
NameOnly = X$
Else
NameOnly = X$
End If

End Function

 

 

Function DSVerschieben(strQuelle As String, _
strZiel As String, _
strFeldname As String, _
varFeldwert As Variant) As Integer

Dim strSQL As String

DSVerschieben = 0
strSQL = „INSERT INTO [“ & strZiel & „] „
strSQL = strSQL & „SELECT [“ & strQuelle & „].* FROM [“ & strQuelle & „] „
strSQL = strSQL & „WHERE [“ & strQuelle & „].[“ & strFeldname & „] = „
If TypeName(varFeldwert) = „String“ Then
strSQL = strSQL & „‚“ & varFeldwert & „‚;“
Else
strSQL = strSQL & varFeldwert & „;“
End If

On Error Resume Next
DoCmd.RunSQL strSQL, False
If Err <> 0 Then
Beep
MsgBox „Fehler beim Übertragen: “ & Err.Description, _
vbOKOnly + vbExclamation, _
„!!! Problem !!!“
DSVerschieben = 1
Exit Function
End If

strSQL = „DELETE * FROM [“ & strQuelle & „] „
strSQL = strSQL & „WHERE [“ & strQuelle & „].[“ & strFeldname & „] = „
If TypeName(varFeldwert) = „String“ Then
strSQL = strSQL & „‚“ & varFeldwert & „‚;“
Else
strSQL = strSQL & varFeldwert & „;“
End If

Err = 0
DoCmd.RunSQL strSQL, False
If Err <> 0 Then
Beep
MsgBox „Fehler beim Löschen: “ & Err.Description, _
vbOKOnly + vbExclamation, _
„!!! Problem !!!“
DSVerschieben = 2
Exit Function
End If

End Function

 

 

Function AdresseHolen(rs As Recordset) As String
Dim strAdr As String

On Error GoTo EndeProc
strAdr = Choose(rs(„Anrede“), „Herrn“, „Frau“, „Firma“) + vbCrLf
If Not IsNull(rs(„ZusatzAnr“)) Then strAdr = strAdr + rs(„ZusatzAnr“) + “ „
If Not IsNull(rs(„Firma“)) Then strAdr = strAdr + rs(„Firma“) + vbCrLf
If Not IsNull(rs(„ZusatzAdr“)) Then strAdr = strAdr + rs(„ZusatzAdr“) + vbCrLf
If Not IsNull(rs(„Vorname“)) And Not IsNull(rs(„Nachname“)) Then
strAdr = strAdr + rs(„Vorname“) + “ “ + rs(„Nachname“) + vbCrLf
ElseIf Not IsNull(rs(„Nachname“)) Then
strAdr = strAdr + rs(„Nachname“) + vbCrLf
End If
If Not IsNull(rs(„Straße“)) Then strAdr = strAdr + rs(„Straße“) + vbCrLf + vbCrLf
If Not IsNull(rs(„PLZ“)) And Not IsNull(rs(„Ort“)) Then
strAdr = strAdr + rs(„PLZ“) + “ “ + rs(„Ort“) + vbCrLf
Else
If Not IsNull(rs(„PLZ“)) Then
strAdr = strAdr + rs(„PLZ“) + vbCrLf
ElseIf Not IsNull(rs(„Ort“)) Then
strAdr = strAdr + rs(„Ort“) + vbCrLf
End If
End If
If Not IsNull(rs(„Land“)) Then strAdr = strAdr + rs(„Land“) + vbCrLf

EndeProc:
AdresseHolen = strAdr

End Function

 

 

Option Compare Database
Option Explicit

‚———————————————————————————-
‚ Einsatz:
‚ dim Clipboard as new ClpBrd
‚
‚ Methoden:
‚ Clipboard.SetData <Data>
‚
‚ Daten in die Zwischenablage kopieren…
‚
‚ <Data>= String-Konstante oder String-Variable
‚ Beispiel:
‚ X$= DLookUp(„[Feld]“,“[Tabelle]“,SQL$)
‚ Clipboard.SetData X$
‚ oder
‚ Clipboard.SetData „Testtext“
‚
‚ X$ = Clipboard.GetData()
‚
‚ Daten aus der Zwischenablage holen…
‚
‚ X$= String-Variable oder direkt im Ausdruck
‚ Beispiel:
‚ X$= Clipboard.GetData()
‚ oder
‚ rs(„Feld“)= „Test: “ & Clipboard.GetData()
‚
‚ Clipboard.Clear
‚
‚ Löscht den aktuellen Inhalt der Zwischenablage…
‚
‚
‚ Clipboard.ClpBrdEmpty()
‚
‚ True, wenn Zwischenablage leer ist, sonst False
‚
‚———————————————————————————-

‚API-Funktionen für Clipboard…
Private Declare Function CountClipboardFormats Lib „user32“ () As Long
Private Declare Function IsClipboardFormatAvailable Lib „user32“ (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib „user32“ (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib „user32“ () As Long
Private Declare Function SetClipboardData Lib „user32“ (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib „user32“ (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib „user32“ () As Long

‚API-Funktionen für Speicher-Operationen…
Private Declare Function GlobalUnlock Lib „kernel32“ (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib „kernel32“ (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib „kernel32“ (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib „kernel32“ (ByVal hMem As Long) As Long
Private Declare Function lStrCpy Lib „kernel32“ Alias „lstrcpy“ (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long

Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 32768

Sub Clear()
Dim lngRetVal As Long

If OpenClipboard(0&) <> 0 Then
lngRetVal = EmptyClipboard()
lngRetVal = CloseClipboard()
End If

End Sub

Function ClpBrdEmpty() As Boolean
Dim lngRetVal As Long

lngRetVal = CountClipboardFormats()
ClpBrdEmpty = (lngRetVal = 0) Or (IsClipboardFormatAvailable(CF_TEXT) = 0)

End Function

Function GetData()
Dim hClipMemory As Long
Dim lpClipMemory As Long
Dim strCBData As String
Dim lngRetVal As Long

strCBData = „“
If ClpBrdEmpty() Then
Beep
MsgBox „ClpBrd/Get: Zwischenablage ist leer…“, vbCritical
Exit Function
End If

If IsClipboardFormatAvailable(CF_TEXT) = 0 Then
Beep
MsgBox „ClpBrd/Get: Zwischenablage enthält keinen Text…“, vbCritical
Exit Function
End If

If OpenClipboard(0&) = 0 Then
Beep
MsgBox „ClpBrd/Get: Zwischenablage kann nicht geöffnet werden…“, vbCritical
Exit Function
End If

hClipMemory = GetClipboardData(CF_TEXT)
If IsNull(hClipMemory) Then
Beep
MsgBox „ClpBrd/Get: Fehler beim Lesen der Zwischenablage…“
strCBData = „“
GoTo EndeFunc
End If

lpClipMemory = GlobalLock(hClipMemory)

If Not IsNull(lpClipMemory) Then
strCBData = Space$(MAXSIZE)
lngRetVal = lStrCpy(strCBData, lpClipMemory)
lngRetVal = GlobalUnlock(hClipMemory)

On Error Resume Next
strCBData = Mid(strCBData, 1, InStr(1, strCBData, Chr$(0), 0) – 1)
If Err <> 0 Then
Beep
MsgBox „ClpBrd/Get: Ungültiges Format …“, vbCritical
strCBData = „“
End If
Else
Beep
MsgBox „ClpBrd/Get: Fehler beim Kopieren aus Zwischenablage…“, vbCritical
End If

EndeFunc:
lngRetVal = CloseClipboard()
GetData = strCBData

End Function

Function SetData(strCBData As String) As Boolean
Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long
Dim lngRetVal As Long

SetData = False
hGlobalMemory = GlobalAlloc(GHND, Len(strCBData) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lStrCpy(lpGlobalMemory, strCBData)
If GlobalUnlock(hGlobalMemory) <> 0 Then
Beep
MsgBox „ClpBrd/Set: Fehler beim Kopieren in die Zwischenablage…“, vbCritical
GoTo EndeFunc
End If

If OpenClipboard(0&) = 0 Then
Beep
MsgBox „ClpBrd/Set: Zwischenablage konnte nicht geöffnet werden…“, vbCritical
GoTo EndeFunc
End If

lngRetVal = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
SetData = True

EndeFunc:
If CloseClipboard() = 0 Then
Beep
MsgBox „ClpBrd/Set: Fehler beim Zugriff auf die Zwischenablage…“, vbCritical
SetData = False
End If

End Function

 

Option Explicit

Type ACL_OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Declare Function API_DateiOeffnen Lib „comdlg32.dll“ Alias _
„GetOpenFileNameA“ (pOpenfilename As ACL_OPENFILENAME) As Long

Declare Function API_DateiSpeichern Lib „comdlg32.dll“ Alias _
„GetSaveFileNameA“ (pOpenfilename As ACL_OPENFILENAME) As Long

Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_EXPLORER = &H80000 ‚ new look commdlg
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_LONGNAMES = &H200000 ‚ force long names for 3.x modules
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_NOLONGNAMES = &H40000 ‚ force no long names for 4.x modules
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_READONLY = &H1
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Public Const OFN_SHOWHELP = &H10

Dim pOpenfilename As ACL_OPENFILENAME

Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
lpszDisplayName As String
lpszTitle As String
ulFlags As Long
BFFCALLBACK As Long
LPARAM As Long
iImage As Integer
End Type

Declare Function SHBrowseForFolder Lib „shell32.dll“ (FolderStruct As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib „shell32.dll“ (ByVal LPCITEMIDLIST As Long, ByVal lpStr As String) As Long

Global Const BIF_RETURNONLYFSDIRS = &H1 ‚ For finding a folder to start document searching
Global Const BIF_DONTGOBELOWDOMAIN = &H2 ‚ For starting the Find Computer
Global Const BIF_STATUSTEXT = &H4
Global Const BIF_RETURNFSANCESTORS = &H8

Global Const BIF_BROWSEFORCOMPUTER = &H1000 ‚ Browsing for Computers.
Global Const BIF_BROWSEFORPRINTER = &H2000 ‚ Browsing for Printers
Global Const BIF_BROWSEINCLUDEFILES = &H4000 ‚ Browsing for Everything

Function OpenFolder(Title$) As String
Dim BI As BROWSEINFO
Dim R As Long
Dim lpBuffer As String * 254

With BI
.hwndOwner = 0
.lpszDisplayName = lpBuffer
.lpszTitle = Title$
.ulFlags = 0
.BFFCALLBACK = 0
.LPARAM = 0
End With

R = SHBrowseForFolder(BI)
R = SHGetPathFromIDList(R, lpBuffer)

OpenFolder = Left$(lpBuffer, InStr(lpBuffer, Chr(0)) – 1)

End Function

Function ACL_DateiOeffnen(strVerzeichnis As String, strTitel As String) As String

Dim strFilter As String
Dim strDateinameUndPfad As String
Dim strDateiname As String
Dim lngErgebnis As Long

‚ Angebotene Dateifilter in der Dropdownliste „Dateityp“
strFilter = „Bilddateien (*.bmp;*.gif;*.jpg)“ & Chr$(0) & „*.BMP;*.GIF;*.JPG“ & Chr$(0)

‚ Vorgegebenes Verzeichnis
If strVerzeichnis = „“ Then
strVerzeichnis = CurDir$ & Chr$(0) ‚ Wenn leer, dann das aktuelle Verzeichnis verwenden
Else
strVerzeichnis = strVerzeichnis & Chr$(0) ‚ ANSI „0“ an übergebenes Verzeichnis anhängen
End If

If strTitel = „“ Then
strTitel = „Access Berater: Datei-Öffnen-Dialog“ ‚ Wenn kein Titel übergeben, Standardtitel festlegen
Else
strTitel = strTitel & Chr$(0) ‚ ANSI „0“ an übergebenen Titel anhängen
End If

‚ Speicherplatz für Dateinamen & Pfad reservieren
strDateinameUndPfad = Space$(255) & Chr$(0)

‚ Speicherplatz für Dateinamen ohne Pfad reservieren
strDateiname = Space$(255) & Chr$(0)

‚Datenstruktur von pOPENFILENAME festlegen

pOpenfilename.lStructSize = Len(pOpenfilename)
pOpenfilename.hwndOwner = 0&
‚pOpenfilename.hwndOwner = Application.hWndAccessApp
pOpenfilename.lpstrFilter = strFilter
pOpenfilename.nFilterIndex = 1
pOpenfilename.lpstrFile = strDateinameUndPfad
pOpenfilename.nMaxFile = Len(strDateinameUndPfad)
pOpenfilename.lpstrFileTitle = strDateiname
pOpenfilename.nMaxFileTitle = Len(strDateiname)
pOpenfilename.lpstrInitialDir = strVerzeichnis
pOpenfilename.lpstrTitle = strTitel
pOpenfilename.Flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_HIDEREADONLY
pOpenfilename.nFileOffset = 0
pOpenfilename.nFileExtension = 0
pOpenfilename.lCustData = 0
pOpenfilename.lpfnHook = 0
pOpenfilename.lpTemplateName = „“

lngErgebnis = API_DateiOeffnen(pOpenfilename)

If lngErgebnis <> 0 Then
ACL_DateiOeffnen = Left(pOpenfilename.lpstrFile, InStr(pOpenfilename.lpstrFile, Chr$(0)) – 1)
Else
ACL_DateiOeffnen = „“
End If

‚ If lngErgebnis <> 0 Then
‚ ACL_DateiOeffnen = Left(pOpenfilename.lpstrFile, pOpenfilename.nFileOffset – 1) & _
‚ „*“ & Mid$(pOpenfilename.lpstrFile, pOpenfilename.nFileOffset + 1, _
‚ pOpenfilename.nFileExtension – pOpenfilename.nFileOffset – 1) & „*“ & _
‚ Mid$(pOpenfilename.lpstrFile, pOpenfilename.nFileExtension + 1, Len(pOpenfilename.lpstrFile) – pOpenfilename.nFileExtension)
‚ Else
‚ ACL_DateiOeffnen = „“
‚ End If

End Function

Function ACL_DateiSpeichern(strVerzeichnis As String, strTitel As String) As String

Dim strFilter As String
Dim strDateinameUndPfad As String
Dim strDateiname As String
Dim lngErgebnis As Long

‚ Angebotene Dateifilter in der Dropdownliste „Dateityp“
strFilter = „Access-Datenbanken (*.mdb; *.mde)“ & Chr$(0) & „*.MDB; *.MDE“ & Chr$(0)

‚ Vorgegebenes Verzeichnis
If strVerzeichnis = „“ Then
strVerzeichnis = CurDir$ & Chr$(0) ‚ Wenn leer, dann das aktuelle Verzeichnis verwenden
Else
strVerzeichnis = strVerzeichnis & Chr$(0) ‚ ANSI „0“ an übergebenes Verzeichnis anhängen
End If

If strTitel = „“ Then
strTitel = „Access Berater: Datei-Speichern-Dialog“ ‚ Wenn kein Titel übergeben, Standardtitel festlegen
Else
strTitel = strTitel & Chr$(0) ‚ ANSI „0“ an übergebenen Titel anhängen
End If

‚ Speicherplatz für Dateinamen & Pfad reservieren
strDateinameUndPfad = Space$(255) & Chr$(0)

‚ Speicherplatz für Dateinamen ohne Pfad reservieren
strDateiname = Space$(255) & Chr$(0)

‚Datenstruktur von pOPENFILENAME festlegen

pOpenfilename.lStructSize = Len(pOpenfilename)
pOpenfilename.hwndOwner = 0&
‚pOpenfilename.hwndOwner = Application.hWndAccessApp
pOpenfilename.lpstrFilter = strFilter
pOpenfilename.nFilterIndex = 1
pOpenfilename.lpstrFile = strDateinameUndPfad
pOpenfilename.nMaxFile = Len(strDateinameUndPfad)
pOpenfilename.lpstrFileTitle = strDateiname
pOpenfilename.nMaxFileTitle = Len(strDateiname)
pOpenfilename.lpstrInitialDir = strVerzeichnis
pOpenfilename.lpstrTitle = strTitel
pOpenfilename.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT
pOpenfilename.nFileOffset = 0
pOpenfilename.nFileExtension = 0
pOpenfilename.lCustData = 0
pOpenfilename.lpfnHook = 0
pOpenfilename.lpTemplateName = „“

lngErgebnis = API_DateiSpeichern(pOpenfilename)

If lngErgebnis <> 0 Then
ACL_DateiSpeichern = Left(pOpenfilename.lpstrFile, InStr(pOpenfilename.lpstrFile, Chr$(0)) – 1)
Else
ACL_DateiSpeichern = „“
End If

‚ If lngErgebnis <> 0 Then
‚ ACL_Speichern = Left(pOpenfilename.lpstrFile, pOpenfilename.nFileOffset – 1) & _
‚ „*“ & Mid$(pOpenfilename.lpstrFile, pOpenfilename.nFileOffset + 1, _
‚ pOpenfilename.nFileExtension – pOpenfilename.nFileOffset – 1) & „*“ & _
‚ Mid$(pOpenfilename.lpstrFile, pOpenfilename.nFileExtension + 1, Len(pOpenfilename.lpstrFile) – pOpenfilename.nFileExtension)
‚ Else
‚ ACL_Speichern = „“
‚ End If

End Function

Option Compare Database
Option Explicit

Sub WaitForm(strForm As String)

While SysCmd(acSysCmdGetObjectState, acForm, strForm)
DoEvents
Wend

End Sub

Sub WaitReport(strReport As String)

While SysCmd(acSysCmdGetObjectState, acReport, strReport)
DoEvents
Wend

End Sub

Function AngemeldeteAnwender() As String
Dim cnn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strListe As String

Set cnn = CurrentProject.Connection
Set rs = cnn.OpenSchema(adSchemaProviderSpecific, , _
„{947BB102-5D43-11D1-BDBF-00C04FB92675}“)

strListe = „“
While Not rs.EOF ‚Feldinhalte ausgeben
strListe = strListe & _
VBAStr(rs.Fields(1).Value) & _
“ (“ & _
VBAStr(rs.Fields(0).Value) & „);“
rs.MoveNext
Wend

AngemeldeteAnwender = Left$(strListe, Len(strListe) – 1)

End Function

Function VBAStr(aStr As String) As String

VBAStr = Left$(aStr, InStr(aStr, Chr$(0)) – 1)

End Function

Problem

Ich habe ein Makro angelegt, das aus einem Verzeichnis eine dort gespeicherte Datei regelmäßig importiert und deren Inhalte in eine Tabelle überträgt. Die Krönung dieses Makros wäre eine Funktion, die die Datei auf der Festplatte nach dem Import löscht. Eine Aktion „DateiLöschen“ oder ähnlich finde ich jedoch im Makroentwurf nicht!

Antwort:

Eine solche Aktion gibt es nicht. Sie können aber über „Ausführen – Code“ eine VBA-Funktion aufrufen, die diese Aufgabe erledigt. Legen Sie daher zunächst die folgende Funktion in einem vorhandenen oder neuen Modul an:

Function DelFile (strFName As String)
On Error Resume
Next Kill strFName
If Err<> 0 Then
Beep MsgBox „Datei “ & strFName & “ konnte nicht gelöscht werden…“
End If
End Function

In Ihrem Makro wählen Sie nun hinter den Aktionen für den Import die Aktion „AusführenCode“ aus. Für den Parameter „Funktionsname“ geben Sie zum Beispiel Folgendes ein:

DelFile
(„Z:\Datenaustausch\Bestellungen2007.xls“)

Die Angaben in Anführungszeichen ersetzen Sie dabei durch Laufwerk, Pfad und Name der gewünschten Datei.