Public Type UserRevision
Name As String
Revision As String
End Type
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub auto_open()
' F1キーを殺す
Application.OnKey "{F1}", ""
'キー コード
'Shift +
'Ctrl ^
'Alt %
Application.OnKey "^+c", "CleanCopy"
Application.OnKey "^+v", "PasteValue"
End Sub
' コピー時、末尾にLFがつくのを防ぐ
Sub CleanCopy()
Application.StatusBar = "copied."
' 全ての選択されたセル値をCRLFで結合
Dim val As String
For i = 1 To Selection.Count
If (Len(val) > 0) Then
val = val & vbCrLf
End If
val = val & Selection(i).Value
Next
' 文字列の末尾からすべての改行コードを除く
val = TrimEndNewLine(val)
' クリップボードへ送る
Call Copy_ClipBoard(val)
' Dim cb As New DataObject
' cb.SetText val
' cb.PutInClipboard
' 少し待機してからステータスバーをクリアする
For resonance = 0 To 100
Sleep 10
DoEvents
resonance = resonance + 1
Next
Application.StatusBar = ""
End Sub
Private Sub Copy_ClipBoard(cpy_txt As String)
If True Then
With CreateObject("Forms.TextBox.1")
.MultiLine = True
.Text = cpy_txt
.SelStart = 0
.SelLength = .TextLength
.Copy
End With
Else
Dim CB As New DataObject
With CB
.SetText cpy_txt ''変数のデータをDataObjectに格納する
.PutInClipboard ''DataObjectのデータをクリップボードに格納する
End With
End If
End Sub
' 文字列の末尾からすべての改行コードを除く
Function TrimEndNewLine(文字列 As String) As String
Dim strTmp As String
strTmp = 文字列
Do Until Right(strTmp, 2) <> vbCrLf
strTmp = Left(strTmp, Len(strTmp) - 2)
Loop
Do Until Right(strTmp, 1) <> vbLf
strTmp = Left(strTmp, Len(strTmp) - 1)
Loop
Do Until Right(strTmp, 1) <> vbCr
strTmp = Left(strTmp, Len(strTmp) - 1)
Loop
TrimEndNewLine = strTmp
End Function
' 貼り付け時、結合セル対するエラーを防止する
Sub PasteValue()
Application.StatusBar = "PasteValue"
Dim CB As New DataObject
Dim sel As Range
Set sel = Selection
If Application.CutCopyMode Then
sel.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
Else
' ペーストの起点を決定
Dim st As Range ' ペースト起点
Set st = sel.Range("A1")
' クリップボードからデータ取得
Dim c_rows As Variant
CB.GetFromClipboard
c_rows = Split(CB.GetText, vbCrLf)
' 処理中の行/列番号
Dim i_row As Integer
i_row = st.Row
Dim i_col As Integer
i_col = st.Column
' ペースト処理
For i = LBound(c_rows) To UBound(c_rows)
Dim c_cols As Variant
c_cols = Split(c_rows(i), vbTab)
For j = LBound(c_cols) To UBound(c_cols)
Dim cell As Range
Set cell = Cells(i_row, i_col)
With cell
.Value = c_cols(j)
i_col = i_col + .MergeArea.Columns.Count
End With
Next j
' 改行
i_col = st.Column
i_row = i_row + Cells(i_row, i_col).MergeArea.Rows.Count
Next i
End If
Application.StatusBar = ""
End Sub
Private Function CONCATENATE2(rTarget As Range, Optional prefix As String = "", Optional suffix As String = "")
Dim sWork As String: sWork = ""
Dim rCell As Range
For Each rCell In rTarget
sWork = sWork + prefix + CStr(rCell.Value) + suffix
Next
CONCATENATE2 = sWork
End Function
Sub SetRedShapeAsDefault()
Set targetSheet = ActiveSheet
' 適当な四角形を描いて「既定の図形に設定」した後消す
' 塗りつぶし=なし
' 線色=赤
' 太さ=2.25
With targetSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=1, Top:=1, Width:=100, Height:=100)
.Fill.Visible = False
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 2.25
.SetShapesDefaultProperties
.Delete
End With
' 適当な線を描いて「既定の線に設定」した後消す
' 線色=赤
' 太さ=3.0
With targetSheet.Shapes.AddLine(BeginX:=1, BeginY:=1, EndX:=100, EndY:=100)
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 3
.SetShapesDefaultProperties
.Delete
End With
End Sub