Option Explicit
' *******************************************************************************
' *
' * 画像をEXCELに貼り付ける
' * 2024.05.25 Btn1,Btn2 の初期のボタン活性・非活性を非活性にする
' *
' *******************************************************************************
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.6 "
'2024.05.27
Public Const G_COLR_GR As Long = 10 '緑
Public Const G_COLR_YL As Long = 6 '黄色緑
Public Const G_COLR_GY As Long = 16 'グレー
'
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 G_Title As String
Public G_LogFile As String
Public G_BookName As String
'
Const PRS_MSG_ROW As Long = 1 '開始行
Const PRS_MSG1_COL As Long = 5 '開始カラム
Const PRS_MSG2_COL As Long = 11 '開始カラム
Const PRS_MSG3_COL As Long = 20 '開始カラム
Public G_PRS_MSG1 As String
Public G_PRS_MSG2 As String
Public G_PRS_MSG3 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
'2024.05.27
If G_Status = "準備中" Then
Call SetStatusBackColor(G_Sh_Canvus, G_Status)
End If
'
With ThisWorkbook.Sheets(G_Sh_Canvus)
.Cells(PRS_MSG_ROW, PRS_MSG1_COL).Value = ""
.Cells(PRS_MSG_ROW, PRS_MSG2_COL).Value = ""
.Cells(PRS_MSG_ROW, PRS_MSG3_COL).Value = ""
End With
'デバックモードの設定
G_BookName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - Len(".xlsm"))
G_LogFile = ThisWorkbook.Path & "\" & G_BookName & "_DebugPrint_" & _
Format(Now(), "yyyymmdd_hhmmss") & ".txt"
'
Call Debug_Printb_Init(G_LogFile)
'
' 描画シートフォーマット
Canvas_Format (G_Sh_Canvus)
' 画面キャプチャのクリップボードリセット
ClearClipboardImage
'カーソルの初期処理
Rows(2).Select '行固定
ActiveWindow.FreezePanes = True
Range("A3").Select 'カーソルの位置
'
'-----------------------------
' 主処理
'-----------------------------
' 画面キャプチャ開始
Application.Caption = "準備中"
Call ExeCaptute
'
End Sub
'
' ### 画面キャプチャ貼り付け処理 ###'
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Sub ExeCaptute()
'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
Dim tmpArray() As Variant
'2024.05.27
If G_Status = "起動中" Then
Call SetStatusBackColor(G_Sh_Canvus, G_Status)
End If
'
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
'■
Debug_Printb "[ExeCaptute]", "."
ReDim tmpArray(UBound(CB) + 1)
For i = 1 To UBound(CB) ' クリップボードの中身の分繰り返す
Dim adr As String: Dim Col As Integer: Dim Row As Integer
adr = ActiveCell.Address
Col = ActiveCell.Column: Row = ActiveCell.Row
'adr = ThisWorkbook.ActiveCell.Address
'Col = ThisWorkbook.ActiveCell.Column: Row = ThisWorkbook.ActiveCell.Row
'■
G_PRS_MSG2 = "CB(" & i & ")=" & CB(i) & " 行列[" & Col & ":" & Row & "] "
tmpArray(i - 1) = G_PRS_MSG2
' 画像判定
If CB(i) = xlClipboardFormatBitmap Then
'★
On Error Resume Next
'ActiveSheet.Paste
ThisWorkbook.Sheets(G_Sh_Canvus).Paste
Sleep G_Sec 'インターバル秒数
'CurCell.Offset(CurRow, CurCols-1).Value = "■"
'
Application.CutCopyMode = False ' 切り取り・コピーモードを解除
G_PasteCnt = G_PasteCnt + 1
'
On Error Resume Next ' 以下の計算幅エラー
'
'Set objShp = Sheets(G_Sh_Canvus).Shapes(Selection.Name)
'Set objShp = ThisWorkbook.Sheets(G_Sh_Canvus).Shapes(Selection.Name)
Set objShp = ActiveSheet.Shapes(Selection.Name)
objShp.LockAspectRatio = msoTrue ' サイズ変更も元の比率保持
objShp.ScaleHeight size, msoTrue ' 画像サイスをSIZE倍する
'
' 画像高さとセル高さからActiveCellの移動幅を計算
height = objShp.height ' <===★★
If height = 0 Then
height = 300
End If
cellHeight = ActiveCell.height
sep = height / cellHeight + G_GapRow
'
ActiveCell.Offset(sep, 0).Select
'ThisWorkbook.Sheets(G_Sh_Canvus).ActiveCell.Offset(sep, 0).Select
Dim iNextRow As Integer
iNextRow = Row + sep
'
G_PRS_MSG3 = "■計算 画像高:" & height & _
" セル高:" & cellHeight & " 間隔:" & sep & _
" >>次行:" & iNextRow
ThisWorkbook.Sheets(G_Sh_Canvus).Cells(PRS_MSG_ROW, PRS_MSG3_COL).Value = _
G_PRS_MSG3
' 画面キャプチャのクリップボードリセット
ClearClipboardImage
End If
Next i
'
Dim tmpMsg As String
Dim k As Long
tmpMsg = ""
For k = 0 To UBound(tmpArray())
tmpMsg = tmpMsg & tmpArray(k)
Next k
ThisWorkbook.Sheets(G_Sh_Canvus).Cells(PRS_MSG_ROW, PRS_MSG2_COL).Value = _
Time & " 判定 " & tmpMsg
Debug_Printb "[ExeCaptute]", Time & " 判定 " & tmpMsg & G_PRS_MSG3
End If
'
G_Status = "起動中"
Application.Caption = G_Status
If G_Test_Mode = "ON" Then
G_PRS_MSG1 = " 監視(現在/最大):" & G_WatchCnt & "/" & G_Test_MaxCnt & _
" - " & "貼付:" & G_PasteCnt
ThisWorkbook.Sheets(G_Sh_Canvus).Cells(PRS_MSG_ROW, PRS_MSG1_COL).Value = _
Time & " " & G_PRS_MSG1
Else
G_PRS_MSG1 = " 監視(現在/最大):" & G_WatchCnt & "/" & "*" & _
" - " & "貼付:" & G_PasteCnt
ThisWorkbook.Sheets(G_Sh_Canvus).Cells(PRS_MSG_ROW, PRS_MSG1_COL).Value = _
Time & " " & G_PRS_MSG1
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
Debug_Printb "[StopCapture]", "isLogging=" & isLogging
If isLogging = True Then
isLogging = False ' キャプチャ取得状態を解除する
Application.OnKey "{ESC}", "" ' Esc キーへの登録を解除する
Call Set_FlushWindow1(G_Sh_Canvus, 0, 0) '点滅を止める
G_Status = "停止中"
Application.Caption = G_Status
'2024.05.27
If G_Status = "停止中" Then
Call SetStatusBackColor(G_Sh_Canvus, G_Status)
End If
'シートをコピーしてコピー先のシートを編集する
Call ShCopy(G_Sh_Canvus, G_Sh_Canvus & "_Out") 'シートコピー
sBookOutMsg = BookOut("結果", G_Sh_Canvus & "_Out", G_Id) ' Book保存
Worksheets(G_Sh_Canvus).Activate
''2024.05.30
' ボタンの活性・非活性
With Worksheets(G_Sh_Canvus)
.CommandButton1.Enabled = True
.CommandButton2.Enabled = False
End With
MsgBox "### 画面キャプチャ停止 ### " & vbCrLf & _
sBookOutMsg, vbInformation, G_APLNAME
Else
'2024.05.30
' ボタンの活性・非活性
With Worksheets(G_Sh_Canvus)
.CommandButton1.Enabled = True
.CommandButton2.Enabled = False
End With
MsgBox "### 画面キャプチャ停止 ### " & vbCrLf & _
"StopCapture " & "isLogging = " & isLogging, vbExclamation, G_APLNAME
End If
End Sub
' 2024.05.27
' 状況行の背景色セット
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Public Function SetStatusBackColor(shName As String, _
sStatus As String) As Boolean
SetStatusBackColor = False
'
Select Case True
Case sStatus = "準備中"
With ThisWorkbook.Sheets(shName).Rows("1:1")
.Interior.ColorIndex = G_COLR_GR
End With
Case sStatus = "起動中"
With ThisWorkbook.Sheets(shName).Rows("1:1")
.Interior.ColorIndex = G_COLR_YL
End With
Case sStatus = "停止中"
With ThisWorkbook.Sheets(shName).Rows("1:1")
.Interior.ColorIndex = G_COLR_GY
End With
Case Else
Debug.Print "shName=" & shName & " sStatus=" & sStatus
End Select
'
SetStatusBackColor = True
End Function
'
' シートコピー
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Public Function ShCopy(shNameS As String, shNameT As String) As String
'先ソースの存在を確認して存在していれば先シートを削除する
If IsExistsSheet(shNameT) = True Then
Application.DisplayAlerts = False
Worksheets(shNameT).Delete
Application.DisplayAlerts = True
End If
'元シートを末尾にコピーし、Activeになった先シート名を変更する
Worksheets(shNameS).Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = shNameT
'先シートの内容処理
Worksheets(shNameT).OLEObjects.Delete 'ActiveXのボタン削除
Rows("1:1").Select '1行目を編集する
Selection.ClearContents
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = G_HlColor
.PatternTintAndShade = 0
End With
' フォントと行高と列幅
With Worksheets(shNameT).Cells
.Font.Name = G_FontName
.Font.size = G_Fontsize
.RowHeight = G_CellRowHeight
.ColumnWidth = G_CellColWidth
End With
' タイトルをセット
Cells(1, 1).Value = G_Title
End Function
'
' 出力
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
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_CondFormat(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
Debug_Printb "[BookOut]", sPathFull
BookOut = sMsg
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
' ### 描画シードのフォーマット ###'
Function Canvas_Format(shName As String)
Dim bRC As Boolean
' クリア処理
Call Del_AllCells(shName)
Call Del_shapes(shName)
' フォントと行高と列幅
With Worksheets(shName).Cells
.Font.Name = G_FontName
.Font.size = G_Fontsize
.RowHeight = G_CellRowHeight
.ColumnWidth = G_CellColWidth
End With
'
Worksheets(shName).Cells(1, 1).RowHeight = 80
' 条件付き書式の設定
bRC = Set_CondFormat(shName, G_HlType, G_HlColor)
' ■画面フラッシュ
Call Set_FlushWindow1(shName, 4, 0)
' 印刷設定
bRC = PrintSetup(shName, G_PrintSize, G_PrintOrient)
'2024.05.27
'状況表示行のブランククリア
With ThisWorkbook.Sheets(shName)
.Cells(PRS_MSG_ROW, PRS_MSG1_COL).Value = "" '(1)
.Cells(PRS_MSG_ROW, PRS_MSG2_COL).Value = "" '(2)
.Cells(PRS_MSG_ROW, PRS_MSG3_COL).Value = "" '(3)
End With
End Function
'
' シートのすべてのデータとオブジェクトを削除する
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Function Del_AllCells(sSheet As String)
Debug_Printb "[Del_AllCells]", "RowMax=" & Rows.Count & " ColMax=" & Columns.Count
Dim rng1 As Range
' ★★ 2022.05.25
Set rng1 = ThisWorkbook.Sheets(sSheet).Range(Cells(2, 1), Cells(Rows.Count, Columns.Count))
rng1.Clear
End Function
'
'エクセルシート上で「画像」を削除する
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Function Del_shapes(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
'
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Function Debug_Printb_Init(sFileName As String)
' 実行時バインデイング
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Call fso.DeleteFile(sFileName, True) '指定したファイルのパスを削除
Set fso = Nothing
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Function Debug_Printb(varSec As String, varData As Variant)
Dim lngFileNum As Long
Dim mystr As String * 15
mystr = varSec
If G_Test_Mode = "ON" Then
lngFileNum = FreeFile()
Open G_LogFile For Append As #lngFileNum
Print #lngFileNum, Time & " " & mystr & " " & varData
Close #lngFileNum
End If
Debug.Print varData
End Function
'
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
' ### クリップボードリセット ###'
Function ClearClipboardImage()
' クリップボードを開く
If OpenClipboard(0) <> 0 Then
' クリップボードから画像データを削除
EmptyClipboard
' クリップボードを閉じる
CloseClipboard
End If
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
Dim sTitle As String
IsSeteiCheck = False
' 設計シート名存在チェック
If IsExistsSheet(shName) = False Then
sMsg = "シートなし " & shName
GoTo IErrorQuit
End If
'2024.05.30
' ボタンの活性・非活性
With Worksheets(G_Sh_Canvus)
.CommandButton1.Enabled = False
.CommandButton2.Enabled = True
End With
'
sShCanvus = sGetSettingValue(wsI, 2, 3) ' 設定 シート名
sId = sGetSettingValue(wsI, 3, 3) ' 設定 ファイルID
sSec = sGetSettingValue(wsI, 4, 3) ' 設定 監視間隔
sGapRow = sGetSettingValue(wsI, 5, 3) ' 設定 貼付行間
sFontName = sGetSettingValue(wsI, 6, 3) ' 設定 文字フォント名
sFontsize = sGetSettingValue(wsI, 6, 4) ' 設定 文字フォントサイズ
sCellRowHeight = sGetSettingValue(wsI, 7, 3) ' 設定 セル行高
sCellColWidth = sGetSettingValue(wsI, 7, 4) ' 設定 セル列幅
sTestMode = sGetSettingValue(wsI, 8, 3) ' 設定 テストモード
sTestMaxCnt = sGetSettingValue(wsI, 8, 4) ' 設定 テストモード 最件
sHlType = sGetSettingValue(wsI, 9, 3) ' 設定 強調セルタイプ
sHlColor = sGetSettingValue(wsI, 9, 4) ' 設定 強調セル背景色
sPrintSize = sGetSettingValue(wsI, 10, 3) ' 設定 印刷用紙
sPrintOrient = sGetSettingValue(wsI, 10, 4) ' 設定 印刷方向
sTitle = sGetSettingValue(wsI, 11, 3) ' 設定 タイトル
'
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
G_Title = sTitle
'
' 監視間隔 数値チェック
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 & " ms " & 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 & vbCrLf & _
" タイトル " & vbTab & G_Title
If G_Test_Mode = "ON" Then
' ■Yes or Noの場合
If MsgBox("設定" & vbCrLf & _
"■処理を開始しますか？" & vbCrLf & vbCrLf & _
sMsg, vbYesNo, G_APLNAME & " [設定]") = vbNo Then
'2024.05.30
' ボタンの活性・非活性
With Worksheets(G_Sh_Canvus)
.CommandButton1.Enabled = True
.CommandButton2.Enabled = False
End With
Exit Function
Else
'2024.05.30
' ボタンの活性・非活性
With Worksheets(G_Sh_Canvus)
.CommandButton1.Enabled = False
.CommandButton2.Enabled = True
End With
End If
End If
IsSeteiCheck = True
Exit Function
IErrorQuit:
'2024.05.30
' ボタンの活性・非活性
With Worksheets(G_Sh_Canvus)
.CommandButton1.Enabled = True
.CommandButton2.Enabled = False
End With
MsgBox sMsg, vbCritical, G_APLNAME
Exit Function
End Function
'
' 条件付き書式の設定
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Function Set_CondFormat(sSheet As String, lType As Long, lColor As Long) As Boolean
Set_CondFormat = True
'
Worksheets(sSheet).Activate
' 条件付き書式の設定
Worksheets(sSheet).Cells.FormatConditions.Delete
'
Select Case True
Case lType = 0
Case lType = 1
ThisWorkbook.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
ThisWorkbook.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_CondFormat = False
End Select
End Function
'
' 条件付き書式の設定の解除
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Function Del_CondFormat(sSheet As String)
'Worksheets(sSheet).Activate
ThisWorkbook.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
' 用紙サイズと方向
Select Case True
Case sSize = "A4" And sHoukou = "横"
With Sheets(shName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlLandscape
End With
Case sSize = "A4" And sHoukou = "縦"
With Sheets(shName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlPortrait
End With
Case sSize = "B4" And sHoukou = "横"
With Sheets(shName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlLandscape
End With
Case sSize = "B4" And sHoukou = "縦"
With Sheets(shName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlPortrait
End With
Case sSize = "A3" And sHoukou = "横"
With Sheets(shName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlLandscape
End With
Case sSize = "A3" And sHoukou = "縦"
With Sheets(shName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlPortrait
End With
Case Else
Debug.Print "sSize=" & sSize & "sHoukou=" & sHoukou
End Select
' --
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
' '2024.05.28
' 環境チェック
'---------+---------+---------+---------+---------+---------+---------+---------+---------+
Function EnvSecCheck() As Boolean
EnvSecCheck = False
Dim iValid As Integer: iValid = 0
Dim i As Integer
Dim ToDay As Date
Dim ExpireDate As Date
Dim myUsrArray As Variant
'
ExpireDate = "2024/06/30"
myUsrArray = Array("Forza1063Z", "forza1063", "Forza1063Z", "Forza1063Z")
ToDay = Date
'
For i = LBound(myUsrArray) To UBound(myUsrArray)
If Environ("USERNAME") = myUsrArray(i) And ExpireDate > Date Then
iValid = 1
Exit For
End If
Next i
'
If iValid = 0 Then
MsgBox "利用権限なしか期限超過 ", vbCritical + vbOKOnly, G_APLNAME & " [環境]"
ThisWorkbook.Close savechanges:=False
Exit Function
End If
EnvSecCheck = True
End Function
