- Katılım
- 20 Şubat 2006
- Mesajlar
- 259
Arkadaşlar sizce bu kırmızıya boyanmış parametre de hata nedeni ne olabilir. Saygılarımla...
Sub Aut
pen()
Call SpecialCellMenu
End Sub
'
Sub SpecialCellMenu()
Dim cb As CommandBar
Set cb = Application.CommandBars("Cell")
'
Set MenuObject = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
MenuObject.Caption = "Change Case...®"
MenuObject.BeginGroup = True
MenuObject.Tag = "MyTagR"
'
For MenuItem = 1 To 5
Set PopItem = MenuObject.Controls.Add(msoControlButton, 1, MenuItem, , True)
PopItem.FaceId = 7
With PopItem
Select Case MenuItem
Case 1
.Caption = "ABC DEF"
Case 2
.Caption = "Abc Def"
Case 3
.Caption = "abc def"
Case 4
.Caption = "Abc def"
Case 5
.Caption = "Abc Def GHI"
End Select
.OnAction = "CaseChange"
End With
Next
Set cb = Nothing
Set PopItem = Nothing
Set MenuObject = Nothing
End Sub
'
Sub Auto_Close()
Application.CommandBars("Cell").Reset
End Sub
'
Sub CaseChange()
Dim lngType As Long, MyRng As Range
Set MyWd = CreateObject("Word.Application")
Set MyDoc = MyWd.Documents.Add
Select Case CommandBars.ActionControl.Parameter
Case 1
lngType = 1
Case 2
lngType = 2
Case 3
lngType = 0
Case 4
lngType = 4
Case 5
For Each MyRng In Selection
If (Not MyRng = Empty) And (Not IsNumeric(MyRng)) Then
Temp = ""
z = ""
c = ""
MyWd.Selection.Text = MyRng.Text
MyWd.Selection.Range.Case = 2
Temp = MyWd.Selection.Text
MyRng = Temp
z = StrReverse(Temp)
x = InStr(1, z, " ")
If x > 0 Then
y = Mid(z, 1, InStr(1, z, " "))
For i = 1 To Len
c = c & WorksheetFunction.Proper(Mid(y, i, 1))
Next
MyRng = Mid(MyRng, 1, Len(MyRng) - x) & StrReverse(c)
End If
End If
Next
GoTo SafeExit:
End Select
For Each MyRng In Selection
If (Not MyRng = Empty) And (Not IsNumeric(MyRng)) Then
MyWd.Selection.Text = MyRng.Text
MyWd.Selection.Range.Case = lngType
MyRng = MyWd.Selection.Text
End If
Next
SafeExit:
MyDoc.Close False
MyWd.Quit
Set MyDoc = Nothing
Set MyWd = Nothing
End Sub
Sub Aut
pen()Call SpecialCellMenu
End Sub
'
Sub SpecialCellMenu()
Dim cb As CommandBar
Set cb = Application.CommandBars("Cell")
'
Set MenuObject = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
MenuObject.Caption = "Change Case...®"
MenuObject.BeginGroup = True
MenuObject.Tag = "MyTagR"
'
For MenuItem = 1 To 5
Set PopItem = MenuObject.Controls.Add(msoControlButton, 1, MenuItem, , True)
PopItem.FaceId = 7
With PopItem
Select Case MenuItem
Case 1
.Caption = "ABC DEF"
Case 2
.Caption = "Abc Def"
Case 3
.Caption = "abc def"
Case 4
.Caption = "Abc def"
Case 5
.Caption = "Abc Def GHI"
End Select
.OnAction = "CaseChange"
End With
Next
Set cb = Nothing
Set PopItem = Nothing
Set MenuObject = Nothing
End Sub
'
Sub Auto_Close()
Application.CommandBars("Cell").Reset
End Sub
'
Sub CaseChange()
Dim lngType As Long, MyRng As Range
Set MyWd = CreateObject("Word.Application")
Set MyDoc = MyWd.Documents.Add
Select Case CommandBars.ActionControl.Parameter
Case 1
lngType = 1
Case 2
lngType = 2
Case 3
lngType = 0
Case 4
lngType = 4
Case 5
For Each MyRng In Selection
If (Not MyRng = Empty) And (Not IsNumeric(MyRng)) Then
Temp = ""
z = ""
c = ""
MyWd.Selection.Text = MyRng.Text
MyWd.Selection.Range.Case = 2
Temp = MyWd.Selection.Text
MyRng = Temp
z = StrReverse(Temp)
x = InStr(1, z, " ")
If x > 0 Then
y = Mid(z, 1, InStr(1, z, " "))
For i = 1 To Len
c = c & WorksheetFunction.Proper(Mid(y, i, 1))
Next
MyRng = Mid(MyRng, 1, Len(MyRng) - x) & StrReverse(c)
End If
End If
Next
GoTo SafeExit:
End Select
For Each MyRng In Selection
If (Not MyRng = Empty) And (Not IsNumeric(MyRng)) Then
MyWd.Selection.Text = MyRng.Text
MyWd.Selection.Range.Case = lngType
MyRng = MyWd.Selection.Text
End If
Next
SafeExit:
MyDoc.Close False
MyWd.Quit
Set MyDoc = Nothing
Set MyWd = Nothing
End Sub