項目

イメージコントロールの画像を保存する

内容説明

UserForm等のコントロールのPictureプロパティに設定された画像をファイルとして保存するサンプルを示します。
SavePictureステートメントを用いることで簡単に処理出来ます。
但し、保存するファイル形式はビットマップ(.BMP)及びメタファイル(.emf)です。 (Pictureプロパティに設定されている画像のファイル形式に依存します)
ファイル名に"xxx.jpg"等と他形式の拡張子を指定してもファイル形式はビットマップ或いはメタファイルで保存されます。
WEBや書籍等でVBAのSavePictureステートメントがjpgやgifでも保存出来ると言う記述を見かけますが間違っていますのでご注意下さい。

'Pictureプロパティの画像をファイルとして保存するサンプル
'UserForm1モジュール
'UserForm1にImage1とCommandButton1を配置
Private Sub CommandButton1_Click()
  Dim fn$
  fn = "D:\eee\fff\ggg.jpg" 'ロードするファイル名
  Image1.Picture = LoadPicture(fn)
  Repaint 'Image1のEnabledプロパティをFalseに設定してある場合Repaintは不要
  fn = "D:\eee\fff\ggg.bmp" 'セーブするファイル名
  MsgBox "画像をロードしました" & vbCrLf & "保存し画像をクリアします", , "SavePictureのテスト"
  SavePicture Image1.Picture, fn
  Image1.Picture = LoadPicture 'クリア
  Repaint '同上
End Sub

追記1：ヘルプの概要
LoadPicture 関数
イメージ(Image)コントロールにグラフィックをロードします
構文
LoadPicture ([Filename])
指定項目　内容
Filename　省略可能です｡ファイル名を示す文字列式です｡フォルダ名とドライブ名を含めても構いません｡ファイル名の指定がなければイメージを消去します
解説
VisualBasicで認識されるピクチャファイルには、ビットマップ ファイル(.BMP)、アイコンファイル(.ICO)、カーソルファイル(.CUR)、run-lengthエンコードファイル(.RLE)、メタファイル(.WMF)、拡張メタファイル(.EMF)、GIFファイル(.GIF)、JPEGファイル(.JPG)などがあります
LoadPicture関数の引数を省略するとイメージコントロール内のピクチャが消去されます
ピクチャをロードしてイメージコントロール内に表示する場合は､ピクチャを表示するオブジェクトのPictureプロパティに､LoadPicture関数の戻り値を割り当てます


SavePicture ステートメント
コントロールに関連付けられたImageプロパティのピクチャをファイルに保管します
構文
SavePicture Picture, stringexpression
指定項目　内容
picture　ピクチャファイルに保管するピクチャを持つイメージ(Image)コントロールを指定します
stringexpression　ピクチャを保管するピクチャファイルの名前を指定します


追記2：デザイン時にPictureプロパティに画像を設定する方法
画像ファイルならプロパティ画面のPictureプロパティで[…]をクリックし読み込む
クリップボードの画像ならプロパティ画面のPictureプロパティを選択し貼り付ける(Ctrl+V)

項目

ネットワーク上のブックを開いているユーザー名を得る

内容説明

ネットワーク上のブックについて既に他のユーザーによって開かれている場合、そのユーザー名を取得するkGetOpenUser関数です。
ログインユーザーのWindowsアクセス権限(制限ユーザー/標準ユーザー/その他)に関係なく、開いているユーザー名を得る為に原始的な方法(ダイアログの文字列取得)を用いています。
(他に良い方法があればいいのですが...)

