Public Sub FactuurBoeken()
'Controle of alles ingevuld is
On Error Resume Next '''
fout = 0
If Range("factuurdatum") = "" Then fout = 1
If Val(Range("Totaal")) = 0 Then fout = 1
If Range("Naam") = "0" Or Range("Naam") = "" Then fout = 1
If fout = 1 Then
i = MsgBox("Datum, Naam of Totaalbedrag ontbreekt")
Call Afsluiten
End If
'Opbouw array
big(1, 0) = 535: big(1, 1) = 7
big(2, 0) = 1040: big(2, 1) = 4
big(3, 0) = 1140: big(3, 1) = 4
big(4, 0) = 384: big(4, 1) = 3
big(5, 0) = 1013: big(5, 1) = 4
'Op tabblad debiteuren lege rij zoeken
Sheets("Debiteuren").Select
Range("B10").Select 'deze cel moet gevuld zijn!
Selection.End(xlDown).Select
rij = 1 + ActiveCell.Row
' GoTo Vervolg1 '''
'Controle versie
Sheets("Factuur").Select
x = Application.UserName
If x = "" Then x = Trim$(System.PrivateProfileString("", "HKEY_LOCAL_MACHINE\Network\Logon", "Username"))
If x = "" Then x = Trim$(System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer", "Logon User Name"))
For i = 1 To Len(x): i1 = i1 + Asc(Mid$(x, i, 1)): Next i
For i = 1 To 5
If big(i, 1) > Len(x) Then big(i, 1) = 1
If i1 = big(i, 0) And Asc(Mid$(x, big(i, 1), 1)) = 78 Then GoTo Vervolg1
Next i
x = x
x = UCase$(Left$(x, 9))
For i = 1 To Len(x): i2 = i2 + Asc(Mid$(x, i, 1)): Next i
If i2 = 694 Or i2 = 227 Then GoTo Vervolg1
ActiveSheet.Unprotect
If Range("P49") = "" Then
Range("P49") = Date
Range("P49").Font.Size = 8
Range("Q49") = "< Installatiedatum"
End If
ActiveSheet.Protect
i = DateDiff("D", Range("P49"), Date)
If i < 30 Then GoTo Vervolg1 '''
If Range("P48") > "" Then GoTo Vervolg2: '''
If rij < 3 Then GoTo Vervolg2 '''
i = MsgBox("De VerkoopFactuur-applicatie moet nog geactiveerd worden." + Chr(13) + "Activering duurt 1 minuut, is eenmalig en gratis." + Chr(13) + "Klik op OK om de activeringspagina in uw browser te openen.", 1, x)
If i = 2 Then Call Afsluiten
ActiveWorkbook.FollowHyperlink Address:="http://www.cpsbv.nl/OfficeTools/OfficeIndex10.htm", NewWindow:=True, AddHistory:=True
ActiveSheet.Unprotect
Range("P48").Locked = False
Range("Q48") = "< Activeringscode"
ActiveSheet.Protect
Call Afsluiten
Vervolg2:
ActiveSheet.Unprotect
Range("P2").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"http://www.cpsbv.nl/OfficeTools/OfficeIndex11.htm", TextToDisplay:= _
" Klik hier voor extra functies"
Selection.Font.ColorIndex = 6
Selection.Font.Underline = xlUnderlineStyleNone
Range("P2").Locked = True
ActiveSheet.Protect
Vervolg1:
'Gegevens kopieren naar tabblad Debiteuren
Sheets("Debiteuren").Select
ActiveSheet.Unprotect
Cells(rij, 2) = Range("Factuur!Factuurnr.")
Cells(rij, 3) = Range("Factuur!Factuurdatum")
Cells(rij, 4) = Range("Factuur!Debiteurnr.")
Cells(rij, 5) = Range("Factuur!Naam")
Cells(rij, 6) = Range("Factuur!Totaal")
Range("K6:N6").Select
Selection.Copy
Cells(rij, 11).Select
ActiveSheet.Paste
Cells(rij, 2).Select
ActiveSheet.Protect
'Bestandsnaam voor kopiebestand samenstellen
x1$ = Range("Debiteuren!LocatieFactuurbestanden")
x2 = Range("Factuur!Factuurnr.")
x3$ = "\": If Right$(x1$, 1) = "\" Then x3$ = ""
Bestandsnaam$ = x1$ + x3$ + Trim$(Str$(x2)) + ".xls"
If x1$ = "" Or x2 < 1 Then Bestandsnaam$ = ""
'Kopiebestand aanmaken
Sheets("Factuur").Select
ActiveSheet.DropDowns(1).Visible = False
'Lijnen weg
ActiveSheet.Unprotect
Range("D13:H16").Select
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
ActiveSheet.Protect
'Factuurdeel
Venster1$ = ActiveWindow.Caption
Range("B2:N54").Select
Selection.Copy
Workbooks.Add
Venster2$ = ActiveWindow.Caption
ActiveSheet.DropDowns.Add(144, 105.75, 248.25, 15.75).Select
ActiveSheet.Paste
Windows(Venster1$).Activate
Sheets("Factuur").Select
If AcceptGiro = 1 Then
'AC positie inlezen
Positie2 = Range("PositieAcceptGiro") ' AC start vanaf 550 punten , zie notatie in cel P47
Range("Accept").Select
ActiveSheet.Unprotect
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
ActiveSheet.Protect
Range("Accept").Select
Selection.Copy
Windows(Venster2$).Activate
Range("A60").Select
ActiveSheet.DropDowns.Add(10, 10, 20, 10).Select
ActiveSheet.Paste
'Terug naar Venster1 - AC kleur herstellen
Windows(Venster1$).Activate
ActiveSheet.Unprotect
Range("Accept").Select
With Selection
.ClearContents '''
.Interior.ColorIndex = 51
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
End With
'Lijnen herstellen
Range("D13:H16").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 24
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 24
End With
End If
ActiveSheet.DropDowns(1).Visible = True
Range("B2").Select
Application.CutCopyMode = False
ActiveSheet.Protect
'Terug naar nieuwe venster
Windows(Venster2$).Activate
Range("A1").Select
'Afmetingen van kopie aanpassen
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.35)
.RightMargin = Application.InchesToPoints(0.3)
.TopMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.4)
End With
ActiveSheet.Shapes("Picture 2").Select
Selection.ShapeRange.LockAspectRatio = msoTrue
'Selection.ShapeRange.Height = 500
Selection.ShapeRange.Width = 475
Selection.ShapeRange.Left = 4
If AcceptGiro = 1 Then
ActiveSheet.Shapes("Picture 4").Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 475
Selection.ShapeRange.Top = Positie2
End If
ActiveSheet.DropDowns(1).Delete
If AcceptGiro = 1 Then ActiveSheet.DropDowns(1).Delete
DoEvents
'Kopiebestand opslaan
On Error GoTo FoutBijOpslaan
If Bestandsnaam$ > "" Then ActiveWorkbook.SaveAs Bestandsnaam$
On Error GoTo 0
FactuurNummer1 = FactuurNummer1 + 1
Call Bewaarfactuurnummer
ReageerOpTweedeKlik = 0
Range("A1").Select
Call Afsluiten
FoutBijOpslaan:
Resume Next
End Sub
)
