Option Explicit
' *******************************************************************************
' *
' * 画像をEXCELに貼り付ける
' *
' *******************************************************************************
Declare PtrSafe Function OpenClipboard Lib "user32" (Optional ByVal hWnd As Long = 0) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
Private Declare PtrSafe Function FlashWindowEx Lib "user32.dll" (pfwi As FLASHWINFO) As Long
' 64bit環境
Private Type FLASHWINFO
cbSize As LongPtr '構造体サイズ
hWnd As LongPtr 'フラッシュするウインドウのハンドル
dwFlags As Long 'フラッシュ状態フラグ
uCount As Long 'フラッシュ回数
dwTimeout As LongPtr 'フラッシュ速度(ミリ秒単位)
End Type
' フラッシュ状態フラグの種類
Const FLASHW_ALL As Long = &H3 'ウインドウキャプションとタスクバーをフラッシュ
Const FLASHW_CAPTION As Long = &H1 'ウインドウキャプションをフラッシュ
Const FLASHW_TRAY As Long = &H2 'タスクバーをフラッシュ
Const FLASHW_STOP As Long = 0 'フラッシュを停止
Const FLASHW_TIMER As Long = &H4 'FLASHW_STOPフラグが設定されるまでフラッシュ
Const FLASHW_TIMERNOFG As Long = &HC 'ウインドウが最前面になるまでフラッシュ
'---------+---------+---------+---------+---------+---------+---------+---------+
Public Const I_SHEET As String = "設定"
Public Const G_APLNAME As String = "OnTCap 1.2 "
Public G_Sh_Canvus As String
Public G_Sec As Integer
Public G_GapRow As Integer
Public G_Id As String
Public G_FontName As String
Public G_Fontsize As Double
Public G_CellRowHeight As Double
Public G_CellColWidth As Double
Public G_Test_Mode As String
Public G_Test_MaxCnt As Long
Public G_HlType As Long
Public G_HlColor As Long
Public G_Status As String
Public G_PrintSize As String
Public G_PrintOrient As String
' ### 基本情報定義 ###'
Public isLogging As Boolean ' キャプチャ収集状態なら True
Public G_WatchCnt As Long ' 監視回数
Public G_PasteCnt As Long ' 貼付回数
'
'---------+---------+---------+---------+---------+---------+---------+---------+
' ### 画面キャプチャ開始 ###'
Sub StartCapture()
Application.MacroOptions Macro:="StartCapture", ShortcutKey:="j"
Dim sMsg As String: sMsg = ""
'-----------------------------
' 初期処理
'-----------------------------
Application.OnKey "{ESC}", "StopCapture" ' Esc キーで停止できるようにしておく
isLogging = True ' キャプチャ取得状態を設定する
G_WatchCnt = 0: G_PasteCnt = 0
G_Status = "準備中"
Application.Caption = "準備中"
' 使用権原チェック
If EnvSecCheck() = False Then
Exit Sub
End If
' 設定シートの値取込
If IsSeteiCheck(I_SHEET) = False Then
Exit Sub
End If
' 描画シートフォーマット
Canvas_Format (G_Sh_Canvus)
' 画面キャプチャのクリップボードリセット
ClearClipboardImage
'2024.05.07 カーソルの初期処理
Range("A2").Select
Rows(2).Select
ActiveWindow.FreezePanes = True
'-----------------------------
' 主処理
'-----------------------------
' 画面キャプチャ開始
Application.Caption = "準備中"
Call ExeCaptute
End Sub
'
' ### 画面キャプチャ貼り付け処理 ###'
'---------+---------+---------+---------+---------+---------+---------+---------+
Sub ExeCaptute()
'2024.05.05
'On Error GoTo ErrHandler
Dim CB As Variant
Dim size As Double: size = 1
Dim height As Long
Dim cellHeight As Double
Dim sep As Integer
Dim i As Integer
Dim objShp
G_WatchCnt = G_WatchCnt + 1
If G_Test_Mode = "ON" And G_WatchCnt > G_Test_MaxCnt Then
isLogging = True
Call StopCapture
Exit Sub
End If
CB = Application.ClipboardFormats
Sleep G_Sec 'インターバル秒数
If Left(Application.Caption, 3) = "停止中" Then GoTo Quit
' 空判定
If CB(1) <> -1 Then
For i = 1 To UBound(CB) ' クリップボードの中身の分繰り返す
' 画像判定
If CB(i) = xlClipboardFormatBitmap Then
ActiveSheet.Paste
'CurCell.Offset(CurRow, CurCols-1).Value = "■"
Application.CutCopyMode = False ' 切り取り・コピーモードを解除
G_PasteCnt = G_PasteCnt + 1
On Error Resume Next ' 以下の計算幅エラー
Set objShp = ActiveSheet.Shapes(Selection.Name)
objShp.LockAspectRatio = msoTrue ' サイズ変更も元の比率保持
objShp.ScaleHeight size, msoTrue ' 画像サイスをSIZE倍する
' 画像の高さとセルの高さからActiveCellの移動幅を計算
height = objShp.height
cellHeight = ActiveCell.height
sep = height / cellHeight + G_GapRow
ActiveCell.Offset(sep, 0).Select
' 画面キャプチャのクリップボードリセット
ClearClipboardImage
'Else
' Debug.Print "判定 画像以外 " & i & " / " & UBound(CB) & _
' " クリップボードの形式 CB(" & i & ")=" & CB(i)
End If
Next i
End If
G_Status = "起動中"
If G_Test_Mode = "ON" Then
Application.Caption = G_Status & _
" 監視-貼付回：" & G_WatchCnt & "/" & G_Test_MaxCnt & _
" - " & G_PasteCnt & _
" CB数：" & UBound(CB) & " - " & CB(1)
Else
Application.Caption = G_Status & _
" 監視-貼付回：" & G_WatchCnt & "/" & "*" & _
" - " & G_PasteCnt & _
" CB数：" & UBound(CB) & " - " & CB(1)
End If
Call Set_FlushSheet(G_Sh_Canvus, G_WatchCnt)
' 制御をOSに移します。
DoEvents
' 次回実行予定時刻を設定（数秒ごとに実行）
If isLogging = True Then
Dim NextSec
NextSec = G_Sec / 1000 / 86400
Application.OnTime Now + NextSec, "ExeCaptute", , isLogging
End If
Exit Sub
ToEnd:
' エラー処理
ErrHandler:
isLogging = False
Dim ErrMsg As String
ErrMsg = "ActiveSheet.Name=" & ActiveSheet.Name & vbCrLf & _
"エラー番号:" & Err.Number & vbCrLf & _
"エラー内容:" & Err.Description
MsgBox ErrMsg, vbCritical, G_APLNAME
Exit Sub
Quit:
MsgBox "AutoCaptureを停止しました。", vbInformation
Application.Caption = "停止中"
End Sub
'
' ### 画面キャプチャ停止 ###'
Sub StopCapture()
Dim sBookOutMsg As String
If isLogging = True Then
isLogging = False ' キャプチャの取得状態を解除する
Application.OnKey "{ESC}", "" ' Esc キーへの登録を解除する
Call Set_FlushWindow1(G_Sh_Canvus, 0, 0) '点滅を止める
G_Status = "停止中"
Application.Caption = G_Status
'If G_Test_Mode = "ON" Then
' Application.Caption = G_Status & _
' " 監視-貼付回数：" & G_WatchCnt & "/" & G_Test_MaxCnt & _
' " - " & G_PasteCnt
'Else
' Application.Caption = G_Status & _
' " 監視-貼付回数：" & G_WatchCnt & "/" & "*" & _
' " - " & G_PasteCnt
'End If
' Bookファイル保存
sBookOutMsg = BookOut("結果", G_Sh_Canvus, G_Id)
MsgBox "### 画面キャプチャ停止 ### " & G_PasteCnt & vbCrLf & _
sBookOutMsg, vbInformation, G_APLNAME
Else
MsgBox "### 画面キャプチャ停止 ### " & G_PasteCnt & vbCrLf & _
"StopCapture " & "isLogging = " & isLogging, vbExclamation, G_APLNAME
End If
End Sub
'
' 出力
'---------+---------+---------+---------+---------+---------+---------+---------+
Public Function BookOut(wbName As String, _
shName As String, _
sId As String) As String
BookOut = ""
Dim wb As Workbook
Dim sBookName As String
Dim sPathFull As String
Dim sMsg As String: sMsg = ""
' 条件付き書式の解除
Call Del_ConditionalFormat(shName)
sBookName = sId & "_" & Trim(shName) & "_" & _
Format(Date, "yyyymmdd") & "_" & _
Format(Time, "hhmmss") & "-" & G_PasteCnt & ".xlsx"
sPathFull = ThisWorkbook.Path & "\" & sBookName
Sheets(Array(shName)).Copy
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
wb.SaveAs fileName:=sPathFull
wb.Close
Application.DisplayAlerts = True
If sBookName <> "" Then
sMsg = "正常" & vbCrLf & "監視-貼付回：" & _
G_WatchCnt & " - " & G_PasteCnt & vbCrLf & sBookName
Else
sMsg = "異常" & vbCrLf & "監視/貼付回：" & _
G_WatchCnt & " - " & G_PasteCnt & vbCrLf & sBookName
End If
BookOut = sMsg
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+
' ### 描画シードのフォーマット ###'
Function Canvas_Format(shName As String)
Dim bRC As Boolean
' クリア処理
'Call DeleteAllCells(shName)
'2024.05.07
Call Delete_Specifiedshapes(shName)
' フォントと行高と列幅
With Worksheets(shName).Cells
.Font.Name = G_FontName
.Font.size = G_Fontsize
.RowHeight = G_CellRowHeight
.ColumnWidth = G_CellColWidth
End With
'2024.05.05
Worksheets(shName).Cells(1, 1).RowHeight = 80
' 条件付き書式の設定
bRC = Set_ConditionalFormat(shName, G_HlType, G_HlColor)
' ■画面フラッシュ
Call Set_FlushWindow1(shName, 4, 0)
' 印刷設定
bRC = PrintSetup(shName, G_PrintSize, G_PrintOrient)
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+
' ### クリップボードリセット ###'
Function ClearClipboardImage()
' クリップボードを開く
If OpenClipboard(0) <> 0 Then
' クリップボードから画像データを削除
EmptyClipboard
' クリップボードを閉じる
CloseClipboard
End If
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+
Function DeleteAllCells(sSheet As String)
' シートのすべてのデータとオブジェクトを削除する
'2024.05.06
MsgBox " Rows.Count=" & Rows.Count & " Columns.Count=" & Columns.Count
Dim rng1 As Range
'rng1 = ThisWorkbook.Sheets(sSheet).Range(Cells(2, 1), Cells(Rows.Count, Columns.Count))
Set rng1 = ThisWorkbook.Sheets(sSheet).Range(Cells(2, 1), Cells(10, 10))
rng1.Clear
'rng1.DrawingObjects.Delete
'ThisWorkbook.Sheets(sSheet).Cells.Clear
'ThisWorkbook.Sheets(sSheet).DrawingObjects.Delete
End Function
'2024.05.07
Function Delete_Specifiedshapes(sSheet As String)
Dim myShape As Shape
For Each myShape In ActiveSheet.Shapes
''エクセルシート上で「画像」を削除する
If myShape.Type = msoPicture Then
myShape.Delete
End If
Next
End Function
'
' 設定値の読込
'---------+---------+---------+---------+---------+---------+---------+---------+
Public Function IsSeteiCheck(shName As String) As Boolean
On Error Resume Next
Dim sMsg As String: sMsg = ""
Dim wsI As Worksheet: Set wsI = Worksheets(shName)
Dim iRC As Integer
Dim sShCanvus As String
Dim sId As String
Dim sSec As String
Dim sGapRow As String
Dim sFontName As String
Dim sFontsize As String
Dim sCellRowHeight As String
Dim sCellColWidth As String
Dim sTestMode As String
Dim sTestMaxCnt As String
Dim sHlType As String
Dim sHlColor As String
Dim sPrintSize As String
Dim sPrintOrient As String
IsSeteiCheck = False
' 設計シート名存在チェック
If IsExistsSheet(shName) = False Then
sMsg = "シートなし " & shName
GoTo IErrorQuit
End If
sShCanvus = sGetSettingValue(wsI, 2, 3) ' 設定 シート名
sId = sGetSettingValue(wsI, 4, 3) ' 設定 ファイルID
sSec = sGetSettingValue(wsI, 5, 3) ' 設定 監視間隔
sGapRow = sGetSettingValue(wsI, 6, 3) ' 設定 貼付行間
sFontName = sGetSettingValue(wsI, 7, 3) ' 設定 文字フォント名
sFontsize = sGetSettingValue(wsI, 7, 4) ' 設定 文字フォントサイズ
sCellRowHeight = sGetSettingValue(wsI, 8, 3) ' 設定 セル行高
sCellColWidth = sGetSettingValue(wsI, 8, 4) ' 設定 セル列幅
sTestMode = sGetSettingValue(wsI, 9, 3) ' 設定 テストモード
sTestMaxCnt = sGetSettingValue(wsI, 9, 4) ' 設定 テストモード 最件
sHlType = sGetSettingValue(wsI, 10, 3) ' 設定 強調セルタイプ
sHlColor = sGetSettingValue(wsI, 10, 4) ' 設定 強調セル背景色
sPrintSize = sGetSettingValue(wsI, 11, 3) ' 設定 印刷用紙
sPrintOrient = sGetSettingValue(wsI, 11, 4) ' 設定 印刷方向
If sShCanvus = "" Or sId = "" Or _
sSec = "" Or sGapRow = "" Or _
sFontName = "" Or sFontsize = "" Or _
sCellRowHeight = "" Or sCellColWidth = "" Or _
sTestMode = "" Or sTestMaxCnt = "" Or _
sHlType = "" Or sHlColor = "" Then
sMsg = "何れかの値が空白 "
GoTo IErrorQuit
End If
' 設計シート名存在チェック
If IsExistsSheet(sShCanvus) = False Then
sMsg = "画像貼付のシートなし " & sShCanvus
GoTo IErrorQuit
End If
G_Sh_Canvus = sShCanvus
G_Id = sId
G_Sec = sSec
G_GapRow = sGapRow
G_FontName = sFontName
G_Fontsize = sFontsize
G_CellRowHeight = sCellRowHeight
G_CellColWidth = sCellColWidth
G_Test_Mode = sTestMode
G_HlColor = sHlColor
G_PrintSize = sPrintSize
G_PrintOrient = sPrintOrient
' 監視間隔 数値チェック
If IsNumeric(sSec) Then
G_Sec = sSec
If G_Sec < 1000 Then
sMsg = "監視間隔 範囲エラー " & sSec
GoTo IErrorQuit
End If
Else
sMsg = "監視間隔 数値エラー " & sSec
GoTo IErrorQuit
End If
' 行間 数値チェック
If IsNumeric(sGapRow) Then
G_GapRow = sGapRow
If G_GapRow <= 1 Then
sMsg = "貼付行間 範囲エラー " & sGapRow
GoTo IErrorQuit
End If
Else
sMsg = "貼付行間 数値エラー " & sGapRow
GoTo IErrorQuit
End If
' 文字フォントサイズ 数値チェック
If IsNumeric(sFontsize) Then
G_Fontsize = sFontsize
Else
sMsg = "文字フォントサイズ 数値エラー " & sFontsize
GoTo IErrorQuit
End If
' セル行高 数値チェック
If IsNumeric(sCellRowHeight) Then
G_CellRowHeight = sCellRowHeight
Else
sMsg = "セル行高 数値エラー " & sCellRowHeight
GoTo IErrorQuit
End If
' セル列幅 数値チェック
If IsNumeric(sCellColWidth) Then
G_CellColWidth = sCellColWidth
Else
sMsg = "セル列幅 数値エラー " & sCellColWidth
GoTo IErrorQuit
End If
' TESTモード/ 最大件数
If Not (sTestMode = "ON" Or sTestMode = "OFF") Then
sMsg = "TESTモード ON/OFF以外 エラー " & sTestMode
GoTo IErrorQuit
End If
If sTestMode = "ON" And IsNumeric(sTestMaxCnt) Then
G_Test_MaxCnt = sTestMaxCnt
If G_Test_MaxCnt <= 0 Then
sMsg = "TESTモード 最大件数範囲エラー " & G_Test_MaxCnt
GoTo IErrorQuit
End If
End If
' 強調セルタイプ 数値
If IsNumeric(sHlType) Then
If Not (sHlType = 0 Or sHlType = 1 Or sHlType = 2) Then
sMsg = "強調セルタイプ 範囲エラー " & sHlType
GoTo IErrorQuit
End If
G_HlType = sHlType
Else
sMsg = "強調セルタイプ 数値エラー " & sHlType
GoTo IErrorQuit
End If
' 強調セル背景色 数値チェック
If IsNumeric(sHlColor) Then
G_HlColor = sHlColor
Else
sMsg = "強調セル背景色 数値エラー " & sHlColor
GoTo IErrorQuit
End If
'---
sMsg = " シート名" & vbTab & G_Sh_Canvus & vbCrLf & _
" 監視間隔" & vbTab & G_Sec & vbCrLf & _
" 貼付行間" & vbTab & G_GapRow & vbCrLf & _
" ファイルID" & vbTab & G_Id & vbCrLf & vbCrLf & _
" 文字 " & vbTab & "フォント：" & G_FontName & " サイズ：" & G_Fontsize & vbCrLf & _
" セル " & vbTab & "行高：" & G_CellRowHeight & " 列幅：" & G_CellColWidth & vbCrLf & _
" テスト " & vbTab & G_Test_Mode & vbTab & "［ON時 回数制限：" & G_Test_MaxCnt & "］" & vbCrLf & _
" 強調セル" & vbTab & "タイプ：" & G_HlType & " 背景色：" & G_HlColor & vbCrLf & _
" 印刷 " & vbTab & "用紙：" & G_PrintSize & " 方向：" & G_PrintOrient
If G_Test_Mode = "ON" Then
' ■Yes or Noの場合
If MsgBox("設定" & vbCrLf & _
"■処理を開始しますか？" & vbCrLf & vbCrLf & _
sMsg, vbYesNo, G_APLNAME) = vbNo Then
Exit Function
End If
End If
IsSeteiCheck = True
Exit Function
IErrorQuit:
MsgBox sMsg, vbCritical, G_APLNAME
Exit Function
End Function
'
' 条件付き書式の設定
'---------+---------+---------+---------+---------+---------+---------+---------+
Function Set_ConditionalFormat(sSheet As String, lType As Long, lColor As Long) As Boolean
Set_ConditionalFormat = True
Worksheets(sSheet).Activate
' 条件付き書式の設定
Worksheets(sSheet).Cells.FormatConditions.Delete
Select Case True
Case lType = 0
Case lType = 1
Worksheets(sSheet).Cells.Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=OR(CELL(""ROW"")=ROW(),CELL(""COL"")=COLUMN())"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = lColor
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Case lType = 2
Worksheets(sSheet).Cells.Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(CELL(""ROW"")=ROW(),CELL(""COL"")=COLUMN())"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = lColor
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Case Else
Set_ConditionalFormat = False
End Select
End Function
'
' 条件付き書式の設定の解除
'---------+---------+---------+---------+---------+---------+---------+---------+
Function Del_ConditionalFormat(sSheet As String)
Worksheets(sSheet).Activate
' 条件付き書式の設定
Worksheets(sSheet).Cells.FormatConditions.Delete
End Function
'
' 気付表示
'---------+---------+---------+---------+---------+---------+---------+---------+
Function Set_FlushWindow1(sSheet As String, lFg As Long, lTimeOut As Long)
Dim tFlashInfo As FLASHWINFO
Dim hWndFlash As LongPtr
Dim lRet As Long
' フラグ複数設定
If lFg = 4 Then
tFlashInfo.dwFlags = FLASHW_ALL Or FLASHW_TIMER
End If
If lFg = 0 Then
tFlashInfo.dwFlags = FLASHW_STOP
End If
' フラッシュ設定
With tFlashInfo
.cbSize = Len(tFlashInfo)
.hWnd = Application.hWnd
'.uCount = luCount
.dwTimeout = lTimeOut
End With
' 指定の設定でウインドウをフラシュする
lRet = FlashWindowEx(tFlashInfo)
End Function
' 気付表示2
'---------+---------+---------+---------+---------+---------+---------+---------+
Function Set_FlushSheet(sSheet As String, iCnt As Long)
' フラッシュ設定（シートの色をスイッチする）
If iCnt \ 2 = 0 Then
ThisWorkbook.Worksheets(sSheet).Tab.ColorIndex = xlColorIndexNone
ThisWorkbook.Worksheets(sSheet).Tab.ColorIndex = 2
Else
ThisWorkbook.Worksheets(sSheet).Tab.ColorIndex = 6
End If
Application.ScreenUpdating = True
End Function
'
' 印刷設定
'---------+---------+---------+---------+---------+---------+---------+---------+
Public Function PrintSetup(shName As String, _
sSize As String, sHoukou As String) As Boolean
PrintSetup = False
Debug.Print "印刷>> サイズ：" & sSize & " 方向：" & sHoukou
' 用紙サイズと方向
If sSize = "A4" And sHoukou = "横" Then
With Sheets(shName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlLandscape
End With
End If
If sSize = "A4" And sHoukou = "縦" Then
With Sheets(shName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlPortrait
End With
End If
' --
If sSize = "B4" And sHoukou = "横" Then
With Sheets(shName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlLandscape
End With
End If
If sSize = "B4" And sHoukou = "縦" Then
With Sheets(shName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlPortrait
End With
End If
' --
If sSize = "A3" And sHoukou = "横" Then
With Sheets(shName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlLandscape
End With
End If
If sSize = "A3" And sHoukou = "縦" Then
With Sheets(shName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlPortrait
End With
End If
' --
With Sheets(shName).PageSetup
' 余白
.LeftMargin = Application.CentimetersToPoints(1)
.RightMargin = Application.CentimetersToPoints(1)
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)
.HeaderMargin = Application.CentimetersToPoints(0)
.FooterMargin = Application.CentimetersToPoints(0)
' ズーム(すべての列を1ページ)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
' ヘッダーとフッター
.CenterHeader = "&A"
.RightHeader = "&D"
.CenterFooter = "&P" & "/" & "&N"
End With
PrintSetup = True
End Function
'
' ブックファイルが開いているか確認
Public Function isBookOpen(bookName) As Boolean
Dim wb As Workbook
Dim sBookName As String
sBookName = bookName
If InStrRev(sBookName, "\") > 0 Then
sBookName = Mid(sBookName, InStrRev(sBookName, "\") + 1)
End If
isBookOpen = False
For Each wb In Worksheets
If wb.Name = sBookName Then
isBookOpen = True
Exit For
End If
Next
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+
Function iGetSettingValue(wsN As Worksheet, _
i As Integer, j As Integer) As Long
Dim iValue As Long
iValue = 0
iValue = Trim(wsN.Cells(i, j).Value)
iGetSettingValue = iValue
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+
Function sGetSettingValue(wsN As Worksheet, _
i As Integer, j As Integer) As String
Dim sValue As String
sValue = ""
sValue = Trim(wsN.Cells(i, j).Value)
sGetSettingValue = sValue
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+
' Sheets に指定した名前のシートの存在確認
Public Function IsExistsSheet(ByVal shName As String)
Dim ws As Variant
For Each ws In Sheets
If LCase(ws.Name) = LCase(shName) Then
IsExistsSheet = True ' 存在する
Exit Function
End If
Next
' 存在しない
IsExistsSheet = False
End Function
'
' 環境チェック
'---------+---------+---------+---------+---------+---------+---------+---------+
Function EnvSecCheck() As Boolean
EnvSecCheck = False
Dim sEnv As String
Dim ToDay As Date
Dim ExpireDate As Date: ExpireDate = "2024/05/30"
Dim sUser1 As String: sUser1 = "Forza1063Z"
Dim sUser2 As String: sUser2 = "forza1063"
Dim sUser3 As String: sUser3 = "Forza1063Z"
Dim sUser4 As String: sUser4 = "Forza1063Z"
Dim sUser5 As String: sUser5 = "Forza1063Z"
Dim sUser6 As String: sUser6 = "Forza1063Z"
If (Environ("USERNAME") = sUser1 Or _
Environ("USERNAME") = sUser2 Or _
Environ("USERNAME") = sUser3 Or _
Environ("USERNAME") = sUser4 Or _
Environ("USERNAME") = sUser5 Or _
Environ("USERNAME") = sUser6) Then
ToDay = Date
If Not ToDay < ExpireDate Then
MsgBox "使用期限を超過 ", vbOKOnly, G_APLNAME
ThisWorkbook.Close savechanges:=False
End If
Else
MsgBox "利用権限なし ", vbOKOnly, G_APLNAME
ThisWorkbook.Close savechanges:=False
End If
EnvSecCheck = True
End Function
'
' ### 画面キャプチャ貼り付け処理 ###'
'---------+---------+---------+---------+---------+---------+---------+---------+
Sub XExeCaptute()
On Error GoTo ErrHandler
Dim CB As Variant
Dim size As Double: size = 1
Dim height As Long
Dim cellHeight As Double
Dim sep As Integer
Dim i As Integer
Dim objShp
G_WatchCnt = G_WatchCnt + 1
If G_Test_Mode = "ON" And G_WatchCnt > G_Test_MaxCnt Then
isLogging = True
Call StopCapture
Exit Sub
End If
CB = Application.ClipboardFormats
Sleep G_Sec 'インターバル秒数
' クリップボードの中身の分繰り返す
For i = 1 To UBound(CB)
' 空判定
If CB(i) <> -1 Then
' 画像判定
If CB(i) = xlClipboardFormatBitmap Then
ActiveSheet.Paste
G_PasteCnt = G_PasteCnt + 1
On Error Resume Next '以下の計算幅エラー
Set objShp = ActiveSheet.Shapes(Selection.Name)
objShp.LockAspectRatio = msoTrue 'サイズ変更も元の比率保持
objShp.ScaleHeight size, msoTrue '画像サイスをSIZE倍する
' 画像の高さとセルの高さからActiveCellの移動幅を計算
height = objShp.height
cellHeight = ActiveCell.height
sep = height / cellHeight + G_GapRow
ActiveCell.Offset(sep, 0).Select
' 画面キャプチャのクリップボードリセット
ClearClipboardImage
Else
Debug.Print "判定 画像以外 " & i & " / " & UBound(CB) & _
" クリップボードの形式 CB(" & i & ")=" & CB(i)
End If
End If
Next i
'If isLogging = True Then
G_Status = "起動"
If G_Test_Mode = "ON" Then
Application.Caption = G_Status & _
" 監視-貼付回：" & G_WatchCnt & "/" & G_Test_MaxCnt & _
" - " & G_PasteCnt & _
" CB数：" & UBound(CB) & " - " & CB(1)
Else
Application.Caption = G_Status & _
" 監視-貼付回：" & G_WatchCnt & "/" & "*" & _
" - " & G_PasteCnt & _
" CB数：" & UBound(CB) & " - " & CB(1)
End If
'End If
Call Set_FlushSheet(G_Sh_Canvus, G_WatchCnt)
' 制御をOSに移します。
DoEvents
' 次回実行予定時刻を設定（数秒ごとに実行）
If isLogging = True Then
Dim NextSec
NextSec = G_Sec / 1000 / 86400
Application.OnTime Now + NextSec, "ExeCaptute", , isLogging
End If
Exit Sub
ToEnd:
' エラー処理
ErrHandler:
isLogging = False
'ErrMsg = "ActiveSheet.Name=" & ActiveSheet.Name & vbCrLf & _
' "エラー番号:" & Err.Number & vbCrLf & _
' "エラー内容:" & Err.Description
'MsgBox ErrMsg, vbCritical, G_APLNAME
End Sub
