| |
全く方法が無い、というわけではありません。組み込みダイアログの各設定項目を、
ユーザーフォームやInputBoxなどを使って問い合わせるマクロを作れば、どうにか
目的とすることが出来そうです。ただし、やたらとコードが長く複雑になるわり
には、マクロ化するだけのメリットがあるかどうかは、大いに疑問が残るところ
でしょう。右クリックのメニューで、簡単に設定を変更できることだから。
いちおう、サンプルを作ってみました。標準モジュールの先頭から入れて下さい。
最近のバージョンでは、先端の形状の種類とか始点・終点別の設定、また線の太さも
ポイント値で細かく設定できようになってますが、それを全て実現させるのは
ホネが折れるので、Excel95時代に可能だった設定内容のみで構成しています。
最近のバージョンに合わせた設定項目にするなら、サンプルを元にして自分で改造
してみて下さい。
直線に登録するマクロは、一番下の Set_MyLine です。
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Type ChooseColor
lStructSize As Long
hWndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As ChooseColor) As Long
Private Const CC_RGBINIT = &H1
Private Const CC_LFULLOPEN = &H2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_SHOWHELP = &H8
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Function GetColorValue(ByVal hWnd As Long) As Long
Dim udtChooseColor As ChooseColor
Dim Ret As Long
With udtChooseColor
.lStructSize = Len(udtChooseColor)
.hWndOwner = hWnd
.hInstance = 0
.lpCustColors = String$(64, Chr$(0))
.flags = CC_RGBINIT
End With
Ret = ChooseColor(udtChooseColor)
If Ret <> 0 Then
If udtChooseColor.rgbResult > RGB(255, 255, 255) Then
GetColorValue = -2
Else
GetColorValue = udtChooseColor.rgbResult
End If
Else
GetColorValue = 0
End If
End Function
Private Sub LineColor(x As String)
Dim hWnd As Long, Ret As Long
hWnd = FindWindow("XLMAIN", Application.Caption)
Ret = GetColorValue(hWnd)
If Ret <> 0 Then
ActiveSheet.Lines(x).Border.Color = Ret
End If
End Sub
Sub Set_MyLine()
Dim x As Variant, AryH As Variant, AryB As Variant
Dim HType As Integer, BType As Integer
Const St1 As String = "先端の形状を以下の数値で指定して下さい" & _
vbLf & "1 = 無し" & vbLf & "2 = 開く" & vbLf & "3 = 閉じる" & _
vbLf & "4 = 両端開く" & vbLf & "5 = 両端閉じる"
Const St2 As String = "線の太さを以下の数値で指定して下さい" & _
vbLf & "1 = 極細" & vbLf & "2 = デフォルト" & vbLf & _
"3 = 中太" & vbLf & "4 = 太"
x = Application.Caller
If VarType(x) <> 8 Then Exit Sub
If TypeName(ActiveSheet.DrawingObjects(x)) <> "Line" Then Exit Sub
AryH = Array(xlNone, xlOpen, xlClosed, xlDoubleOpen, xlDoubleClosed)
AryB = Array(xlHairline, xlThin, xlMedium, xlThick)
Do
HType = Application.InputBox(St1, Type:=1)
If HType = False Then Exit Sub
Loop While HType < 1 Or HType > 5
ActiveSheet.Lines(x).ArrowHeadStyle = AryH(HType - 1)
Do
BType = Application.InputBox(St2, Type:=1)
If BType = False Then Exit Sub
Loop While BType < 1 Or BType > 4
ActiveSheet.Lines(x).Border.Weight = AryB(BType - 1)
Call LineColor(CStr(x)) 'コモンダイアログのカラーパレット呼び出し
End Sub
|
|
Kein
- 06/10/23(月) 16:25 -
