• ベストアンサー

エクセルの試用期限の設定について

みなさん、こんにちわ！ 以前にも質問させて頂き組み込んでみると出来たと思っていましたが出来ていませんでした。 たびたび申し訳ないですが教えてください。 エクセルのマクロファイルに試用期間を設けて所定日数経過するとそのファイル自体が一度開いて試用期間が過ぎましたとメッセージを表示させて終了するようにしたいのですが、やっぱりパソコンの内部時計の変更で開くものでしょうか？ パソコンの内部時計を変更しても開かないようにはできないものでしょうか？ 具体的に教えて頂ければ大変ありがたいです。 たびたびすいませんが宜しく 現状のものを貼り付けておきます。 Private Sub Workbook_Open() Dim t As String Dim dt As Date t = GetSetting("TestApp", "TestSection", "Issheet") If t = "" Then ' レジストリ値がない。初めて実行されたと認識し、今日の日付をセット t = Format(CLng(Now())) SaveSetting "TestApp", "TestSection", "Issheet", t ' ダミーのランダム値をセット SaveSetting "TestApp", "TestSection", "Issheetd", Right$(Str(CDbl(Now())), 5) End If dt = CLng(t) If Now() > dt + 32 Then ' 初めて実行された日から32日以上経っている MsgBox "試用期間が過ぎましたので終了します。" ' 本ブックをClose For Each w In Application.Workbooks w.Save Next w Workbooks.Close End Sub

noname#63196
noname#63196

質問者が選んだベストアンサー

  • ベストアンサー
  • kenpon24
  • ベストアンサー率64% (66/102)
回答No.3

用途や試用期間からしてシェアウェアか何かだろうに、コード書いてくれと・・・ お金を取るつもりなら、質問者さん自身の大幅なレベルアップが必要です。そんなに難しいロジックじゃないんだし、レジストリ書き込みなど高度な内容も扱っていますので。 コードもコンパイルエラーになるし、'本ブックをクローズ　で全ブックを閉じているし、理解してやっているのかが不安です。 元を改良したサンプルです。ただし、私はレジストリに余計な書き込みなどしたくなかったので、実際に書き込みテストは行っておりません。 ご自分で確認してください。 ところで、ダミー値をセットする目的は何ですか？ 理由があるなら教えていただけませんか？ サンプル Private Sub Workbook_Open() Dim t As String Dim tt As String Dim dt As Date Dim dtt As Long t = GetSetting("TestApp", "TestSection", "Issheet") tt = GetSetting("TestApp", "TestSection_zan", "Issheet_zan") If t = "" Then Exit Sub End If dt = CLng(t) dtt = CLng(tt) '日付が巻き戻った、32日以上経っている場合終了する If CLng(Now()) < dt Or dtt < 0 Then MsgBox "試用期間が過ぎましたので終了します。" ' 本ブックをClose <-全ブックをクローズするがよいのか？ For Each w In Application.Workbooks w.Save Next w Workbooks.Close End If End Sub Private Sub Workbook_Close() Dim t As String Dim tt As String t = GetSetting("TestApp", "TestSection", "Issheet") tt = GetSetting("TestApp", "TestSection_zan", "Issheet_zan") If tt = "" Then 'レジストリ値がない。初めて実行されたと認識し、今日の日付をセット t = Format(CLng(Now())) tt = "32" Else '書き込み値をセット。暗号化が必要ならハッシュ関数を考えること tt = CStr(CLng(tt) - (CLng(Now()) - CLng(t))) t = Format(CLng(Now())) End If Range("D1") = t 'レジストリに値をセット SaveSetting "TestApp", "TestSection", "Issheet", t ' ダミーのランダム値をセット SaveSetting "TestApp", "TestSection", "Issheetd", Right$(Str(CDbl(Now())), 5) '残日数を記述 SaveSetting "TestApp", "TestSection_zan", "Issheet_zan", tt End Sub それと、このままNo.2さんのおっしゃるとおり、 前回の使用日　　7/1 　使用期限　　　　7/10 　PCの日付　　　　7/17 → 7/10に変更 のようなケースには対応しきれません。 自動でタイムサーバ同期をするか・・・、 net time サーバー /set /yes 初回起動時に自身のショートカットまたはレジストリを書き換えるスクリプトをスタートアップに登録するか・・・ こんな動作をするマクロ、あんまり配布してほしくないなぁ。。 私ならレジストリ書き込みされるのも嫌です。

