bloempje
03-13-2011, 02:34 PM
Hi,
I am pretty new to VBA and to this forum. I will try yo explain the problem I have with my code.
I am creating a table to help my company calculate its travel expenses. The calculations in are done through a click-able button (using embedded excell table was an issue :banghead:, don't ask me why).
The point is that all works well, up to this protection level. Since users are not allowed to touch some columns, so to prevent them from messing with the calculations ( they have to fill the total of km done, the table gives the total expenses in euros, the expenses remain untouched).
Inside my code, I protect and unprotect the table so I can do the calculations. Somehow, at the end the expenses column ends up unprotected. Can anybody help me with this?
This is my code (sorry for the Dutch word, if it is an issue I can rename the functions):
Sub tabl101()
Dim oDoc As Word.Document
Set oDoc = ActiveDocument
Call tabel_maak
Call knop_maak
End Sub
Public Function knop_maak()
'Call onthef_beveilig
'Add a command button to a new document
Dim doc As Word.Document
Set doc = ActiveDocument
Dim tabel As Word.Table
Set tabel = Selection.Tables(1)
Dim rtabel, ktabel As Integer
rtabel = tabel.Rows.Count
ktabel = tabel.Columns.Count
Dim shp As Word.InlineShape
tabel.Cell(rtabel, ktabel - 1).Select
Set shp = Selection.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1")
With shp
.OLEFormat.Object.Caption = "Bereken Totaal"
.Height = 50
.Width = 100
End With
'Add a procedure for the click event of the inlineshape
'**Note: The click event resides in the This Document module
Dim sCode As String
sCode = "Public Sub " & shp.OLEFormat.Object.Name & "_Click()" & vbCrLf & _
"Call Sommeer_Converteer" & vbCrLf & _
"End Sub"
doc.VBProject.VBComponents("ThisDocument").CodeModule.AddFromString sCode
Call beveilig
End Function
Public Function Sommeer_Converteer()
Call onthef_beveilig
Dim rtabel As Long, j As Long, vSum As Double, vSumRow As Double, ktabel As Long
Dim oNum As Range, oNum1 As Range, oNum2 As Range
Dim myTable As Word.Table
vSum = 0
If Not Selection.Information(wdWithInTable) Then
MsgBox "Please place the cursor inside the table & restart macro"
Exit Function
Else
Set myTable = Selection.Tables(1)
End If
rtabel = myTable.Rows.Count
ktabel = myTable.Columns.Count
For j = 2 To rtabel - 1
vSumRow = 0
With myTable
'Get the value of the cells
Set oNum1 = .Cell(j, ktabel - 3).Range
Set oNum2 = .Cell(j, ktabel - 1).Range
'Strip end of cell markers
oNum1.End = oNum1.End - 1
oNum2.End = oNum2.End - 1
'make temporary sum
'''
If IsNumeric(oNum1) Then
.Cell(j, (ktabel - 2)).Range.Text = FormatCurrency(Expression:=0.19 * oNum1, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'Get the new cell value
Set oNum1 = .Cell(j, (ktabel - 2)).Range
'Strip the end of cell marker
oNum1.End = oNum1.End - 1
'Add it up
vSumRow = vSumRow + CDbl(Mid(oNum1, 2, Len(oNum1) - 1))
vSumRow = vSumRow
End If
'
'
If IsNumeric(oNum2) Then
.Cell(j, (ktabel - 1)).Range.Text = FormatCurrency(Expression:=oNum2, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'Get the new cell value
Set oNum2 = .Cell(j, (ktabel - 1)).Range
'Strip the end of cell marker
oNum2.End = oNum2.End - 1
'Add it up
vSumRow = vSumRow + CDbl(Mid(oNum2, 2, Len(oNum2) - 1))
End If
'
'
myTable.Cell(j, ktabel).Range.Text = FormatCurrency(Expression:=vSumRow, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'''
Set oNum = .Cell(j, ktabel).Range
oNum.End = oNum.End - 1
'If cell value is numeric then format
If IsNumeric(oNum) Then
.Cell(j, ktabel).Range.Text = FormatCurrency(Expression:=oNum, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'Get the new cell value
Set oNum = .Cell(j, ktabel).Range
'Strip the end of cell marker
oNum.End = oNum.End - 1
'Add it up
vSum = vSum + CDbl(Mid(oNum, 2, Len(oNum) - 1))
End If
End With
Next j
myTable.Cell(rtabel, ktabel).Range.Text = FormatCurrency(Expression:=vSum, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
Call beveilig
End Function
Public Function tabel_maak()
'
' tabellen Macro
'
'
Dim rtabel, ktabel As Integer
rtabel = 45
ktabel = 7
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=rtabel, NumColumns:= _
ktabel, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Tabelraster" Then
.Style = "Tabelraster"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
'Vul kolomtitels in
With Selection.Tables(1)
.Columns(1).Width = InchesToPoints(0.75)
.Columns(2).Width = InchesToPoints(2.5)
.Columns(3).Width = InchesToPoints(0.75)
.Columns(4).Width = InchesToPoints(0.75)
.Columns(5).Width = InchesToPoints(0.75)
.Columns(6).Width = InchesToPoints(0.75)
.Columns(7).Width = InchesToPoints(0.75)
With .Rows(1)
.Cells(1).Range.Text = "Datum activiteit"
.Cells(2).Range.Text = "Omschrijving (duidelijk vermelden plaats van vertrek en aankomst)"
.Cells(3).Range.Text = "Projectnr."
.Cells(4).Range.Text = "Auto km"
.Cells(5).Range.Text = "Bedrag"
.Cells(6).Range.Text = "Overig Bedrag"
.Cells(7).Range.Text = "Totaal"
.Cells(1).Range.Select
End With
End With
'Zet Style cellen vast
'Selection.MoveLeft Unit:=wdCharacter, Count:=5
Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 1)
For i = 0 To (ktabel - 2)
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Next i
Selection.Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
Call beveilig
End Function
Public Function beveilig()
Dim rtabel, ktabel As Long
rtabel = Selection.Tables(1).Rows.Count
ktabel = Selection.Tables(1).Columns.Count
Selection.Tables(1).Cell(1, 1).Select
'MsgBox ("Dit is de inhoud:" & rtabel & " " & ktabel)
If ActiveDocument.ProtectionType = wdNoProtection Then
ActiveDocument.Protect _
Type:=wdAllowOnlyFormFields, NoReset:=True, Password:="test01"
End If
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:="test01"
End If
Dim i As Integer
Selection.MoveDown Unit:=wdLine, Count:=2
For i = 0 To (ktabel - 4)
'selecteer kolom met km
If i <> 0 Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
End If
Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 3), Extend:=wdExtend
Selection.Editors.Add wdEditorEveryone
Next i
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 3), Extend:=wdExtend
Selection.Editors.Add wdEditorEveryone
'Als laatste dan maar expliciet(!)
'Selection.MoveLeft Unit:=wdCharacter, Count:=1
'Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 3), Extend:=wdExtend
'Selection.Editors(wdEditorEveryone).Delete
ActiveDocument.Protect Password:="test01", NoReset:=False, Type:= _
wdAllowOnlyReading, UseIRM:=False, EnforceStyleLock:=False
End Function
Public Function onthef_beveilig()
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:="test01"
End If
End Function
Sub kolom_weg()
'
' kolom_weg Macro
'
'
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1
ActiveDocument.Unprotect
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=44, Extend:=wdExtend
Selection.MoveUp Unit:=wdLine, Count:=2, Extend:=wdExtend
Selection.Editors(wdEditorEveryone).Delete
Selection.Editors.Add wdEditorEveryone
ActiveDocument.Protect Password:="test01", NoReset:=False, Type:= _
wdAllowOnlyReading, UseIRM:=False, EnforceStyleLock:=False
End Sub
cheers,
bloempje
I am pretty new to VBA and to this forum. I will try yo explain the problem I have with my code.
I am creating a table to help my company calculate its travel expenses. The calculations in are done through a click-able button (using embedded excell table was an issue :banghead:, don't ask me why).
The point is that all works well, up to this protection level. Since users are not allowed to touch some columns, so to prevent them from messing with the calculations ( they have to fill the total of km done, the table gives the total expenses in euros, the expenses remain untouched).
Inside my code, I protect and unprotect the table so I can do the calculations. Somehow, at the end the expenses column ends up unprotected. Can anybody help me with this?
This is my code (sorry for the Dutch word, if it is an issue I can rename the functions):
Sub tabl101()
Dim oDoc As Word.Document
Set oDoc = ActiveDocument
Call tabel_maak
Call knop_maak
End Sub
Public Function knop_maak()
'Call onthef_beveilig
'Add a command button to a new document
Dim doc As Word.Document
Set doc = ActiveDocument
Dim tabel As Word.Table
Set tabel = Selection.Tables(1)
Dim rtabel, ktabel As Integer
rtabel = tabel.Rows.Count
ktabel = tabel.Columns.Count
Dim shp As Word.InlineShape
tabel.Cell(rtabel, ktabel - 1).Select
Set shp = Selection.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1")
With shp
.OLEFormat.Object.Caption = "Bereken Totaal"
.Height = 50
.Width = 100
End With
'Add a procedure for the click event of the inlineshape
'**Note: The click event resides in the This Document module
Dim sCode As String
sCode = "Public Sub " & shp.OLEFormat.Object.Name & "_Click()" & vbCrLf & _
"Call Sommeer_Converteer" & vbCrLf & _
"End Sub"
doc.VBProject.VBComponents("ThisDocument").CodeModule.AddFromString sCode
Call beveilig
End Function
Public Function Sommeer_Converteer()
Call onthef_beveilig
Dim rtabel As Long, j As Long, vSum As Double, vSumRow As Double, ktabel As Long
Dim oNum As Range, oNum1 As Range, oNum2 As Range
Dim myTable As Word.Table
vSum = 0
If Not Selection.Information(wdWithInTable) Then
MsgBox "Please place the cursor inside the table & restart macro"
Exit Function
Else
Set myTable = Selection.Tables(1)
End If
rtabel = myTable.Rows.Count
ktabel = myTable.Columns.Count
For j = 2 To rtabel - 1
vSumRow = 0
With myTable
'Get the value of the cells
Set oNum1 = .Cell(j, ktabel - 3).Range
Set oNum2 = .Cell(j, ktabel - 1).Range
'Strip end of cell markers
oNum1.End = oNum1.End - 1
oNum2.End = oNum2.End - 1
'make temporary sum
'''
If IsNumeric(oNum1) Then
.Cell(j, (ktabel - 2)).Range.Text = FormatCurrency(Expression:=0.19 * oNum1, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'Get the new cell value
Set oNum1 = .Cell(j, (ktabel - 2)).Range
'Strip the end of cell marker
oNum1.End = oNum1.End - 1
'Add it up
vSumRow = vSumRow + CDbl(Mid(oNum1, 2, Len(oNum1) - 1))
vSumRow = vSumRow
End If
'
'
If IsNumeric(oNum2) Then
.Cell(j, (ktabel - 1)).Range.Text = FormatCurrency(Expression:=oNum2, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'Get the new cell value
Set oNum2 = .Cell(j, (ktabel - 1)).Range
'Strip the end of cell marker
oNum2.End = oNum2.End - 1
'Add it up
vSumRow = vSumRow + CDbl(Mid(oNum2, 2, Len(oNum2) - 1))
End If
'
'
myTable.Cell(j, ktabel).Range.Text = FormatCurrency(Expression:=vSumRow, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'''
Set oNum = .Cell(j, ktabel).Range
oNum.End = oNum.End - 1
'If cell value is numeric then format
If IsNumeric(oNum) Then
.Cell(j, ktabel).Range.Text = FormatCurrency(Expression:=oNum, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
'Get the new cell value
Set oNum = .Cell(j, ktabel).Range
'Strip the end of cell marker
oNum.End = oNum.End - 1
'Add it up
vSum = vSum + CDbl(Mid(oNum, 2, Len(oNum) - 1))
End If
End With
Next j
myTable.Cell(rtabel, ktabel).Range.Text = FormatCurrency(Expression:=vSum, _
NumDigitsAfterDecimal:=2, IncludeLeadingDigit:=vbTrue, _
UseParensForNegativeNumbers:=vbTrue)
Call beveilig
End Function
Public Function tabel_maak()
'
' tabellen Macro
'
'
Dim rtabel, ktabel As Integer
rtabel = 45
ktabel = 7
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=rtabel, NumColumns:= _
ktabel, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Tabelraster" Then
.Style = "Tabelraster"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
'Vul kolomtitels in
With Selection.Tables(1)
.Columns(1).Width = InchesToPoints(0.75)
.Columns(2).Width = InchesToPoints(2.5)
.Columns(3).Width = InchesToPoints(0.75)
.Columns(4).Width = InchesToPoints(0.75)
.Columns(5).Width = InchesToPoints(0.75)
.Columns(6).Width = InchesToPoints(0.75)
.Columns(7).Width = InchesToPoints(0.75)
With .Rows(1)
.Cells(1).Range.Text = "Datum activiteit"
.Cells(2).Range.Text = "Omschrijving (duidelijk vermelden plaats van vertrek en aankomst)"
.Cells(3).Range.Text = "Projectnr."
.Cells(4).Range.Text = "Auto km"
.Cells(5).Range.Text = "Bedrag"
.Cells(6).Range.Text = "Overig Bedrag"
.Cells(7).Range.Text = "Totaal"
.Cells(1).Range.Select
End With
End With
'Zet Style cellen vast
'Selection.MoveLeft Unit:=wdCharacter, Count:=5
Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 1)
For i = 0 To (ktabel - 2)
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Next i
Selection.Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
Call beveilig
End Function
Public Function beveilig()
Dim rtabel, ktabel As Long
rtabel = Selection.Tables(1).Rows.Count
ktabel = Selection.Tables(1).Columns.Count
Selection.Tables(1).Cell(1, 1).Select
'MsgBox ("Dit is de inhoud:" & rtabel & " " & ktabel)
If ActiveDocument.ProtectionType = wdNoProtection Then
ActiveDocument.Protect _
Type:=wdAllowOnlyFormFields, NoReset:=True, Password:="test01"
End If
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:="test01"
End If
Dim i As Integer
Selection.MoveDown Unit:=wdLine, Count:=2
For i = 0 To (ktabel - 4)
'selecteer kolom met km
If i <> 0 Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
End If
Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 3), Extend:=wdExtend
Selection.Editors.Add wdEditorEveryone
Next i
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 3), Extend:=wdExtend
Selection.Editors.Add wdEditorEveryone
'Als laatste dan maar expliciet(!)
'Selection.MoveLeft Unit:=wdCharacter, Count:=1
'Selection.MoveDown Unit:=wdLine, Count:=(rtabel - 3), Extend:=wdExtend
'Selection.Editors(wdEditorEveryone).Delete
ActiveDocument.Protect Password:="test01", NoReset:=False, Type:= _
wdAllowOnlyReading, UseIRM:=False, EnforceStyleLock:=False
End Function
Public Function onthef_beveilig()
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:="test01"
End If
End Function
Sub kolom_weg()
'
' kolom_weg Macro
'
'
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1
ActiveDocument.Unprotect
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=44, Extend:=wdExtend
Selection.MoveUp Unit:=wdLine, Count:=2, Extend:=wdExtend
Selection.Editors(wdEditorEveryone).Delete
Selection.Editors.Add wdEditorEveryone
ActiveDocument.Protect Password:="test01", NoReset:=False, Type:= _
wdAllowOnlyReading, UseIRM:=False, EnforceStyleLock:=False
End Sub
cheers,
bloempje