[[20170116012224]]　『ｍｏｍｏさんのツールをいじってみました』（マリオ）　ページの最後に飛ぶ

『ｍｏｍｏさんのツールをいじってみました』（マリオ）

エクセルの学校で、ｍｏｍｏさんの「SheetlayoutToClipBord」
大変重宝して使わせてもらっています。
今回クリップボードではなくて、テキストに書き込むバージョンの「Sheetlayout_To_Text」を作ってみました。

[[20110209184943]]

 『[談]シートレイアウトの投稿どうしてますか？』（ｍｏｍｏ）
 ごく最近、Windows8.1からWindows10にバージョンアップしたのですが、
 クリップボードに文字を貼り付けられなくなってました。エクセルはExcel2013を使用してます。
 Debug.Print Join(AryTxt, vbCrLf)は表示されるのになぜ？
 '****************************************
  With GetObject("new:" & DataObjectID)
      .SetText Join(AryTxt, vbCrLf)
      .PutInClipboard
  End With
 '****************************************
 の部分で、クリップボードにうまく貼り付いていないみたいです。
 貼り付けても「??」の文字が貼り付くのみでした。
 ★Windows10で、クリップボードに文字を貼り付けるやりかた、分かる方がおられましたら、
 ご教授願います。「SetText」と「PutInClipboard」は使えないみたいです？？

 VBのScript（txtに文字を書き込んだ後、拡張子をvbsに変えて実行できるScript）では、
 '**************************************************************
 Dim cmd , str
 cmd = "cmd.exe /c ""echo あいうえお| clip"""
 CreateObject("WScript.Shell").Run cmd, 0, False
 '**************************************************************
 で、コマンドプロンプトを経由して、クリップボードに、「あいうえお」を書き込めました。
 知識不足で、断念しました。

 過去にβさんも同じようなことを言っていました。