その他の回答 (4)

  • Azzz___
  • ベストアンサー率40% (9/22)
回答No.5

私も昔考えたことがあったので興味ある質問です。 手っ取り早いのは外部から日付情報を持ってくることだと思いますが、 更にその起動情報を外部に保存しておくと、より固いと思います。 質問者さんがHTML知識などお持ちならCGIで日付だけを吐き出す HTMLを作って、そこの値を読み込み、更に保存させる方法です。 今では死語かもしれませんが、クラサバというやつですね。 ただ複数からのアクセスを想定するとどのPCからのアクセスか 固有にしておく必要がありますので できるかは分かりませんが、そのときにExcelのシリアル値も 一緒に保存しておけば、いけそうだし、駄目なら CGI等でクッキー使って埋め込んでおくのもいいかもしれません。 あるいは利用者にハンドル名を入れさせるのもいいかと思います。 ただしこの場合ネットワーク接続前提なので スタンドアローンのPCではできないですので、更に別途対策が必要ですね。 そこでNo1さんとNo2さんのロジックを応用して No2さん 　前回の使用日　　7/1 　使用期限　　　　7/10 　PCの日付　　　　7/17 → 7/10に変更 上記の情報に加え、毎回起動時の日付の書き込みを行えば、 日付を戻された時にエラー検知できるでしょう。 ただどのみちレジストリをいじられると意味がなくなりますので レジストリの値を暗号化させるなどの仕掛けが必要になりますね。 もっともこの意味で言えば、レジストリである必要はないので Cドライブ直下などにini的なファイルを置いてそこから読み込ませても 同じだし、同ブック内に非表示シート(メニューバーから表示できない)を作っても 意味合いは同じだと思います。 ただこの方法でも日付の書き込み先を見つけられたら確実性がなくなりますので ガチガチにするという意味では 色々なパターンを考慮して行わなければならないので 100%は難しいと思いますし、 それを実装するにはお金取れる価値あるかなとか思います(笑) コードの例示とかはすみませんがパスにてお願いします。

  • kenpon24
  • ベストアンサー率64% (66/102)
回答No.4

失礼、Thisworkbookのイベントだったか。 Private Sub Workbook_Close()を Private Sub Workbook_BeforeClose(Cancel As Boolean) にすること。 ちなみに現状ではレジストリキー自体を削除されたら対応しきれませんので悪しからず。 それと、タイトルを微妙に変えてのマルチポストはやめましょう

noname#63196
質問者

お礼

回答いただき誠申し訳ないです。 参考に頑張ってみます。 他投稿、以後気をつけます。

回答No.2

＞パソコンの内部時計を変更しても開かないようにはできないものでしょうか？ そのレベルの問題を何とかするなら、外部の標準日付を取得するしか ないでしょうね。 例えば、管理者以外は日付を変更できないようなサーバの日付を 参照するとか（NET TIMEコマンドとかで出来ましたっけ？ …あ、NET TIME使うなら起動時にサーバと日付を合わせるって手もあるな）、 ネットから標準日付を取得するとか（そっちは私はよくわかりません）。 ちなみに、ANo.1氏のチェック方法も役に立たないわけでは無いとは思いますが、 例えば以下のような場合に、うまく行かないと思います。 　前回の使用日　　7/1 　使用期限　　　　7/10 　PCの日付　　　　7/17 → 7/10に変更

  • kenpon24
  • ベストアンサー率64% (66/102)
回答No.1

