Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


38158 / 76732 ←次へ | 前へ→

【43717】Re:矢印(オートシェイプ)の書式設定ダイアログ
回答  Kein  - 06/10/23(月) 16:25 -

引用なし
パスワード
   全く方法が無い、というわけではありません。組み込みダイアログの各設定項目を、
ユーザーフォームや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
1 hits

【43695】矢印(オートシェイプ)の書式設定ダイアログ ひげくま 06/10/23(月) 11:25 質問
【43697】Re:矢印(オートシェイプ)の書式設定ダイア... Jaka 06/10/23(月) 12:13 発言
【43702】Re:矢印(オートシェイプ)の書式設定ダイア... ひげくま 06/10/23(月) 12:38 お礼
【43704】Re:矢印(オートシェイプ)の書式設定ダイア... ichinose 06/10/23(月) 12:51 発言
【43714】Re:矢印(オートシェイプ)の書式設定ダイア... ひげくま 06/10/23(月) 15:12 お礼
【43698】Re:矢印(オートシェイプ)の書式設定ダイア... かみちゃん 06/10/23(月) 12:14 発言
【43703】Re:矢印(オートシェイプ)の書式設定ダイア... ひげくま 06/10/23(月) 12:40 お礼
【43717】Re:矢印(オートシェイプ)の書式設定ダイア... Kein 06/10/23(月) 16:25 回答
【43720】Re:矢印(オートシェイプ)の書式設定ダイア... ひげくま 06/10/23(月) 17:18 お礼
【43721】Re:矢印(オートシェイプ)の書式設定ダイ... yuu1 06/10/23(月) 17:56 回答
【43733】Re:矢印(オートシェイプ)の書式設定ダイ... ひげくま 06/10/24(火) 9:29 お礼

38158 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free