[[20160326092004]]
 『xl2013 での　ｍｏｍｏさんのレイアウトアップユーティリティ』（β）

 そこで、クリップボードは、あきらめて
 テキストファイルに、Excelのシートレイアウトを書き込んで
 デスクトップに出力するように、ｍｏｍｏさんのコードをいじってみました。

 '・
 '・
 '・
 '・
 '↓コードは、ココから 
 '*******************************************************************************
  '=====================================================
  ' 投稿用シートレイアウトをtxtファイルに記述
  ' 　　　　　　　　　　　　      　作成者（マリオ）
  '
  ' デスクトップに「txtファイルを作成」
  '=====================================================

 Option Explicit

 Sub Sheetlayout_To_Text()
 '★区切り文字
  Const BrkStr As String = "|"
  'Const BrkStr As String = "  "
  Cells.Columns.AutoFit

 '--------- セル範囲を選択する ----------------------------------------------------
  Dim myRng As Range, rngFormula As Range, rngBuf As Range, msg As String
  Dim tbl() As Variant, AryTxt() As String, StrBuf As String
  Dim i As Long, j As Long, AryWidth() As Long, LenBuf As Long, flag_num As Integer
      flag_num = 0
     '****************************************************
      On Error GoTo myError
         msg = "取得したい範囲を選択してください。"
         Set myRng = Application.InputBox(msg, Type:=8)
      On Error GoTo 0
     '****************************************************
      msg = "数式として表示したい範囲はありますか？"
  If MsgBox(msg, vbYesNo) = vbYes Then
    Do
     '****************************************************
      On Error GoTo myError
      msg = "数式として表示したい範囲を選択してください。"
      Set rngBuf = Application.InputBox(msg, Type:=8, Default:=myRng.Address)
      On Error GoTo 0
     '****************************************************
      If rngFormula Is Nothing Then
        Set rngFormula = rngBuf
      Else
        Set rngFormula = Application.Union(rngFormula, rngBuf)
      End If
      Set rngBuf = Nothing
      msg = "さらに数式として表示したい範囲がありますか？"
    Loop While MsgBox(msg, vbYesNo) = vbYes
  End If
 '------------------------------------------------------------------------

 '------------ 文字列操作 -----------------------------------------------------------------
  ReDim tbl(1 To myRng.Rows.Count, 1 To myRng.Columns.Count)
  ReDim AryWidth(1 To UBound(tbl, 2))
  For i = 1 To myRng.Rows.Count
    For j = 1 To myRng.Columns.Count
      tbl(i, j) = myRng.Cells(i, j).Text
      If Not rngFormula Is Nothing Then
        If Not Application.Intersect(myRng.Cells(i, j), rngFormula) Is Nothing Then
          tbl(i, j) = myRng.Cells(i, j).Formula
        End If
      End If
      LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
      If AryWidth(j) < LenBuf Then
        AryWidth(j) = LenBuf
      End If
    Next j
  Next i
  ReDim AryTxt(UBound(tbl, 1))
  AryTxt(0) = String(Len(myRng.Rows(myRng.Rows.Count).Row) + 3, " ")
  For i = 1 To UBound(tbl, 2)
    StrBuf = "[" & Split(myRng.Columns(i).EntireColumn.Address(False, False), ":")(0) & "]"
    If AryWidth(i) > Len(StrBuf) Then
      AryTxt(0) = AryTxt(0) & BrkStr & StrBuf & String(AryWidth(i) - Len(StrBuf), " ")
    Else
      AryTxt(0) = AryTxt(0) & BrkStr & StrBuf
      AryWidth(i) = Len(StrBuf)
    End If
  Next i
  For i = 1 To UBound(tbl, 1)
    AryTxt(i) = " [" & myRng.Rows(i).Row & "]" & _
                String(Len(myRng.Rows(myRng.Rows.Count).Row) - Len(myRng.Rows(i).Row), " ")
    For j = 1 To UBound(tbl, 2)
      LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
      If IsNumeric(tbl(i, j)) Then
        AryTxt(i) = AryTxt(i) & BrkStr & String(AryWidth(j) - LenBuf, " ") & tbl(i, j)
      Else
        AryTxt(i) = AryTxt(i) & BrkStr & tbl(i, j) & String(AryWidth(j) - LenBuf, " ")
      End If
    Next j
  Next i
 '----------------------------------------------------------------------------------------

 '------- Desktopにtxtファイルを作成して、テキストを書き込む ------
  Dim fname As String, fso, objTxtfil, objShells, Path
  Dim rc As Integer, msg2 As String
  fname = "Excel - Sheetlayout.txt" '★ファイル名
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set objShells = CreateObject("WScript.Shell")
  Path = objShells.SpecialFolders("Desktop") & "\" & fname

  If fso.FileExists(Path) = True Then
     msg = " 既に、同名ファイルが存在します"
     msg2 = "上書きしますか？" _
            & vbCr & vbCr & Path
     rc = MsgBox(msg2, vbOKCancel, msg)
     If rc = vbCancel Then
        GoTo myError
     Else
        flag_num = 2
     End If
  Else
        flag_num = 1
  End If

  Set objTxtfil = fso.CreateTextFile(Path, 2, True)
  objTxtfil.Write Join(AryTxt, vbCrLf)
  objTxtfil.Close
 '-----------------------------------------------------------------

 If flag_num = 2 Then
    msg = "上書きしました"
 ElseIf flag_num = 1 Then
    msg = "新規作成しました"
 End If
 rc = MsgBox(Path, vbOKOnly, msg)