やり方次第じゃないですか？ 最初の日付だけを記録するのではなく、閉じる度に 最終使用日時と残日数を記録する。 起動時にNowをとって最終使用日時より戻っていたらNG、 ＋残日数が0未満になったらNGのチェックをするようにするとかで、いかがでしょうか。

noname#63196
質問者

お礼

kenpon24さん、早速ご回答ありがとうございます。 なるほど。。。 VBA勉強中のため、すいませんが、具体的に教えていただけると助かるんですが・・

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • もしも新規Excelファイルを開いてる場合は閉じる

    Excel2003です・ ユーザーが新規Excelファイル（book1)かテスト用ファイルを開いている場合は閉じる処理を考えております。 Option Explicit Dim ws As Workbook, flag As Boolean Private Sub Workbook_Open() For Each ws In Workbooks If ws.Name = "Book1" Then flag = True Next ws If flag = True Then Workbooks("Book1.xls").Close 　 Else 　 End IF For Each ws In Workbooks If ws.Name = "テスト用.xls" Then flag = True Next ws If flag = True Then Workbooks("テスト用.xls").Close 　 Else 　 End IF End Sub このコードだとBook1を開いているのに、Trueで拾ってくれません。 ws.Name = "Book1.xls"にしても同じです。 どこかおかしい部分があるのでしょうか？

  • Excelのブック間の串刺し計算について

    Excelのブック間の串刺し計算について VBA超初心者です。同じフォルダ内にファイルがいくつかあり、同じ形式で、sheet1のB4のセルに計があったとして、それをブック間で串刺し集計したいのですが、うまくいきません。どこが悪いのかもわからず、困り果ててます。ご指導お願いします。 Sub BookShuukei() Dim FileName As String Dim Total As Integer Dim OpenedBook As Workbook Dim IsBookOpen As Boolean FileName = Dir("*.xls") Application.ScreenUpdating = False Do While FileName <> "" If FileName <> ThisWorkbook.Name Then IsBookOpen = False For Each OpenedBook In Workbooks If OpenedBook.Name = FileName Then IsBookOpen = True Exit For End If Next If IsBookOpen = False Then Workbooks.Open (FileName) End If Total = Total + Workbooks(FileName).Sheets(1).Range("B4").Value If IsBookOpen = False Then Workbooks(FileName).Close End If End If FileName = Dir() Loop Application.ScreenUpdating = True MsgBox (Total) End Sub

  • Excel 2007　Windows７での不具合

    下記のExcel 2007 VBAマクロを Windows XP で組んでいましたが、 Windows 7 に乗り換えたとたん、強制終了してしまいます。 Workbooks.Openのアドレスは、Windows 7用に書き換えました。 何方かご教授願います。 　　Private Sub CommandButton63_Click() 　　Application.ScreenUpdating = False 　　Dim wb As Workbook 　　wbn1 = ActiveWorkbook.Name 　　For Each wb In Workbooks 　　If wb.Name = wbn1 Then 　　Workbooks.Open "D:\ユーザー\PC18\Documents\※※※※\※※※※.xls" 　　ActiveWindow.WindowState = xlMaximized　 　　Workbooks(wbn1).Save 　　Application.DisplayAlerts = False 　　Workbooks(wbn1).Close 　　Else: Application.ScreenUpdating = False 　　End If 　　Next 　　Application.ScreenUpdating = True 　　End Sub

  • ExcelのVBAでブックを保存

    住所録Aと住所録Bがあります。 AとBを比較して、差異をを別ファイルに出力しようとしています。 比較元となるファイルは、AでもBでもかまいません。 比較、判定、ファイルへの出力部分は、省略していますが、保存 する場合は、どこに行うのがよいのですか bookですか。sheetですか。 両方で、SaveAsができまが、使い分けがあるのでしょうか。 どのように使い分けするのでしょうか。 書き方、使い方のおかしいところを指摘して頂くとありがたい です。 --------------------------------------------------------------------------------------------------- Option Explicit Sub test() Dim ret As Integer Dim row1 As Long Dim col1 As Long Dim row2 As Long Dim col2 As Long Dim myRtn As Boolean Dim fno1 As String Dim fno2 As String Dim OutBook As New Workbook Dim OutSheet As New Worksheet Dim OutFileName As String Dim cnt As Integer Dim I As Integer ret = MsgBox("処理を開始します。" + Chr(13) + Chr(10) + "よろしいですか。？", _ vbYesNo + vbQuestion) If ret = vbNo Then End End If myRtn = Application.Dialogs(xlDialogOpen).Show If myRtn = False Then MsgBox "［キャンセル］が選択されました" & vbCr & _ "処理を終了します" Exit Sub End If fno1 = Application.ActiveWorkbook.Name myRtn = Application.Dialogs(xlDialogOpen).Show If myRtn = False Then MsgBox "［キャンセル］が選択されました" & vbCr & _ "処理を終了します" Exit Sub End If fno2 = Application.ActiveWorkbook.Name Set OutBook = Workbooks.Add Set OutSheet = ActiveSheet OutBook.Worksheets(1).Name = "テスト" OutFileName = "テスト.xls" With Application.Workbooks(fno1).Worksheets(1) row1 = 1 col1 = 1 cnt = 1 Do While .Cells(row1, 1) <> "" 処理 （省略） Loop End With MsgBox "処理が終了しました。", vbOKOnly + vbInformation, "確認" Application.Workbooks(fno1).Close Application.Workbooks(fno2).Close OutSheet.SaveAs Filename:=OutFileName OutBook.SaveAs Filename:=OutFileName OutBook.Close End Sub --------------------------------------------------------------------------------------------------- OutSheet.SaveAs Filename:=OutFileName or OutBook.SaveAs Filename:=OutFileName のどちらでも保存ができます。 また、書き方、使い方のおかしいところを指摘して頂くとありがたいです。

  • マクロ　エクセル２００３

    いつも回答して頂き感謝しています。 原紙のブックを開き、別の名前を付けて保存するマクロを考えています。 原紙のブックを開くマクロはネットから探して、少し修正して出来あがったのですが、 この開いた原紙のブックに別の名前を付けて保存するマクロで困っています。 ただ単に名前を付けるだけだったら問題無いのですが、 その名前が既に保存されていないか確認した後、保存としたいのです。 ブックを開く記述を少し引用して出来ないかやってみたのですが、 Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile で、定数式が必要です。と表示されエラーが発生してしまいます。 どのように変更したら上手くいくのでしょうか？宜しくお願い致します。 Sub Sample() Dim buf1 As String Dim buf2 As String Dim NewFile As String Dim ws1 As Worksheet Dim wb As Workbook Set ws1 = ThisWorkbook.Worksheets("作成") NewFile = "借入貸出" & ws1.Range("C4").Value & "." & ws1.Range("D4").Value Const Target1 As String = "C:\Users\Owner\Documents\借入貸出原紙.xlsx" Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile　& ".xlsx" buf1 = Dir(Target1) If buf1 = "" Then MsgBox Target1 & vbCrLf & "は存在しません", vbExclamation Exit Sub End If For Each wb In Workbooks If wb.Name = buf1 Then Application.DisplayAlerts = False Workbooks("借入貸出原紙.xlsx").Close Application.DisplayAlerts = True End If Next wb Workbooks.Open Target1 buf2 = Dir(Target2) If buf2 = "" Then End If End Sub

  • excelのファイルとセル値を書き出したい

    excel2003を利用しています。 とあるフォルダにある excelファイル名(自分自身のファイルを除く） を全て書き出して、 且つ A１セルの値をB列に書き出すことを、やろうとvbaを作ってみましたが。 最後のファイルのA1セルを書きだすところで、エラーになっていまい そこだけ空白になってしまいます。※写真参照 記述は以下の通りです。どのように修正すればよいか 教えていただけないでしょうか？ また他にもっと優れた記述があれば、そちらも教えて欲しいです。 よろしくお願いします。 Sub test() Dim buf As String, cnt As Long Dim Path As String Path = ThisWorkbook.Path & "\" buf = Dir(Path & "*.xls") cnt = 2 Do While buf <> "" If buf <> ThisWorkbook.Name Then cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Workbooks.Open Filename:=Path & "\" & buf MsgBox Workbooks(buf).Worksheets(1).Range("A1").Value Cells(cnt, 2) = Workbooks(buf).Worksheets(1).Range("A1").Value Workbooks(buf).Close End If Loop End Sub

  • 複数のエクセルシートをまとめるマクロ

    下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub

  • VBAの内容について

    エクセルファイルのVBAを少し手直ししたいのですが、 超初心者で行き詰っております。 下記は全体の一部なのですが、、どんな内容を表しているのか 教えていただけないでしょうか？ 調べてみても、変数を定義して、計算している（？） くらいしかわかりませんでした。 Public Sub abc計算() Dim vi As Class1 Set vi = New Class1 Dim k As Long For k = CLng(vix_ro) To 6 Step -1 If (vi.abc_flg(CLng(k - 1), 6) = True) Then si_to.Cells(CLng(k - 1), 6).Value = "○" End If Next End Sub excel2007　vista使用です。 どうぞよろしくお願い申し上げます。

  • Excelにおけるセルの値をVB2005に配列として取り込みたい

    Excelのセルの値をVB2005に配列として取り込みたいのですが、Excel.Rangeと配列の整合性が取れず困っています。 なんらかヒントになるような助言をお願いします。 以下は今までに作成中のコードです。 Public Class Form1 Dim xlsapp As New Excel.Application Dim xlsbook As Excel.Workbook Dim xlssheet As Excel.Worksheet Dim fn As String = "sample.xls" Dim Q(,,) As Double Dim i, j, x, y, z As Integer Dim k As Double Dim w(i), v(i), u(i) As Double Dim As Object Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click xlsbook = xlsapp.Workbooks.Open(fn) xlssheet = xlsbook.Worksheets(1) k = 1 w(i) = xlssheet.Cells(1, 3) v(i) = xlssheet.Cells(1, 2) u(i) = xlssheet.Cells(1, 1) For x = 2 To 11 If w(i) = 1 Then For y = 2 To 11 If v(i) = 1 Then Q(1, 1, k) = u(i) k = k + 1 End If Next End If Next z = k For k = 1 To z TextBox1.Text = Q(1, 1, k) Next End Sub Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click Me.Close() xlsapp.DisplayAlerts = False xlssheet = Nothing xlsbook.Close() xlsbook = Nothing xlsapp.Quit() xlsapp = Nothing End Sub End Class

  • アクセスの印刷ＶＢＡを教えて下さい

    アクセス初心者です。 バージョンは2002を使っています。 ネットで探して詳しく分からないままプログラムしています。 フォームで印刷のコマンドボタンを作ってそのボタンをクリックすると表示されてる 1ページのみ印刷したいのですが全てのレコードが印刷されてしまいます。 どうすればいいのか教えて下さい。 下記が今現在のＶＢＡです。 Private Sub 印刷_Click() Dim varCopies As Variant varCopies = InputBox("部数を数字で入力してください", "印刷部数の指定") If Len(varCopies) = 0 Then Exit Sub End If If IsNumeric(varCopies) = False Then MsgBox "部数は数字で入力してください", vbOKOnly + vbCritical, "入力エラー" Exit Sub ElseIf CLng(varCopies) = 0 Then MsgBox "部数は0以上で入力してください", vbOKOnly + vbCritical, "入力エラー" Exit Sub End If If MsgBox("印刷しますか？" & vbCrLf & "部数=" & varCopies _ , vbYesNo + vbInformation, "印刷の確認") = vbYes Then DoCmd.OpenForm "伝票", acPreview, , , acFormReadOnly DoCmd.PrintOut acPrintAll, , , , CLng(varCopies) DoCmd.Close acForm, "伝票" End If End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する