| Function xlFitRange( xl As Variant , xlSheet As Variant , vRange As Variant , vParam As Variant ) |
| ' |
| ' |
| ' |
| ' |
| ' |
| On Error GoTo GeneralError |
| ' |
| Dim vWidth As Variant |
| Dim vHeight As Variant |
| Dim vRangeColumn As Variant |
| Dim vRangeRow As Variant |
| Dim vValue As Variant |
| Dim i As Integer |
| Dim sValue As String |
| Dim sMsg As String |
| ' |
| ' |
| ' |
| If Instr( Cstr( vParam ) , "x" ) > 0 Then |
| vValue = Split( Trim(Cstr(vParam)) , "x" ) |
| vWidth = Trim(Cstr(vValue(0))) |
| vHeight = Trim(Cstr(vValue(1))) |
| Else |
| vWidth = Cstr( vParam ) |
| vHeight = Cstr( vParam ) |
| End If |
| ' |
| If Instr( Trim(Cstr(vRange)) , ":" ) Then |
| vValue = Split( Trim(Cstr( vRange )) , ":" ) |
| ' |
| For i = 1 to len( vValue( 0 ) ) |
| sValue = Mid$( vValue( 0 ) , i , 1 ) |
| If IsNumeric( sValue ) Then |
| vRangeRow = vRangeRow + sValue |
| Else |
| vRangeColumn = vRangeColumn + sValue |
| End If |
| Next |
| ' |
| If vRangeColumn <> "" Then vRangeColumn = vRangeColumn & ":" |
| If vRangeRow <> "" Then vRangeRow = vRangeRow & ":" |
| ' |
| For i = 1 to len( vValue( 1 ) ) |
| sValue = Mid$( vValue( 1 ) , i , 1 ) |
| If IsNumeric( sValue ) Then |
| vRangeRow = vRangeRow + sValue |
| Else |
| vRangeColumn = vRangeColumn + sValue |
| End If |
| Next |
| ' |
| Else |
| For i = 1 to len( vRange ) |
| sValue = Mid$( vRange , i , 1 ) |
| If IsNumeric( sValue ) Then |
| vRangeRow = vRangeRow + sValue |
| Else |
| vRangeColumn = vRangeColumn + sValue |
| End If |
| Next |
| If vRangeColumn <> "" Then vRangeColumn = vRangeColumn & ":" & vRangeColumn |
| If vRangeRow <> "" Then vRangeRow = vRangeRow & ":" & vRangeRow |
| End If |
| ' |
| ' |
| If Trim(Cstr( vRange )) = "" Then |
| xlSheet.Cells.Select |
| xl.Selection.Columns.AutoFit |
| xl.Selection.Rows.AutoFit |
| xlSheet.Range( "A1" ).Select |
| Else |
| If Lcase(Cstr( vParam )) = "" Then |
| If vRangeColumn <> "" Then xlSheet.Columns( vRangeColumn ).AutoFit |
| If vRangeRow <> "" Then xlSheet.Rows( vRangeRow ).AutoFit |
| Else |
| If vRangeColumn <> "" Then xlSheet.Columns( vRangeColumn ).ColumnWidth = Cdbl( vWidth ) |
| If vRangeRow <> "" Then xlSheet.Rows( vRangeRow ).RowHeight = Cdbl( vHeight ) |
| End If |
| End If |
| ' |
| WayOut: |
| Exit Function |
| GeneralError: |
| xl.Visible = False |
| sMsg = "Fehler (Nr. " & err & ") in Zeile " & Erl & ": " & Error |
| sMsg = sMsg & Chr(10) & Chr(10) |
| sMsg = sMsg & "Parameter: " & Chr(10) |
| sMsg = sMsg & "Bereich = " & Cstr( vRange ) & Chr(10) |
| sMsg = sMsg & "Maßangaben = " & Cstr( vParam ) & Chr(10) |
| sMsg = sMsg & "Spaltenbreite = " & Cstr( vWidth ) & Chr(10) |
| sMsg = sMsg & "Reihenhöhe = " & Cstr( vHeight ) & Chr(10) |
| sMsg = sMsg & "Bereich Spalten = " & Cstr( vRangeColumn ) & Chr(10) |
| sMsg = sMsg & "Bereich Reihen = " & Cstr( vRangeRow ) & Chr(10) |
| If Err = 213 And Error = "OLE: Automation object error" Then |
| sMsg = sMsg & Chr(10) & Chr(10) |
| sMsg = sMsg & "Hinweis: " & Chr(10) & "MS Excel meldet einen generellen Fehler." & Chr(10) |
| sMsg = sMsg & "Überprüfen sie die Angaben des Bereiches. Sie dürfen nur maximal einen Doppelpunkt enthalten, Zeilen- und Reihenangaben müssen plausibel sein." & Chr(10) |
| sMsg = sMsg & "" |
| Elseif err = 213 And ( Instr( Error , "ColumnWidth" ) > 0 Or Instr( Error , "RowHeight" ) > 0 ) Then |
| sMsg = sMsg & Chr(10) & Chr(10) |
| sMsg = sMsg & "Hinweis: " & Chr(10) & "Die Maßangaben müssen dem lokalen Zahlenformat entsprechen." & Chr(10) |
| sMsg = sMsg & "Das Zahlenformat für Breite oder Höhe kann vermutlich nicht interprteiert werden." |
| End If |
| MsgBox sMsg , 16 , "Fehler in Funktion xlFitRange()" |
| xl.Visible = True |
| Resume Next |
| End Function |