myError:

  If flag_num = 0 Then
     MsgBox "何もせずに終了します"
  End If
  Set myRng = Nothing
  Set rngBuf = Nothing
  Set rngFormula = Nothing
  Set fso = Nothing
  Set objShells = Nothing
  Set objTxtfil = Nothing
 End Sub
 '*******************************************************************************
 '↑コードは、ココまで

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

 マリオさん

 ご健在のようで何よりです。

 いつかはＭＳが対応してくれるかなと思っていましたが、まだ同じ現象になるんですね。

 当方、[[20160326092004]]　でも触れましたけど、必要な時には Win7(xl2010)側で処理していたんですが、あまりにも面倒なので
 当該部分を　API 対応　したものに切り替えて使っています。

 ★ただし、私の場合、win8.1(xl2013) で、すでにだめでした。

 コードはネットで拾ったものなので、ここに掲載していいのかどうか、悩みますが、でも、ネットでも
 無断流用掲載はダメ　ということは書いてなかった（ような記憶）ので以下に書いておきます。

 (本来は URL を紹介すべきでしょうけど、どれだったかがわからなくなっていて・・）

 まず、ｍｏｍｏさんのコードの最後の部分、

  With GetObject("new:" & DataObjectID)
    .SetText Join(AryTxt, vbCrLf)
    .PutInClipboard
  End With

 これを

    CopyText Join(AryTxt, vbCrLf)

 に変更。

 で、別モジュールを挿入して、

 Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hData As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlag As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'本来はＣ言語用の文字列コピーだが、２つ目の引数をStringとしているので変換が行われた上でコピーされる。
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As String) As Long

 '定数宣言
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GHND As Long = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const CF_TEXT As Long = 1
Private Const CF_OEMTEXT As Long = 7

 Function CopyText(str As String) As Boolean
    Dim hGlobal As Long
    Dim length As Long
    Dim p As Long

    '戻り値をとりあえず、Falseに設定しておく。
    CopyText = False
    If OpenClipboard(0) <> 0 Then
        If EmptyClipboard() <> 0 Then
            '長さの算出(本来はUnicodeから変換後の長さを使うほうがよい)
            length = LenB(str) + 1
            'コピー先の領域確保
            hGlobal = GlobalAlloc(GHND, length)
            p = GlobalLock(hGlobal)
            '文字列をコピー
            Call lstrcpy(p, str)
            'クリップボードに渡すときにはUnlockしておく必要がある
            Call GlobalUnlock(hGlobal)
            'クリップボードへ貼り付ける
            Call SetClipboardData(CF_TEXT, hGlobal)
            'クリップボードをクローズ
            Call CloseClipboard
            'コピー成功
            CopyText = True
        End If
    End If
End Function

（β） 2017/01/16(月) 06:59

 >>βさん
 すごい、クリップボードに貼り付きました。
 コード、ありがとうございます。

（マリオ） 2017/01/21(月) 20:29

 最後のほうの、ｍｏｍｏさんのコードでいえば

  With GetObject("new:" & DataObjectID)
    .SetText Join(AryTxt, vbCrLf)
    .PutInClipboard
  End With

 マリオさんがまとめてくれている　Sheetlayout_To_ClipBoard　でいえば

  CopyText Join(AryTxt, vbCrLf)　と　別モジュールの組み合わせ　に加え

 以下のようなコードでもコピペができますね。

    With ActiveSheet.OLEObjects.Add("Forms.TextBox.1")
        With .Object
        .MultiLine = True
        .Value = Join(AryTxt, vbCrLf)
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
        End With
        .Delete
    End With

（β） 2017/02/13(月) 00:09

 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
 ファイルを置いておきます。
 ■シートレイアウト To Text_To ClipBord_02.xls 
http://d.kuku.lu/f4c13f676f
 ★アゲマシタ(2017/03/3 19:44)
 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
（マリオ） 2017/03/03(金) 19:47

コメント返信：

[ 一覧(最新更新順) ]

[[20170116012224]] 『ｍｏｍｏさんのツールをいじってみました』 （マリオ） ページの最後に飛ぶ

[[20170116012224]]　『ｍｏｍｏさんのツールをいじってみました』（マリオ）　ページの最後に飛ぶ