diff --git a/RelaxTools.xlam b/RelaxTools.xlam index 2b973ac..266d90c 100644 Binary files a/RelaxTools.xlam and b/RelaxTools.xlam differ diff --git a/Source/RelaxTools.xlsm b/Source/RelaxTools.xlsm index dc865e9..8931551 100644 Binary files a/Source/RelaxTools.xlsm and b/Source/RelaxTools.xlsm differ diff --git a/Source/src/Class/CommandLine.cls b/Source/src/Class/CommandLine.cls index 90adc9f..00268b9 100644 --- a/Source/src/Class/CommandLine.cls +++ b/Source/src/Class/CommandLine.cls @@ -7,6 +7,35 @@ Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False +'----------------------------------------------------------------------------------------------------- +' +' [RelaxTools-Addin] v4 +' +' Copyright (c) 2009 Yasuhiro Watanabe +' https://github.com/RelaxTools/RelaxTools-Addin +' author:relaxtools@opensquare.net +' +' The MIT License (MIT) +' +' Permission is hereby granted, free of charge, to any person obtaining a copy +' of this software and associated documentation files (the "Software"), to deal +' in the Software without restriction, including without limitation the rights +' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +' copies of the Software, and to permit persons to whom the Software is +' furnished to do so, subject to the following conditions: +' +' The above copyright notice and this permission notice shall be included in all +' copies or substantial portions of the Software. +' +' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +' SOFTWARE. +' +'----------------------------------------------------------------------------------------------------- Option Explicit #If VBA7 And Win64 Then diff --git a/Source/src/Class/FileTime.cls b/Source/src/Class/FileTime.cls new file mode 100644 index 0000000..d89f3e4 --- /dev/null +++ b/Source/src/Class/FileTime.cls @@ -0,0 +1,175 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "FileTime" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'----------------------------------------------------------------------------------------------------- +' +' [RelaxTools-Addin] v4 +' +' Copyright (c) 2009 Yasuhiro Watanabe +' https://github.com/RelaxTools/RelaxTools-Addin +' author:relaxtools@opensquare.net +' +' The MIT License (MIT) +' +' Permission is hereby granted, free of charge, to any person obtaining a copy +' of this software and associated documentation files (the "Software"), to deal +' in the Software without restriction, including without limitation the rights +' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +' copies of the Software, and to permit persons to whom the Software is +' furnished to do so, subject to the following conditions: +' +' The above copyright notice and this permission notice shall be included in all +' copies or substantial portions of the Software. +' +' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +' SOFTWARE. +' +'----------------------------------------------------------------------------------------------------- +Option Explicit + +#If VBA7 And Win64 Then + Private Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As LongPtr, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr + Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long + Private Declare PtrSafe Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FileTime, lpFileTime As FileTime) As Long + Private Declare PtrSafe Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SystemTime, lpFileTime As FileTime) As Long + Private Declare PtrSafe Function SetFileTime Lib "kernel32" (ByVal hFile As LongPtr, lpCreationTime As FileTime, lpLastAccessTime As FileTime, lpLastWriteTime As FileTime) As Long +#Else + Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long + Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long + Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (ByRef lpLocalFileTime As FileTime, ByRef lpFileTime As FileTime) As Long + Private Declare Function SystemTimeToFileTime Lib "kernel32" (ByRef lpSystemTime As SystemTime, ByRef lpFileTime As FileTime) As Long + Private Declare Function SetFileTime Lib "kernel32" (ByVal cFile As Long, ByRef lpCreationTime As FileTime, ByRef lpLastAccessTime As FileTime, ByRef lpLastWriteTime As FileTime) As Long +#End If + +' SystemTime 構造体 +Private Type SystemTime + Year As Integer + Month As Integer + DayOfWeek As Integer + Day As Integer + Hour As Integer + Minute As Integer + Second As Integer + Milliseconds As Integer +End Type + +' FileTime 構造体 +Private Type FileTime + LowDateTime As Long + HighDateTime As Long +End Type + +' 定数の定義 +Private Const GENERIC_READ As Long = &H80000000 +Private Const GENERIC_WRITE As Long = &H40000000 +Private Const FILE_SHARE_READ As Long = &H1 +Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80 +Private Const OPEN_EXISTING As Long = 3 +Public Sub SetCreationTime(ByVal stFilePath As String, ByVal dtCreateTime As Date) + +#If VBA7 And Win64 Then + Dim cFileHandle As LongPtr +#Else + Dim cFileHandle As Long +#End If + Dim tFileTime As FileTime + Dim tNullable As FileTime + + cFileHandle = GetFileHandle(stFilePath) + If cFileHandle <> 0 Then + tFileTime = GetFileTime(dtCreateTime) + Call SetFileTime(cFileHandle, tFileTime, tNullable, tNullable) + Call CloseHandle(cFileHandle) + End If + +End Sub +Public Sub SetLastWriteTime(ByVal stFilePath As String, ByVal dtUpdateTime As Date) + +#If VBA7 And Win64 Then + Dim cFileHandle As LongPtr +#Else + Dim cFileHandle As Long +#End If + Dim tFileTime As FileTime + Dim tNullable As FileTime + + cFileHandle = GetFileHandle(stFilePath) + If cFileHandle <> 0 Then + tFileTime = GetFileTime(dtUpdateTime) + Call SetFileTime(cFileHandle, tNullable, tNullable, tFileTime) + Call CloseHandle(cFileHandle) + End If + +End Sub + +Public Sub SetLastAccessTime(ByVal stFilePath As String, ByVal dtAccessTime As Date) + +#If VBA7 And Win64 Then + Dim cFileHandle As LongPtr +#Else + Dim cFileHandle As Long +#End If + Dim tNullable As FileTime + Dim tFileTime As FileTime + + cFileHandle = GetFileHandle(stFilePath) + If cFileHandle <> 0 Then + tFileTime = GetFileTime(dtAccessTime) + Call SetFileTime(cFileHandle, tNullable, tFileTime, tNullable) + Call CloseHandle(cFileHandle) + End If + +End Sub + + +' FileTime を取得する +Private Function GetFileTime(ByVal dtSetting As Date) As FileTime + + Dim tSystemTime As SystemTime + + With tSystemTime + .Year = Year(dtSetting) + .Month = Month(dtSetting) + .DayOfWeek = Weekday(dtSetting) + .Day = Day(dtSetting) + .Hour = Hour(dtSetting) + .Minute = Minute(dtSetting) + .Second = Second(dtSetting) + End With + + Dim tLocalTime As FileTime + Call SystemTimeToFileTime(tSystemTime, tLocalTime) + + Dim tFileTime As FileTime + Call LocalFileTimeToFileTime(tLocalTime, tFileTime) + + GetFileTime = tFileTime + +End Function + +' ファイルのハンドルを取得する +#If VBA7 And Win64 Then + Private Function GetFileHandle(ByVal stFilePath As String) As LongPtr + + GetFileHandle = CreateFile(stFilePath, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) + + End Function +#Else + Private Function GetFileHandle(ByVal stFilePath As String) As Long + + GetFileHandle = CreateFile(stFilePath, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) + + End Function +#End If + diff --git a/Source/src/Microsoft Excel Objects/ThisWorkbook.cls b/Source/src/Microsoft Excel Objects/ThisWorkbook.cls index e02fec5..c73a19d 100644 --- a/Source/src/Microsoft Excel Objects/ThisWorkbook.cls +++ b/Source/src/Microsoft Excel Objects/ThisWorkbook.cls @@ -292,14 +292,24 @@ Private Sub XL_WorkbookAfterSave(ByVal WB As Workbook, ByVal Success As Boolean) Dim strFullName As String strFolder = GetSetting(C_TITLE, "Backup", "Folder", "") If Len(Trim(strFolder)) = 0 Then - strFullName = WB.FullName + strFullName = WB.FullName & ".000" Else - strFullName = rlxAddFileSeparator(strFolder) & rlxGetFullpathFromFileName(WB.FullName) + strFullName = rlxAddFileSeparator(strFolder) & rlxGetFullpathFromFileName(WB.FullName) & ".000" End If + + Dim DateCreated As Date + With CreateObject("Scripting.FileSystemObject") + DateCreated = .GetFile(WB.FullName).DateCreated + End With + mblnEventCancel = True - WB.SaveCopyAs strFullName & ".000" + WB.SaveCopyAs strFullName mblnEventCancel = False + Dim a As FileTime + Set a = New FileTime + a.SetCreationTime strFullName, DateCreated + End If Application.DisplayAlerts = blnDisplayAlerts @@ -583,7 +593,9 @@ Private Sub XL_LINE_SheetSelectionChange(ByVal sh As Object, ByVal Target As Ran With sh.Shapes(C_XY_BAR_NAME).Fill .visible = True ' .ForeColor.RGB = lngFillColor - .Transparency = 1 +' .Transparency = 0 + .ForeColor.RGB = vbWhite + .Transparency = 0 .Solid End With diff --git a/Version.txt b/Version.txt index 810c8d0..74e1e6c 100644 --- a/Version.txt +++ b/Version.txt @@ -1,4 +1,9 @@ -2017/08/13(sun) RelaxTools-Addin Version 4.13.8(RustRemover) +2017/08/15(tue) RelaxTools-Addin Version 4.13.9(RustRemover) +◇機能改善 +・十字カーソルのガイドの背景色が透明で他の文字と重なると見づらくなるので白固定とした。 +・ブックの世代管理でファイル作成時のタイムスタンプを保持するように修正。 + +2017/08/13(sun) RelaxTools-Addin Version 4.13.8(RustRemover) ◇機能改善 ・かんたん表DXで「矩形」を「短形」と記述していたのを修正。 ・シートを新しいブックにコピーする際、ActiveBookで新しくコピーしたブックを判定していたが、