項目

ユーザーフォームのタイトルバー非表示

内容説明

ユーザーフォームのタイトルバーを非表示にするkFormNonCaption関数を示します。
スプラッシュウィンドウやプログレスバー等に用いることが出来ます。

Option Explicit
Option Private Module '←標準モジュールの場合
Private Declare Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" _
  (ByVal pacc As Object, phwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Const GWL_STYLE = (-16&)
Const GWL_EXSTYLE = (-20&)
Const WS_CAPTION = &HC00000
Const WS_EX_DLGMODALFRAME = &H1&

'kFormNonCaption関数
'ユーザーフォームのタイトルバー非表示
'引数：uf ユーザーフォーム
'      flat True=フラットなウィンドウにする(枠無し)
'戻値：0=失敗 0<>成功 変更前のウィンドウスタイルの値
Function kFormNonCaption(ByVal uf As Object, Optional ByVal flat As Boolean) As Long
  Dim wnd As Long, ih#
  ih = uf.InsideHeight
  WindowFromObject uf, wnd
  If flat Then SetWindowLong wnd, GWL_EXSTYLE, GetWindowLong(wnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
  kFormNonCaption = SetWindowLong(wnd, GWL_STYLE, GetWindowLong(wnd, GWL_STYLE) And Not WS_CAPTION)
  DrawMenuBar wnd
  uf.Height = uf.Height - uf.InsideHeight + ih
End Function

'kFormNonCaption関数の使用例
'UserFormモジュール
Option Explicit

Private Sub UserForm_Activate()
  '実際にはイニシャル処理を記述
  Application.Wait Now + TimeValue("0:00:03")
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  kFormNonCaption Me, True
End Sub

追記：高度なウィンドウスタイル
Excelウインドウ左上のアイコンを変更、UserFormのタイトルバーにアイコンを設定する等については ソフトウェア<Our Software>
エクセルVBAテクニック集 kVBA1
クラス編については
エクセルVBAテクニック集 kVBA4
をご参照下さい。

項目

セル範囲から指定したセル範囲を分離する

内容説明

2 つ以上のセル範囲を集合するUnionメソッドが有りますが逆にセル範囲から指定したセル範囲を分離する機能は準備されていません
そこでセル範囲から指定したセル範囲を分離したRangeオブジェクトを返すkDisunion関数を示します。

'kDisunion関数
'セル範囲から指定したセル範囲を分離したRangeオブジェクトを返します。
'引数　 Cell:元のセル範囲 Exclusion:分離するセル範囲
'戻り値 Range
Function kDisunion(Cell As Range, Exclusion As Range) As Range
  Dim rr As Range
  For Each rr In Cell
    If Application.Intersect(Exclusion, rr) Is Nothing Then
      If kDisunion Is Nothing Then
        Set kDisunion = rr
      Else
        Set kDisunion = Application.Union(kDisunion, rr)
      End If
    End If
  Next
End Function

'kDisunion関数のテスト
Sub test_kDisunion()
  Dim rg As Range
  Set rg = kDisunion(Range("a1:c10"), Range("b2"))
  Debug.Print rg.Address
  rg.Select '確認の為
End Sub

項目

線の書式設定をする

内容説明

線の描画を行うツール等にて線の色・太さ・種類の書式設定を行う場合どのようにしていますか。
ユーザーフォームで線の色・太さ・種類の書式設定を実装するには相当大変な作業となります。ここではExcelの組み込みダイアログ ボックスを利用した非常に簡単な方法を示します。
(Excel2000/2002/2003で利用可。Excel2007では利用不可)

'標準モジュール
Option Explicit
Option Private Module
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Const GWL_EXSTYLE = (-20)
Const WS_EX_CONTEXTHELP = &H400&

'kDialogLine関数
'描画オブジェクトの書式設定ダイアログを表示します
'引数 Color　   色       xlColorIndexAutomatic/xlColorIndexNone/RGB関数の値/ColorConstantsクラスの色定数(vbRed,vbBlackなど)
'　　 Weight    線の太さ XlBorderWeightクラスのxlHairline､xlThin､xlMedium､xlThick
'　　 LineStyle 線の種類 XlLineStyleクラスの

xlContinuous､xlDash､xlDashDot､xlDashDotDot､xlDot､xlDouble､xlSlantDashDot､xlLineStyleNone
'戻り値 vbOK:OKキーが押された  vbCansel:キャンセルされた
'     0:エラー(アクティブシートの描画オブジェクトが保護されている)
Function kDialogLine(Color As Long, Weight As XlBorderWeight, LineStyle As XlLineStyle) As Long
  If ActiveSheet.ProtectDrawingObjects Then Exit Function
  On Error Resume Next
  ActiveSheet.ChartObjects("_DialogPatterns").Delete
  On Error GoTo 0
  If Weight = 0 Then Weight = xlHairline
  If LineStyle = 0 Then LineStyle = xlContinuous
  With ActiveSheet.ChartObjects.Add(0, 0, 1, 1).Chart
    .Parent.Name = "_DialogPatterns"
    .Location Where:=xlLocationAsObject, Name:=ActiveSheet.Name
    .ChartType = xlColumnClustered
    .SeriesCollection.NewSeries
    .SeriesCollection(1).Formula = "=SERIES(,,{1},)"
    .Axes(xlValue).HasMajorGridlines = True
    .Axes(xlValue).MajorGridlines.Select
    With Selection.Border
      .Color = Color   'vbRed '.ColorIndex = 3 '赤
      .Weight = Weight 'xlHairline
      .LineStyle = LineStyle 'xlContinuous
    End With
    Call SetTimer(0&, 0&, 0&, AddressOf pCloudPatternsProc)
    kDialogLine = IIf(Application.Dialogs(xlDialogPatterns).Show, vbOK, vbCancel)
    If kDialogLine = vbOK Then
      With .Axes(xlValue).MajorGridlines.Border
        If .LineStyle <> xlAutomatic Then Color = .Color
        Weight = .Weight
        LineStyle = .LineStyle
      End With
    End If
    .Parent.Delete
  End With
End Function
Private Sub pCloudPatternsProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTimer As Long)
  Dim wnd As Long
  On Error Resume Next
  KillTimer 0&, idEvent
  wnd = FindWindow("bosa_sdm_XL" & Val(Application.Version), "目盛線の書式設定")
  If wnd = 0 Then wnd = FindWindow(vbNullString, "目盛線の書式設定")
  If wnd = 0 Then wnd = FindWindow("bosa_sdm_XL" & Val(Application.Version), vbNullString)
  If wnd = 0 Then Exit Sub
  SetWindowLong wnd, GWL_EXSTYLE, GetWindowLong(wnd, GWL_EXSTYLE) And Not WS_EX_CONTEXTHELP
  SetWindowText wnd, "線の書式設定"
End Sub

'kDialogLine関数のテスト
Sub test_kDialogLine()
  Dim Color As Long, Weight As XlBorderWeight, LineStyle As XlLineStyle, rt As Long
  '値代入
  Color = vbRed '赤
  'Color = ActiveWorkbook.Colors(3) 'ColorIndexプロパティの値で与える場合
  Weight = xlHairline
  LineStyle = xlContinuous
  'kDialogLine関数の呼び出し
  rt = kDialogLine(Color, Weight, LineStyle)
  '結果表示
  If rt = vbOK Then '設定された
    Debug.Print "Color="; Color, "Weight="; Weight, "LineStyle="; LineStyle
  ElseIf rt = vbCancel Then
    Debug.Print "キャンセルされました"
  Else 'rt = 0
    Debug.Print "error：アクティブシートは描画オブジェクトが保護されています"
  End If
End Sub

項目

セルの列幅をポイント或いはmm単位で設定する

内容説明

ワークシートのセル幅をポイント或いはmm単位で設定する方法です。
セルの高さや幅のプロパティは次のものがあります。

RowHeight プロパティ　　行高さを取得および設定します。(ポイント単位)
ColumnWidth プロパティ　列幅を取得および設定します。(文字数単位)単位は標準スタイルの1文字分の幅に相当
Height プロパティ　　　 行高さを取得します。設定は不可。(ポイント単位)
Width プロパティ　　　　列幅を取得します。設定は不可。(ポイント単位)

セルの行高さについては、RowHeightプロパティにてポイント或いはmm単位で設定出来ます。(1mm=2.85ポイント)
但し、セルの列幅に付いてはColumnWidthプロパティで設定する事になりますがポイント単位を文字数単位に変換する必要があります。

注）ポイントの最小単位について
Height及びWidthプロパティの最小単位は0.75ポイントです。
RowHeightプロパティやkColumnWidth関数の列幅には0.75の倍数を与える必要があります。倍数でない場合は自動的に0.75の倍数に調整されます。

'標準モジュール
Option Explicit
Option Private Module

'kColumnWidth関数
'セルの列幅をポイント単位から文字幅単位に変換します
'引数 Point:列幅(ポイント単位) 注)0.75の倍数で与える
Function kColumnWidthPo(Point As Double) As Double
  Const MG = 3.75 '補正値
  kColumnWidthPo = (Point - MG) * Cells(1).ColumnWidth / (Cells(1).Width - MG)
End Function

'(参考)pColumnWidthMargin関数 列幅のマージン(補正値)取得
Private Function pColumnWidthMargin() As Double
  Dim w1#, w2#, cw#
  With Cells(1)
    cw = .ColumnWidth
    .ColumnWidth = 5: w1 = .Width
    .ColumnWidth = 10: w2 = .Width
    .ColumnWidth = cw
  End With
  pColumnWidthMargin = w1 * 2 - w2 '3.75
End Function

'kColumnWidthMilli関数
'セルの列幅をmm単位から文字幅単位に変換します
'引数 mm:設定する列幅(mm)
Function kColumnWidthMilli(mm As Double) As Double
  kColumnWidthMilli = kColumnWidthPo(Application.CentimetersToPoints(mm / 10))
End Function

'kColumnWidth関数のテスト
Sub test1_kColumnWidthPo()
  Selection.ColumnWidth = kColumnWidthPo(75)
End Sub
Sub test2_kColumnWidthPo()
  Range("b3:d3").ColumnWidth = kColumnWidthPo(27)
End Sub

'kColumnWidthMilli関数のテスト
Sub test1_kColumnWidthMilli()
  Selection.ColumnWidth = kColumnWidthMilli(20)
End Sub
Sub test2_kColumnWidthMilli()
  Range("b3:d5").ColumnWidth = kColumnWidthMilli(15)
End Sub

追記：印刷時の補正について
エクセルの印刷精度は曖昧でCADの出力のように厳密には行きません。
印刷した結果として幅と高さを正確に出力するには以下のように設定する長さを補正します。
1. 精度はプリンタードライバーに依存するので実際に印刷して高さ・幅を実測します。
2. 設定したい長さが50mmとして実測値が45.5mmの場合 50*50/45.5 の値を長さとして与えます。

エクセル入力支援[k蘭]

項目

アクティブにしないで指定したセルへ図を挿入する

内容説明

画像ファイルを指定セルの位置へ挿入する場合、以下に示すコードのようにブックをActivateにし、シートをSelectし、セルをSelectしてInsertとなります。
まさにマクロの記録そのもののコードです。

  Workbooks("Book1.xls").Activate
  Sheets("Sheet2").Select
  Range("B2").Select
  ActiveSheet.Pictures.Insert "c:\ddd\eee\fff.jpg"

そこで、一切アクティブやセレクトしないで画像ファイルを指定セルへ挿入するkPicturesInsert関数を示します。
kPicturesInsert関数を用いればアドインや非表示ファイルへの画像挿入も可能となります。

'アクティブにしないで指定したセルへ図をファイルから挿入する
'引数 file     : 挿入する画像ファイル(フルファイル名)
'　　 reference: 挿入先を指定(Rangeオブジェクト)
'戻り値: 貼り付けたオブジェクト
Function kPicturesInsert(ByVal file As String, ByVal reference As Range) As ShapeRange
  On Error Resume Next
  Set kPicturesInsert = reference.Parent.Pictures.Insert(file).ShapeRange
  With kPicturesInsert
    .Top = reference.Top
    .Left = reference.Left
  End With
End Function

'kPicturesInsert関数のテスト
Sub test_kPicturesInsert()
  Dim reference As Range, file$, sr As ShapeRange
  file = "c:\ddd\eee\fff.png"
  Set reference = Workbooks("Book1.xls").Sheets("Sheet2").Range("c3")
  Set sr = kPicturesInsert(file, reference)
  If sr Is Nothing Then MsgBox "エラー"
End Sub

追記1：クリップボードの画像を貼り付ける
アクティブにしないでクリップボードの画像を貼り付けるkPicturesPaste関数です。
アドインや非表示ファイルへの画像貼り付けも可能です。

'アクティブにしないで指定したセルへクリップボードの図を貼り付ける
'引数 reference:貼り付け先を指定(Rangeオブジェクト)
'戻り値: 貼り付けたオブジェクト
Function kPicturesPaste(ByVal reference As Range) As ShapeRange
  On Error Resume Next
  Set kPicturesPaste = reference.Parent.Pictures.Paste.ShapeRange
  With kPicturesPaste
    .Top = reference.Top
    .Left = reference.Left
  End With
End Function

'kPicturesPaste関数のテスト
Sub test_kPicturesPaste()
  Dim reference As Range, sr As ShapeRange
  Set reference = Workbooks("Book1.xls").Sheets("Sheet2").Range("d4")
  Set sr = kPicturesPaste(reference)
  If sr Is Nothing Then MsgBox "エラー"
End Sub

追記2：クリップボードの画像を形式を選択して貼り付ける
アクティブにしないでクリップボードの画像を形式を選択して貼り付けるkPicturesPasteSpecial関数です。
アドインや非表示ファイルへの画像貼り付けも可能です。

'モジュールレベル
Option Explicit
Public Enum ePicFormat
  ePNG  '"図 (PNG)"
  eJPEG '"図 (JPEG)"
  eGIF  '"図 (GIF)"
  eEMF  '"図 (拡張メタファイル)"
  eDRW  '"MS Office 描画オブジェクト"
End Enum

'アクティブにしないで指定したセルへクリップボードの図を形式を選択して貼り付ける
'引数 reference:貼り付け先を指定(Rangeオブジェクト)
'     Format   :0="図 (PNG)" 1="図 (JPEG)" 2="図 (GIF)" 3="図 (拡張メタファイル)" 4="MS Office 描画オブジェクト"
'戻り値: 貼り付けたオブジェクト
Function kPicturesPasteSpecial(ByVal reference As Range, Optional ByVal Format As ePicFormat = eJPEG) As ShapeRange
  On Error Resume Next
  ActiveSheet.PasteSpecial Format:=Array _
    ("図 (PNG)", "図 (JPEG)", "図 (GIF)", "図 (拡張メタファイル)", "MS Office 描画オブジェクト")(Format)
  If Err = 0 Then
    Selection.Cut
    Set kPicturesPasteSpecial = reference.Parent.Pictures.Paste.ShapeRange
    With kPicturesPasteSpecial
      .Top = reference.Top
      .Left = reference.Left
    End With
  End If
End Function

'kPicturesPasteSpecial関数のテスト
Sub test_kPicturesPasteSpecial()
  Dim reference As Range, sr As ShapeRange
  Set reference = Workbooks("Book2.xls").Sheets("Sheet2").Range("b2")
  Set sr = kPicturesPasteSpecial(reference, eEMF)
  If sr Is Nothing Then MsgBox "エラー"
End Sub

項目

長整数値(Long)を下位・上位ワード(Integer)に分ける

内容説明

長整数値(Long)を下位・上位ワード(Integer)に分ける関数です。
C言語でいうところのHIWORD関数、LOWORD関数及びMAKELONG関数です。

'kLoWord,kHiWord,kMakeLong関数のテスト
Sub test_HiLoWord()
  Dim lparam&, hi%, lo%
  lparam = &HA001B002
  hi = kHiWord(lparam)
  lo = kLoWord(lparam)
  Debug.Print Hex(lparam), Hex(hi), Hex(lo), Hex(kMakeLong(lo, hi))
End Sub
  
'長整数値(Long)を下位・上位ワード(Integer)に分ける
'引数 dw:長整数値(Long)
'戻り値　下位ワード(Integer)
Function kLoWord(ByVal dw As Long) As Integer
  kLoWord = (dw And &HFFFF&) - IIf(dw And &H8000&, &H10000, 0)
End Function

'引数 dw:長整数値(Long)
'戻り値　上位ワード(Integer)
Function kHiWord(ByVal dw As Long) As Integer
  kHiWord = (dw And &HFFFF0000) \ &H10000
End Function

'下位・上位ワードを与えて長整数値を取得する
'引数 LoWord :下位ワード(Integer)
'     HiWord:上位ワード(Integer)
'戻り値 作成された長整数値(Long)
Function kMakeLong(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
  kMakeLong = (LoWord And &HFFFF&) Or (HiWord * &H10000)
End Function

項目

隠しシートを表示出来ないようにする

内容説明

シートを非表示にするにはご存知のように[書式]-[シート]-[表示しない]と操作します。
(ActiveWindow.SelectedSheets.Visible = False)
表示は[書式]-[シート]-[再表示]のリストからシートを選択します。
Sheets("Sheet1").Visible = True

[再表示]のリストに表示されない非表示のシートにするには、
Sheets("Sheet1").Visible = xlVeryHidden
と、VisibleプロパティにxlVeryHiddenを指定します。
手操作
VBEにてプロジェクトエクスプローラにて対象オブジェクト(シート)を選択しプロパティウィンドウのVisibleプロパティを(-1)xlSheetVisibleにする事で表示出来ます。
但し、プロジェクトの保護がされている場合はプロパティ操作は出来ません。

さらに強固に隠しシートを表示出来ないようにするには、VisibleプロパティにxlVeryHidden(又はxlSheetHidden)を設定後、
[ツール]-[保護]-[ブックの保護]で[シート構成]をチェックしパスワードを設定します。
ActiveWorkbook.Protect Password:="ppp", Structure:=True
これでプロテクトを解除しない限り隠しシートを表示する事は出来ません。

項目

シート見出しを表示しない

内容説明

シート見出しを表示しない画面構成にしたい場合、どのようにしていますか？
ご存知のように[ツール]-[オプション]-[表示]タブ-[シート見出し]のチェックを外すで実現できます。
ActiveWindow.DisplayWorkbookTabs = False
しかし、ユーザーに[表示]タブ-[シート見出し]をチェックされて非表示を解除されてしまいます。

そこで、あまり知られていないシート見出しを非表示にする方法です。(遊び技)

1. シート見出し領域と水平スクロールバー領域の境をマウスポイントすると[左右矢印ポインタ]になります。
2. この状態でクリックし左端までドラッグします。
   ActiveWindow.TabRatio = 0
3. シート見出し領域が隠れて非表示になります。
4. [ツール]-[オプション]-[表示]タブ-[シート見出し]のチェックを外します。
5. この状態で保存します。

TabRatioプロパティの値はブックに保存されますので、次にファイルを開いてもシート見出しは非表示のままです。
方法を知らないと解除する事は出来ません。

項目

流れる文字及び点滅文字

内容説明

エクセルVBAで 流れる文字 や 点滅文字 を実装しようとするとタイマーを用いる等の常時監視の手法となり結構大変な事になります。
そこで、WebBrowserコントロールにてHTMLタグのマーキーを用いて簡単に
流れる文字
や
点滅文字
を実装する方法を示します。

その1 シートでの流れる文字及び点滅文字
ワークシートに動的にWebBrowserコントロールを作成・削除しています。そのため対象シートのブックではプロジェクトのリセットが掛かります。
ThisWorkbookのWorkSheetで実行する場合は変数が初期化されますのでご注意下さい。

'標準モジュール
Option Explicit
Option Private Module
Const dMARQUEE = "_BrowserMarquee"
Const dBLINK = "_BrowserBlink"

'流れる文字のテスト
Sub test_kBrowserMarqueeAdd() '横に流れる
  kBrowserMarqueeAdd dMARQUEE, ActiveSheet.Range("b2:d2"), "流れる文字！！　流れる文字！！", "Maroon"
End Sub
Sub test2_kBrowserMarqueeAdd() '縦に流れる
  kBrowserMarqueeAdd dMARQUEE, ActiveSheet.Range("b2:c5"), "流れる文字！！<br>縦に流れる" <p>こんにちは", up:=True
End Sub

'流れる文字削除のテスト
Sub test_kBrowserMarqueeDelete()
  kBrowserMarqueeDelete dMARQUEE
End Sub

'点滅文字のテスト
Sub test_kBrowserBlinkAdd()
  kBrowserBlinkAdd dBLINK, ActiveSheet.Range("b4"), "点滅", "Teal"
End Sub
'点滅文字削除のテスト
Sub test_kBrowserBlinkDelete()
  kBrowserBlinkDelete dBLINK
End Sub

'シートに流れる文字を表示(WebBrowserを作成して表示)
'Name :作成するWebBrowserの名前(任意のユニークな名前)
'rg   :流れる文字を表示するセル範囲
'msg  :流れる文字
'Color:FONTタグのCOLOR属性 Black Gray Silver White Red Yellow Lime Aqua Blue Fuchsia Maroon Olive Green Teal Navy Purple等
'bold :True=太字
'up   :True=縦に流れる 省略値=横に流れる
Function kBrowserMarqueeAdd(ByVal Name As String, ByVal rg As Range, ByVal msg As String, Optional ByVal Color As String = "Black", Optional ByVal bold As Boolean, Optional ByVal up As Boolean) As Long
  Dim ep As OLEObject
  kBrowserMarqueeDelete Name
  On Error Resume Next
  Set ep = ActiveSheet.OLEObjects.Add(ClassType:="Shell.Explorer.2")
  If Err Then kBrowserMarqueeAdd = Err: Exit Function
  On Error GoTo 0
  With ep
    .Name = Name
    .Left = rg.Left: .Top = rg.Top: .Width = rg.Width + 2: .Height = rg.Height + 2
    .Object.Navigate "about:blank"
    .Object.Navigate "javascript:document.write('<body topmargin=1 scroll=no ><Marquee scrolldelay=180 " & IIf(up, "direction=up height=" & .Height / 0.75, "") & "><font color=" & Color & " >" & IIf(bold, "<b>", "") & msg & "</Marquee>');"
  End With
  '再描画のお呪い(表示内容を更新)
  ActiveSheet.Select: Application.ScreenUpdating = True
End Function

'流れる文字を削除
Function kBrowserMarqueeDelete(Name As String) As Long
  If IsObject(Evaluate(Name)) Then _
    ActiveSheet.OLEObjects(Name).Delete
End Function

'シートに点滅文字を表示(WebBrowserを作成して表示)
'Name  :作成するWebBrowserの名前(任意のユニークな名前)
'rg    :点滅文字を表示するセル範囲
'msg   :点滅文字
'Color :FONTタグのCOLOR属性 Black Gray Silver White Red Yellow Lime Aqua Blue Fuchsia Maroon Olive Green Teal Navy Purple等
'center:True=文字配置を中央
'adjust:文字数に応じた調整値
Function kBrowserBlinkAdd(ByVal Name As String, ByVal rg As Range, ByVal msg As String, Optional Color As String = "Black", Optional center As Boolean = True, Optional ByVal adjust As Long) As Long
  Dim ep As OLEObject, amount&
  If adjust = 0 Then adjust = LenB(StrConv(msg, vbFromUnicode)) * 10
  kBrowserBlinkDelete Name
  On Error Resume Next
  Set ep = ActiveSheet.OLEObjects.Add(ClassType:="Shell.Explorer.2")
  If Err Then kBrowserBlinkAdd = Err: Exit Function
  On Error GoTo 0
  With ep
    .Name = dBLINK
    .Left = rg.Left: .Top = rg.Top: .Width = rg.Width + 2: .Height = rg.Height + 2
    amount = .Height / 0.75
    .Object.Navigate "about:blank"
    .Object.Navigate "javascript:document.write('<body topmargin=1 leftmargin=1 rightmargin=0 scroll=no>" & IIf(center, "<center>", "") & "<marquee direction=up scrollamount=" & amount & " height=" & amount & IIf(adjust, " width=" & adjust, "") & " scrolldelay=1000><font color=" & Color & ">" & msg & "</marquee>');"
  End With
  '再描画のお呪い(表示内容を更新)
  ActiveSheet.Select: Application.ScreenUpdating = True
End Function

'点滅文字を削除
Function kBrowserBlinkDelete(Name As String) As Long
  If IsObject(Evaluate(Name)) Then _
    ActiveSheet.OLEObjects(Name).Delete
End Function

その2 ユーザーフォームでの流れる文字及び点滅文字
準備としてユーザーフォームに[その他のコントロール]-[Microsoft WebBrowser]よりWebBrowser1とWebBrowser2を配置。
各WebBrowserのHeightプロパティは20程度に設定。

'UserFormモジュール
Option Explicit

Private Sub UserForm_Initialize()
  kBrowserMarqueeOn WebBrowser1, "流れる文字！！　流れる文字！！", "Maroon"
  'kBrowserMarqueeOn WebBrowser1, "流れる文字！！<br>縦に流れる<p>こんにちは", , ,True
  kBrowserBlinkOn WebBrowser2, "点滅", "Teal"
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
  pDisp.Document.Body.scroll = "no"
End Sub

Private Sub WebBrowser2_DocumentComplete(ByVal pDisp As Object, URL As Variant)
  pDisp.Document.Body.scroll = "no"
End Sub

'標準モジュール又はUserFormモジュール
Option Explicit
Option Private Module '←標準モジュールの場合

'ユーザーフォームのWebBrowserに流れる文字を表示
'brow :WebBrowser 注:Heightプロパティは20程度に設定の事
'msg  :流れる文字
'Color:FONTタグのCOLOR属性 Black Gray Silver White Red Yellow Lime Aqua Blue Fuchsia Maroon Olive Green Teal Navy Purple等
'bold :True=太字
'up   :True=縦に流れる 省略値=横に流れる
Function kBrowserMarqueeOn(ByVal brow As WebBrowser, ByVal msg As String, Optional ByVal Color As String = "Black", Optional ByVal bold As Boolean, Optional ByVal up As Boolean) As Long
  brow.Navigate "about:blank"
  brow.Navigate "javascript:document.write('<body topmargin=5 scroll=no><Marquee scrolldelay=180  " & IIf(up, "direction=up height=" & brow.Height, "") & "><font color=" & Color & ">" & IIf(bold, "<b>", "") & msg & "</Marquee>');"
End Function

'流れる文字の表示を停止
'brow  :WebBrowser
Function kBrowserMarqueeOff(ByVal brow As WebBrowser)
  brow.Navigate "about:blank"
End Function

'ユーザーフォームのWebBrowserに点滅文字を表示
'brow  :WebBrowser 注:Heightプロパティは20程度に設定の事
'msg   :点滅文字
'Color :FONTタグのCOLOR属性 Black Gray Silver White Red Yellow Lime Aqua Blue Fuchsia Maroon Olive Green Teal Navy Purple等
'center:True=文字配置を中央
'adjust:文字数に応じた調整値
Function kBrowserBlinkOn(ByVal brow As WebBrowser, ByVal msg As String, Optional ByVal Color As String = "Black", Optional center As Boolean = True, Optional ByVal adjust As Long) As Long
  If adjust = 0 Then adjust = LenB(StrConv(msg, vbFromUnicode)) * 10
  brow.Navigate "about:blank"
  brow.Object.Navigate "javascript:document.write('<body topmargin=5 scroll=no>" & IIf(center, "<center>", "") & "<marquee direction=up scrollamount=" & brow.Height & " height=" & brow.Height & IIf(adjust, " width=" & adjust, "") & " scrolldelay=1000><font color=" & Color & ">" & msg & "</marquee>');"
End Function

'点滅文字の表示を停止
'brow  :WebBrowser
Function kBrowserBlinkOff(ByVal brow As WebBrowser)
  brow.Navigate "about:blank"
End Function

項目

切り取り又はコピーされたセル範囲を取得する

内容説明

切り取り又はコピーモード時(枠線点滅の状態)の範囲を取得するkGetRangeCopyCut関数を示します。
セルを切り取り又はコピーした場合に選択範囲の枠線が点滅状態になります。この状態で他のセルに移動すると点滅状態のセル範囲はもはや取得できません。
API関数にてクリップボードからコピーされているデータ情報を取得します。
枠線点滅の状態が取得出来ると[形式を選択して貼り付け]に含まれていない特殊な貼り付け機能等を実装する事が可能になります。

'標準モジュール
Option Explicit
Option Private Module
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" _
  (ByVal lpString As String) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

'kGetRangeCopyCut関数
'切り取り又はコピーモード時(枠線点滅の状態)の範囲を取得する
'注:複数エリアを切り取り又はコピーした場合は連続した1エリアとして処理されます。(Excelの仕様)
Function kGetRangeCopyCut() As Range
  Dim mem&, sz&, lk&, vv As Variant, buf$
  If Application.CutCopyMode = False Then Exit Function
  OpenClipboard 0&
  mem = GetClipboardData(RegisterClipboardFormat("Link"))
  CloseClipboard
  If mem = 0 Then Exit Function
  sz = GlobalSize(mem)
  lk = GlobalLock(mem)
  buf = String(sz, vbNullChar)
  CopyMemory ByVal buf, ByVal lk, sz
  GlobalUnlock mem
  vv = Split(buf, vbNullChar)
  buf = "'" & vv(1) & "'!" & Application.ConvertFormula(vv(2), xlR1C1, xlA1)
  Set kGetRangeCopyCut = Range(buf)
End Function

コマンド例：
kGetRangeCopyCut関数を用いたコマンドです。
簡単な応用として、コピーされた範囲をアクティブセルへ特殊仕様で貼り付ける例を3つ示します。
セル範囲をコピーし、貼り付け先の左上セルを選択してマクロを実行します。(通常の[コピー]-[貼り付け]と同じインターフェイスです)

'kAllCopyPaste関数　全てコピー
'コピーされた範囲をセルの幅・高さを含めてアクティブセル位置へ貼り付け
Sub kAllCopyPaste()
  Dim sou As Range, des As Range, ii&
  If Application.CutCopyMode <> xlCopy Then Beep: Exit Sub
  Set sou = kGetRangeCopyCut
  If sou Is Nothing Then Beep: Exit Sub
  Set des = ActiveCell.Resize(sou.Rows.Count, sou.Columns.Count)
  If sou.Address(External:=True) = des.Address(External:=True) Then Beep: Exit Sub
  sou.Copy des
  For ii = 1 To sou.Count
    If sou(ii).ColumnWidth <> des(ii).ColumnWidth Then des(ii).ColumnWidth = sou(ii).ColumnWidth
    If sou(ii).RowHeight <> des(ii).RowHeight Then des(ii).RowHeight = sou(ii).RowHeight
  Next
End Sub

'kBorderCopyPaste関数　罫線コピー
'コピーされた範囲の罫線のみをアクティブセル位置へ貼り付け
Sub kBorderCopyPaste()
  Dim sou As Range, des As Range
  If Application.CutCopyMode <> xlCopy Then Beep: Exit Sub
  Set sou = kGetRangeCopyCut
  If sou Is Nothing Then Beep: Exit Sub
  Set des = ActiveCell.Resize(sou.Rows.Count, sou.Columns.Count)
  If sou.Address(External:=True) = des.Address(External:=True) Then Beep: Exit Sub
  With Sheets.Add
    .Range("a1").PasteSpecial Paste:=xlPasteFormats
    With Selection
      des.Copy
      .PasteSpecial Paste:=xlPasteAllExceptBorders
      .Copy des
    End With
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
  sou.Copy
End Sub

'kSwapCellsPaste関数　セルの交換
'コピー又は切り取りされた範囲をアクティブセル位置の範囲と交換
'仕様: 値(数式)のみ交換、書式は交換しない
'　　　数式はコピーした場合R1C1形式(相対位置)、切り取りした場合A1形式(絶対位置)で交換
Sub kSwapCellsPaste()
  Dim sou As Range, des As Range, ii&, vs As Variant, vd As Variant
  If Application.CutCopyMode = False Then Beep: Exit Sub
  Set sou = kGetRangeCopyCut
  If sou Is Nothing Then Beep: Exit Sub
  Set des = ActiveCell.Resize(sou.Rows.Count, sou.Columns.Count)
  If sou.Address(External:=True) = des.Address(External:=True) Then Beep: Exit Sub
  For ii = 1 To sou.Count
    vs = IIf(sou(ii).HasFormula, IIf(Application.CutCopyMode = xlCopy, sou(ii).FormulaR1C1, sou(ii).Formula), sou(ii).Value)
    vd = IIf(des(ii).HasFormula, IIf(Application.CutCopyMode = xlCopy, des(ii).FormulaR1C1, des(ii).Formula), des(ii).Value)
    sou(ii) = vd
    des(ii) = vs
  Next
End Sub

サンプル：
kGetRangeCopyCut関数を用いたアドインです。
セルの右クリックショートカットメニューに拡張貼り付けのコマンドを設定しています
拡張貼り付け [kExtensionPaste]　Version 1.02
kExtensionPaste.xla(ソース公開)のダウンロード