'標準モジュール
Option Explicit
Declare Function SetTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
  (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Const WM_CLOSE = &H10
Private Declare Sub GetWindowText Lib "user32" Alias "GetWindowTextA" _
  (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long)
Dim duser$

'kGetOpenUser関数　ネットワーク上のブックを開いているユーザー名を得る
'引数 file：ネットワーク上のブック(フルパス名)
'　　 例："\\aaa\bbb\ccc\ddd.xls"　注：必ず\\で始まっている必要あり
'戻り値：ユーザー名　""=ネットワーク上のブックは開かれていない
Function kGetOpenUser(file$) As String
  duser = ""
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  SetTimer 0, 0, 5, AddressOf pGetOpenUserProc
  On Error Resume Next
  With Workbooks.Open(Filename:=file, Notify:=False)
    If Err Then
      kGetOpenUser = duser
    Else
      duser = "Intact"
      'If .ReadOnly Then Debug.Print "ReadOnly"
      'If GetAttr(file) And vbReadOnly Then Debug.Print "vbReadOnly"
      .Close False
    End If
  End With
  On Error GoTo 0
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Function

Private Function pGetOpenUserProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
  Dim wnd&, buf$
  KillTimer 0, idEvent
  If duser = "" Then hWnd = FindWindowEx(0, 0, "#32770", "Microsoft Excel")
  If hWnd = GetActiveWindow Then
    wnd = FindWindowEx(hWnd, 0&, "MSOUNISTAT", vbNullString)
    If wnd Then
      buf = String(256, vbNullChar)
      GetWindowText wnd, buf, Len(buf)
      buf = Left$(buf, InStr(buf, vbNullChar) - 1)
      SendMessage hWnd, WM_CLOSE, 0, 0
      duser = Mid(buf, InStr(buf, "は現在 ") + 4, InStr(buf, " が使用") - InStr(buf, "は現在 ") - 4)
    End If
  End If
End Function

'kGetOpenUser関数の使用例
Sub test_kGetOpenUser()
  Dim file$, user$
  file = "\\aaa\bbb\ccc\ddd.xls" 'ネットワーク上のブック(フルパス名)
  user = kGetOpenUser(file)
  If user = "" Then
    MsgBox Dir(file) & vbCrLf & "ネットワーク上で開かれていません"
  Else
    MsgBox Dir(file) & vbCrLf & "ネットワーク上で開いているユーザー名" & vbCrLf & user
  End If
End Sub

追記：共有ファイルを開いている各ユーザー情報を得る
ネットワーク上の共有ファイルの場合は UserStatusプロパティ で開いている各ユーザー名等の情報が取得出来ます。

項目

VBAでスクリプトを使用する

内容説明

VBScriptコード(スクリプト)をファイル(.vbs)に出力せず実行する事が出来ます。
ScriptControlオブジェクトを用います。
文字列で与えたスクリプトを実行できる夢のような処理が出来ます。用途はアイデア次第でしょう。

ScriptControlオブジェクトの解説(ヘルプより引用)
アプリケーションでスクリプトを使用できるようにします｡
機能
● ActiveX Scriptingをサポートするすべてのスクリプト言語。
● スクリプトをコンパイルする機能と､発生したエラーに関する詳細なエラー情報を表示する機能｡
● スクリプト実行時に発生した実行時エラーをトラップして表示する機能｡
● オブジェクトモデルの機能をスクリプトに公開する機能。
● グローバルな関数をスクリプトに公開する機能｡
● スクリプトの機能と実行時間を制限する機能｡

詳細はヘルプをご覧下さい
MSSCRIPT.HLP (Microsoft Script Control リファレンス)
　C:\WINNT\system32\MSSCRIPT.HLP
VBSCRIP5.CHM (Microsoft Visual Basic Scripting Edition[VBScript ランゲージ リファレンス])
　C:\Program Files\Microsoft Visual Studio\Common\IDE\IDE98\MSE\1041\VBSCRIP5.CHM
(フォルダ、ファイル名はOS、Office等のバージョンにより異なります)

参照設定[Microsoft Script Control x.x]
c:\winnt\system32\msscript.ocx

'■利用例1 (事後バインディング)
Sub test1_ScriptControl()
  Dim cd$, aa, bb, cc, zz
  aa = 1: bb = 2: cc = 3
  cd = "Sub Main(aa,bb,cc,zz)" & vbNewLine & "On Error Resume Next" & vbNewLine & _
    "zz=aa+bb+cc" & vbNewLine & _
    "End Sub"
  With CreateObject("MSScriptControl.ScriptControl")
    .Language = "VBScript"
    .AddCode cd 'code
    .Run "Main", aa, bb, cc, zz
  End With
  Debug.Print cd
  Debug.Print "zz="; zz
End Sub

'■利用例2 (参照設定[Microsoft Script Control x.x])
Sub test2_ScriptControl()
  Dim cd$ ', sc As ScriptControl
  cd = "Sub Main()" & vbNewLine & "On Error Resume Next" & vbNewLine & _
    "MsgBox ""test"", , ""title""" & vbNewLine & _
    "End Sub"
  'Set sc = New ScriptControl
  With New ScriptControl
    .Language = "VBScript"
    .AddCode cd
    .Run "Main"
  End With
  Debug.Print cd
End Sub

'■利用例3 (オブジェクトモデルをスクリプトエンジンで使用する)
'(HELPより引用) AddObjectメソッドの使い方
Private Sub test3_ScriptControl()
  Dim p1$, sc As Object, fs As Object
  'FileSystemObjectのインスタンス作成
  Set fs = CreateObject("Scripting.FileSystemObject")
  'スクリプトコントロールを初期化
  Set sc = CreateObject("ScriptControl")
  With sc
    .Language = "VBScript"
    .AllowUI = True
    .UseSafeSubset = False
    'スクリプトコントロールにFileSystemObjectを追加
    .AddObject "FileSystem", fs, True
    'スクリプトコードを定義
    p1 = "Sub Sub1" & vbNewLine & _
      "  Dim Msg" & vbNewLine & _
      "  Msg = FileSystem.Drives.Count" & vbNewLine & _
      "  Msg = Msg & "" 個のドライブが接続されています。""" & vbNewLine & _
      "  MsgBox Msg" & vbNewLine & _
      "End Sub"
    'スクリプトコードを追加
    .AddCode p1
    'スクリプトコードを実行
    .Run "Sub1"
  End With
End Sub

'■利用例4 (式や関数の結果、定数の値を得る)
Sub test4_ScriptControl()
  With CreateObject("MSScriptControl.ScriptControl")
    .Language = "VBScript"
    Debug.Print .Eval("1+2*3/4"), .Eval("Atn(1)")
    Debug.Print .Eval("vbOk"), .Eval("vbRed")
  End With
End Sub

'■利用例5 (ScriptControlで配列ソートを行うユーザー関数)
'kVbsSort関数 ScriptControlで配列ソート
'引数　 ar:配列
'       reverse:False=正順(既定値) True=逆順
'戻り値 ソートした配列
Function kVbsSort(ByVal ar As Variant, Optional ByVal reverse As Boolean) As Variant
  Dim js As Object 'JScriptTypeInfo
  With CreateObject("ScriptControl") 'New ScriptControl
    .Language = "JScript"
    .AddCode ("function VbsSort(ar){" & "return(new VBArray(ar).toArray().sort());}")
    Set js = .Run("VbsSort", ar)
    If reverse Then js.reverse
    kVbsSort = Split(js, ",")
  End With
End Function

'kVbsSort関数の実行例
Sub test1_kVbsSort()
  Dim ar, item
  ar = Array("555", "222", "111", "444", "333") 'テストデータ
  ar = kVbsSort(ar)   'ソート
  For Each item In ar 'ソート済み配列の表示
    Debug.Print item
  Next
End Sub
Sub test2_kVbsSort()
  Dim ar, item, so
  ReDim ar(1 To 5) 'テストデータ
  ar(1) = "CCC": ar(2) = "AAA": ar(3) = "EEE": ar(4) = "DDD": ar(5) = "BBB"
  so = kVbsSort(ar, True)
  For Each item In so
    Debug.Print item
  Next
End Sub

項目

ThisWorkbookのオブジェクトを得る

内容説明

デフォルトではブックモジュール(ThisWorkbook)のオブジェクト名は"ThisWorkbook"ですが任意に変更されていた場合でもブックモジュールを取得する関数です。
VBIDEインターフェイスを使用して汎用的にThisWorkbookオブジェクトを操作するには必須です。
ブックモジュールのオブジェクト名が変更されている場合、処理が出来ないソフトをよく見かけますので心当たりの作者の方はどうぞご利用下さい。

'kGetThisWorkbook関数
'引数　：wb ターゲットのワークブック
'戻り値：ブックモジュール(ThisWorkbook)のオブジェクト VBComponent
'参照設定[Microsoft Visual Basic for Applications Extensibility x.x]
'関数、変数のデータ型 Object→VBComponent(参照設定した場合)
Function kGetThisWorkbook(Optional wb As Workbook) As Object 'VBComponent
  If wb Is Nothing Then Set wb = ActiveWorkbook
  Set kGetThisWorkbook = wb.VBProject.VBComponents(wb.CodeName)
End Function

'kGetThisWorkbook関数の使用例1
Sub test1_kGetThisWorkbook()
  Dim vc As Object 'VBComponent
  Set vc = kGetThisWorkbook 'ActiveWorkbook
  Debug.Print vc.Name
  Debug.Print "コードモジュールの行数="; vc.CodeModule.CountOfLines
End Sub

'kGetThisWorkbook関数の使用例2
Sub test2_kGetThisWorkbook()
  Dim wb As Workbook, vc As Object 'VBComponent
  Set wb = Workbooks("Book1.xls")
  Set vc = kGetThisWorkbook(wb)
  Debug.Print wb.Name; " "; vc.Name; " コードの表示"
  Debug.Print vc.CodeModule.Lines(1, vc.CodeModule.CountOfLines)
End Sub

'全コンポーネント処理の雛型(ブックモジュールを見分ける例)
'参照設定[Microsoft Visual Basic for Applications Extensibility x.x]
Sub testAllComponentsProcessed()
  Dim vc As VBComponent 'Object
  Dim wb As Workbook
  Set wb = ActiveWorkbook
  For Each vc In wb.VBProject.VBComponents
    Select Case vc.Type
    Case vbext_ct_StdModule       '1 標準モジュール
      '
    Case vbext_ct_ClassModule     '2 クラス モジュール
      '
    Case vbext_ct_MSForm          '3 Microsoft Form
      '
    Case vbext_ct_ActiveXDesigner '11 ActiveX デザイナ
      '
    Case vbext_ct_Document        '100 Document モジュール
      If vc.Name = wb.CodeName Then
      'If vc.Properties("Name") = wb.Name Then '別法
        'ブックモジュールの処理
        Debug.Print wb.Name, "ブックモジュール名="; vc.Name
        '
      Else
        'シートモジュールの処理
        '
      End If
    End Select
  Next
End Sub

追記： 開いている全てのファイルを取得する
アドインファイルを含めて現在開いている全てのファイル名を取得する例を示します。

Sub testAllOpenFiles()
  Dim vp As Object, Name$
  For Each vp In Application.VBE.VBProjects
    Name = ""
    On Error Resume Next
    Name = Dir(vp.Filename)
    On Error GoTo 0
    If Name = "" Then Name = vp.VBComponents(1).Properties("Name")
    Debug.Print Name
    '
  Next
End Sub

項目

エクセルを閉じる時に終了処理の不都合を解消する

内容説明

Exceを閉じるときに終了処理(メニューを戻す、データを退避・クリア等)の不都合を解消する方法です。
ThisWorkbookのBeforeCloseイベントで終了処理を行った場合は、終了処理後に[Bookへの変更を保存しますか？] [はい][いいえ][キャンセル]のメッセージボックスが表示され、[キャンセル]を選択した場合、Excelは閉じません。
終了処理は終了しているのに実際はExcelは閉じていないという不都合が発生します。
この不都合を解消してBeforeCloseイベントにて保存処理を行う方法を示します。 方法としては保存処理を自前で行うしか方法は無いようです。

'ThisWorkbookモジュール
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim Wb As Workbook, flg As Boolean
  For Each Wb In Workbooks
    If Wb.Saved = False Then
      Select Case MsgBox(Wb.Name & "への変更を保存しますか?", vbYesNoCancel Or vbExclamation)
      Case vbNo
        Wb.Saved = True
      Case vbYes
        If Dir(Wb.FullName, vbHidden Or vbReadOnly Or vbSystem) = "" Then
          flg = Not Application.Dialogs(xlDialogSaveAs).Show
          If flg = True Then Exit For
        Else
          Wb.Save
        End If
      Case vbCancel
        flg = True: Exit For
      End Select
    End If
  Next
  If flg Then 'キャンセルされた
    Cancel = True
  Else
    '閉じられる時の処理を記述(メニューを戻す、データを退避・クリア・保存等の処理)
    MsgBox "Test" & vbCrLf & ThisWorkbook.Name & "は閉じられます"
    '
  End If
End Sub

ExcelでありExcelでないアプリ[kStart]

項目

ユーザーフォームをマクロで作成

内容説明

ユーザーフォームをマクロで作成する方法です。
主に開発ツールとして利用する事が出来ます。
VBIDEインターフェイスを使用するため
[セキュリティ]-[信頼のおけるソース元] のチェック
及び、以下への参照設定が必要です。
Microsoft Forms x.x Object Library
Microsoft Visual Basic for Applications Extensibility x.x


'標準モジュール
Option Explicit

'UserFormの作成、表示、削除
Sub test_UserFormAdd()
  Dim vc As Object 'VBComponent
  Set vc = ThisWorkbook.VBProject.VBComponents.Add(3) 'vbext_ct_MSForm) '作成
  UserForms.Add(vc.Name).Show '表示
  ThisWorkbook.VBProject.VBComponents.Remove vc '削除
End Sub

'ユーザーフォームをマクロで作成例
Sub test_kPassDialogAdd()
  Dim wb As Workbook
  Set wb = ActiveWorkbook
  kPassDialogAdd wb, "保護の解除"
End Sub

'パスワード入力ダイアログを作成して実行処理例
Sub test_kPassDialogShow()
  Dim pass$
  pass = kPassDialogShow
  If pass <> "Cancel" Then MsgBox "パスワード: " & pass
End Sub

'パスワード入力ダイアログ作成
Function kPassDialogAdd(wb As Workbook, Optional cap$ = "ライセンス登録") As Object 'VBComponent
  Dim ctl As Object 'Controls
  Set kPassDialogAdd = wb.VBProject.VBComponents.Add(3) 'vbext_ct_MSForm) '作成
  With kPassDialogAdd
    .Properties("Width").Value = 184
    .Properties("Height").Value = 67
    .Properties("Caption").Value = cap
    Set ctl = .Designer.Controls
  End With
  With ctl.Add("Forms.Label.1")
    .Caption = "パスワード(P)"
    .Accelerator = "P"
    .Height = 10: .Left = 6: .Top = 6: .Width = 72
  End With
  With ctl.Add("Forms.TextBox.1")
    .Height = 16: .Left = 6: .Top = 20: .Width = 100
    .PasswordChar = "*"
  End With
  With ctl.Add("Forms.CommandButton.1")
    .Caption = "OK"
    .Default = True
    .Height = 17.5: .Left = 115: .Top = 5: .Width = 60
  End With
  With ctl.Add("Forms.CommandButton.1")
    .Caption = "キャンセル"
    .Cancel = True
    .Height = 17.5: .Left = 115: .Top = 27: .Width = 60
  End With
End Function

'パスワード入力ダイアログを作成して実行処理
Function kPassDialogShow() As String
  Dim uf As Object, uu As Object, cap$
  Dim vc As Object ' VBComponent
  cap = "ライセンス登録"
  kPassDialogShow = "Cancel"
  Set vc = kPassDialogAdd(ThisWorkbook, cap)
  vc.CodeModule.DeleteLines 1, vc.CodeModule.CountOfLines
  vc.CodeModule.InsertLines 1, _
    "Private Sub CommandButton1_Click()" & vbCrLf & _
    "Hide" & vbCrLf & _
    "End Sub" & vbCrLf & _
    "Private Sub CommandButton2_Click()" & vbCrLf & _
    "Unload Me" & vbCrLf & _
    "End Sub"
  Set uf = UserForms.Add(vc.Name)
  uf.Show
  For Each uu In UserForms
    If uu.Name = uf.Name Then kPassDialogShow = uf.TextBox1
  Next
  'ThisWorkbook.VBProject.VBComponents.Remove vc
End Function

項目

ユーザーフォーム名を変数で指定して表示する

内容説明

ユーザーフォームのオブジェクト名を変数(文字列)で与えて表示等の制御を行う方法です。
UserFormsオブジェクトのAddメソッドを用います。

'標準モジュール
Option Explicit
Dim duf As Object

'基本形 ユーザーフォームを変数で表示
Sub test1_E03M104()
  Dim uf$
  uf = "UserForm1" 'UserFormオブジェクト名
  VBA.UserForms.Add(uf).Show 'ユーザーフォーム名を変数で指定して表示
End Sub

'オブジェクト変数に代入し制御
Sub test_Show()
  Dim uf$
  uf = "UserForm1" 'UserFormオブジェクト名
  Set duf = VBA.UserForms.Add(uf)
  duf.Caption = "test_Show" 'オブジェクト変数にて色々制御
  duf.Show vbModeless
  AppActivate Application 'フォーカスをシートに戻す
End Sub

'オブジェクト変数でUnload
Sub test_Unload()
  Unload duf
  Set duf = Nothing
End Sub

'ユーザーフォーム名でUnload
Sub test2_Unload()
  Dim uu As Object
  For Each uu In UserForms
    If uu.Name = "UserForm1" Then Unload uu
  Next
End Sub

追記： 表示されているユーザーフォームとロードされているユーザーフォームの数を調べる


Sub test_UserFormDebug()
  Dim uu As Object, ii&
  '表示されているユーザーフォームの数
  Debug.Print "Show="; DoEvents
  'ロードされているユーザーフォームの数
  Debug.Print "Load="; UserForms.Count
  For Each uu In UserForms
    ii = ii + 1
    Debug.Print ii; uu.Name, uu.Visible
  Next
End Sub

項目

ユーザーフォームをアクティブセルの位置に表示

内容説明

ユーザーフォームをアクティブセルの隣にぴったり表示する方法です。


'kFormPosCell関数
'ユーザーフォームを指定セルに表示
'uf：ユーザーフォーム
'pos：表示するセル位置(既定値はActiveCellの右下)
Sub kFormPosCell(uf As Object, Optional pos As Range)
  If ActiveWindow.Panes.Count > 1 Then Exit Sub '[ウィンドウ枠の固定],[分割]には未対応
  Static kx!, ky!, zm#, zx#, zy#
  Dim ww&, hh&, deskw&, deskh&, ia As IAccessible
  If kx = 0 Or ky = 0 Then
    Set ia = uf
    ia.accParent.accLocation 0, 0, ww, hh
    ia.accParent.accParent.accLocation 0, 0, deskw, deskh
    kx = uf.Width / ww: ky = uf.Height / hh '0.75
  End If
  If pos Is Nothing Then Set pos = ActiveCell.Offset(1, 1) '右下
  With ActiveWindow
    If zm <> .Zoom / 100 Then
      zm = .Zoom / 100 'x縮尺
      'y縮尺 75%時等の誤差解消に必須
      zy = CLng(pos.Height / ky * zm + 0.1) * ky / pos.Height
      zx = CLng(pos.Width / kx * zm) * kx / pos.Width
    End If
    uf.StartUpPosition = 0
    uf.Move pos.Left * zx + .PointsToScreenPixelsX(0) * kx, _
      pos.Top * zy + .PointsToScreenPixelsY(0) * ky
  End With
End Sub

'ユーザーフォームモジュール
'kFormPosCell関数の利用例
Private Sub UserForm_Initialize()
  kFormPosCell Me
End Sub

注： kFormPosCell関数は実用ツール[k蘭]にて用いているルーチンの一部です。
[k蘭]-[カレンダー]コマンドでカレンダーをポップアップ表示しています。
エクセル入力支援[k蘭]
但し、ここに示したkFormPosCell関数は[ウィンドウ枠を固定]や[分割]には対応していません。
[k蘭]では[ウィンドウ枠を固定]や[分割]に対応しています。

項目

ユーザーフォームにハイパーリンクを設定する

内容説明

ユーザーフォームにWebページや電子メールアドレス等のハイパーリンクを設定する方法です。
FollowHyperlinkメソッドを用いる事で簡単に、シート上のハイパーリンクと同様の機能を実現出来ます。
LabelのCaptionプロパティにハイパーリンクの文言を記述し、Clickイベントで実行します。


LabelのClickイベントへの記述要領
（詳細はFollowHyperlinkメソッドのヘルプをご参照ください。）

Private Sub lblMaile_Click() 'メール
  ThisWorkbook.FollowHyperlink "mailto:kmado<kmado@aqua-r.tepm.jp>>?subject=k窓について", , True
End Sub

Private Sub lblWebsite_Click() 'WebSiteを開く
  ThisWorkbook.FollowHyperlink Address:="http://www2.aqua-r.tepm.jp/~kmado/", NewWindow:=True
End Sub

kHyperForm.xls(ソース公開)のダウンロード


追記1：デザイン時のLabelプロパティ例
Labelのプロパティは外観をハイパーリンクのように設定します。

ForeColor = &HC00000(青色)
MousePointer = fmMousePointerCustom '99
MouseIcon = xxx.cur(指差しのカーソル) karrow.curのダウンロード
ControlTipText = "作者へのeメール" '"WebSite「k窓」"
Caption = "kmado@aqua-r.tepm.jp" '"http://www2.aqua-r.tepm.jp/~kmado/"
Font.Underline = True 'Fontオブジェクトで下線の設定

追記2：無理やり機能を実現した例
FollowHyperlinkメソッドの存在を知らない為に無理やり機能を実現した例を書籍やWEB上等でよく見かけます。作者の方はご注意下さい。

'(1)IEを起動するパターン
Private Sub Label1_Click()
  'With New SHDocVw.InternetExplorer '参照設定 Microsoft Internet Controls
  With GetObject("", "Internetexplorer.Application") '実行時バインディング
    .Visible = True
    .Navigate "http://www.google.co.jp/"
  End With
End Sub

'(2)HyperlinkオブジェクトのAddメソッドを用いた最悪のパターン
Private Sub Label2_Click()
  Application.ScreenUpdating = False
  With Workbooks.Add(xlWBATWorksheet)
    With ActiveSheet.Hyperlinks.Add(Anchor:=Selection, Address:="http://www.google.co.jp/")
      .Follow NewWindow:=True
    End With
    .Close False
  End With
  Application.ScreenUpdating = True
End Sub

'(3)APIのShellExecute関数を用いたパターン
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
  (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub LabelWebSite_Click()
  ShellExecute 0&, vbNullString, "http://www.google.co.jp/", vbNullString, vbNullString, vbNormalFocus
End Sub
Private Sub LabelSupport_Click()
  ShellExecute 0&, vbNullString, "mailto:xxx@xxx.com?subject=Support", vbNullString, vbNullString, vbNormalFocus
End Sub

追記3： Windows組み込みのハンドカーソルを使う
kHyperForm.xls(ソース公開)では、ハイパーリンクをポイントした場合のハンドカーソルはデザイン時にMouseIconプロパティへcurファイルを設定しています。
ここでは、Windows組み込みのハンドカーソルを使う方法を2つ程示します。
MouseIconプロパティは空にしておきます。

その1：MouseMoveイベントで処理する
'UserFormモジュール
'ハイパーリンク用にLabel1を配置
Option Explicit
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" _
   (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib "user32" _
  (ByVal hCursor As Long) As Long
Const IDC_HAND = 32649& 'ハンドカーソル
Dim dcur As Long

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If dcur Then SetCursor dcur
End Sub

Private Sub UserForm_Initialize()
  dcur = LoadCursor(0&, IDC_HAND)
End Sub

その2：組み込みアイコンハンドルをMouseIconプロパティへ設定
'UserFormモジュール
'ハイパーリンク用にLabel1を配置
Private Sub UserForm_Initialize()
  Label1.MousePointer = fmMousePointerCustom
  Label1.MouseIcon = kIPictureDisp
End Sub

'標準モジュール MIPictureDisp
Option Explicit
Type PictDesc
  cbSize As Long
  picType As Long
  hIcon As Long
End Type
Type RIID
  id(16) As Byte
End Type
Const PICTYPE_ICON = 3
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" _
  (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
  (lpPictDesc As PictDesc, iid As RIID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

'kIPictureDisp関数　アイコンハンドルをピクチャー(IPictureDisp)へ変換
'引数　hIcon:アイコンハンドル(ExtractIcon,LoadCursor,LoadIcon等の戻り値)
'　　　省略値=ハンドカーソルを設定
'戻り値: ピクチャーオブジェクト(IPictureDisp)
'使用例: Label1.MouseIcon = kIPictureDisp(hIcon)
'　　　　CommandButton1.Picture = kIPictureDisp(hIcon)
Function kIPictureDisp(Optional hIcon As Long) As IPictureDisp
  Dim pict As PictDesc, dis As RIID
  If hIcon = 0 Then hIcon = LoadCursor(0, 32649&) 'IDC_HAND
  dis.id(8) = &HC0: dis.id(15) = &H46
  With pict
    .cbSize = Len(pict)
    .picType = PICTYPE_ICON
    .hIcon = hIcon
  End With
  OleCreatePictureIndirect pict, dis, 1, kIPictureDisp
End Function

項目

セルの右クリックショートカットメニューを設定する

内容説明

セルの右クリックショートカットメニューのカスタマイズはCommandBar名"Cell"に対して設定します。
'通常次のような記述
Application.CommandBars("Cell").Controls.Add
　 これでは[表示]が[標準]に付いては正常に設定されますが、[改ページプレビュー]の場合ショートカットメニューが作成されません。
実は[標準]と[改ページプレビュー]のCommandBarは別物でそれぞれ個別に設定する必要があります。
しかし、CommandBar名は両方とも"Cell"という同名であり名前での区別はつきません。
Indexで区別はつきますがEcxcelのバージョンや環境によってIndexが一定ではありません。
これらの状況を勘案し簡潔に確実に、セルの右クリックショートカットメニューの作成・削除を行うサンプルを示します。

'[表示]が[標準]、[改ページプレビュー]両方に
'セルの右クリックショートカットメニューを作成
Sub test_CellBarAdd()
  Dim cb As CommandBar
  test_CellBarDel
  For Each cb In Application.CommandBars
    If cb.Name = "Cell" Then
      With cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
        .Caption = "aaa(&A)"
        With .Controls.Add(Temporary:=True)
          .Caption = "bbb(&B)"
          .OnAction = "bbb"
          .FaceId = 52
        End With
        With .Controls.Add(Temporary:=True)
          .Caption = "ccc(&C)"
          .OnAction = "ccc"
        End With
      End With
    End If
  Next
End Sub

'作成したセルの右クリックショートカットメニューを削除
Sub test_CellBarDel()
  Dim cb As CommandBar
  On Error Resume Next
  For Each cb In Application.CommandBars
    If cb.Name = "Cell" Then
      cb.Controls("aaa(&A)").Delete
    End If
  Next
End Sub

その2：もう1つのセルの右クリックショートカットメニュー
選択セルの縁を右クリックする"Nondefault Drag and Drop"ショートカットメニューのカスタマイズ例です。
"セルの交換(&S)"と言うメニュー項目を追加し選択セルの値を相互に入れ替えます。

'セルの右クリック[ドラッグ&ドロップ]ショートカットメニューの拡張
'開始 メニューの追加
Sub kExtensionNondefaultAdd()
  kExtensionNondefaultDell
  With Application.CommandBars("Nondefault Drag and Drop").Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
    .Caption = "セルの交換(&S)"
    '.OnAction = ThisWorkbook.Name & "!kSwapDragDrop"
    .OnAction = "kSwapDragDrop"
    .FaceId = 1545
  End With
End Sub
'終了 メニューの削除
Sub kExtensionNondefaultDell()
  On Error Resume Next
  Application.CommandBars("Nondefault Drag and Drop").Controls("セルの交換(&S)").Delete
End Sub

Private Sub kSwapDragDrop()
  Application.CommandBars.FindControl(, 2048).Execute
  Application.OnTime Now, "pSwapCells1"
End Sub
Private Sub pSwapCells1()
  Application.CommandBars.FindControl(msoControlButton, 128).accDoDefaultAction
  pSwapCells2 Selection
  Application.OnTime Now + TimeValue("00:00:01"), "pSwapCells2"
End Sub
Private Sub pSwapCells2(Optional ByVal rr As Range)
  Static rg As Range
  Dim vv As Variant
  If Not rr Is Nothing Then Set rg = rr: Exit Sub
  vv = Selection.Value: Selection = rg.Value
  rg = vv:  rg.Select
End Sub