Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function fOSUserName() As String
Application.ScreenUpdating = False
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If lngX <> 0 Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = ""
End If
End Function
Function IsFileOpen(FileName As String)
Application.ScreenUpdating = False
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
Sub opslaan()
Application.ScreenUpdating = False
Dim retval
Dim MyXL As Object
pad = Sheets(2).Range("n1").Value
If IsFileOpen(pad & "Rapporten.xls") Then
retval = MsgBox("Rapporten.xls staat open" & vbCrLf & "Wilt u deze sluiten?", vbQuestion + vbYesNo)
If retval = vbYes Then
Set MyXL = GetObject(pad & "Rapporten.xls")
MyXL.Close
End If
End If
''Next
If Right(pad, 1) <> "" Then pad = pad & ""
codeA = Sheets(3).Range("g2").Value
bestand = pad & codeA & ".xls"
bericht = "Bestand wordt opgeslagen als:" & Chr(10) & bestand & Chr(10) & "Is dit correct ?"
naam_ok = MsgBox(bericht, vbYesNo)
If naam_ok = vbYes Then
ActiveWorkbook.SaveAs FileName:=bestand
End If
Dim VrijeRij, Directory
Application.ScreenUpdating = False
Directory = ActiveSheet.Range("N1").Value & ""
VrijeRij = 2
Range("P1:U1").Select
Selection.Copy
Workbooks.Open FileName:=Directory & "\Rapporten.xls"
Do Until ActiveSheet.Cells(VrijeRij, 1).Value = ""
ActiveSheet.Cells(VrijeRij, 1).Select
VrijeRij = VrijeRij + 1
Loop
ActiveSheet.Cells(VrijeRij, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub