Option Explicit
'**********************************************************************
' 機能名 : 暗号化サンプルＡＰ
'
' 機能説明 : 各種暗号化／複合化をテストする
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
' : このプログラムは、日本国著作権法および国際条約により保護
' : されています。このプログラムの全部または一部を無断で複製
' : したり、無断で複製物を頒布すると、著作権の侵害となります
' : のでご注意ください。
'**********************************************************************
'**********************************************************************
' 共通定数定義
'**********************************************************************
'**********************************************************************
' 共通変数定義
'**********************************************************************
' 暗号化ＤＬＬクラスの定義
Private cryptMin As Object
Private cryptDes As Object
Private cryptB64 As Object
Private progress As Object
'**********************************************************************
' メソッド
'**********************************************************************
' @(f)
' 関数名 : Form_Load
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : フォームロード
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub Form_Load()
On Error GoTo ErrHandler
Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' カレントフォルダの変更
SetCurrentDirectory App.Path
' CryptMin.dllの存在チェック
On Error Resume Next
If CreateObject("CryptMin.CryptMinClass") Is Nothing Then
If fso.FileExists("CryptMin.dll") Then
' 暗号化ＤＬＬのレジストリ登録
Shell "regsvr32 /s CryptMin.dll", vbHide
Else
' 暗号化ＤＬＬをＥＸＥと同じフォルダに置いてください。
MsgBox _
"CryptMin.dllが見つかりませんでした。" & vbCrLf & vbCrLf & _
"CryptMin.dllを" & vbCrLf & _
"[" & App.Path & "]" & vbCrLf & _
"に置いてください。"
End
End If
End If
On Error GoTo ErrHandler
' 暗号化ＤＬＬのオブジェクト生成（必須）
Set cryptMin = CreateObject("CryptMin.CryptMinClass")
Set cryptDes = CreateObject("CryptMin.CryptDesClass")
Set cryptB64 = CreateObject("CryptMin.CryptB64Class")
Set progress = CreateObject("CryptMin.ProgressClass")
' 進捗メッセージの表示有無と表示開始までの経過時間設定
Dim flag As Boolean
flag = False
If ProgressCheck.Value = 1 Then flag = True
progress.ProgressInit Me.hWnd, flag, Val(ProgressDelayText)
' ラジオボタンのデフォルト設定
OrgOption(0).Value = True
EncodeOption(0).Value = True
CryptOption(2) = True
Exit Sub
ErrHandler:
If Err.Number = 339 Then
MsgBox "システムエラー" & vbCrLf & _
"ＶＢ６ランタイムがインストールされていない可能性があります。"
Else
MsgBox "システムエラー" & vbCrLf & Err.Description
End If
Exit Sub
End Sub
' @(f)
' 関数名 : Form_Paint
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : フォーム描画時の処理
'
' 備考 : 進捗メッセージが表示中の時は最善面に表示する
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub Form_Paint()
On Error GoTo ErrHandler
If progress Is Nothing = False Then
' 進捗メッセージが表示中の時は最善面に表示する
progress.WindowTopMost
End If
Exit Sub
ErrHandler:
'MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : Command1_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化ボタンクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub Command1_Click()
On Error GoTo ErrHandler
Dim fileNo As Integer
Dim inpStr As String
Dim outStr As String
Dim inpByte() As Byte
Dim outByte() As Byte
Dim kenByte() As Byte
Dim opt(0 To 1) As Boolean
Dim fso As New FileSystemObject
Dim canFlag As Boolean
Dim msg As String
' 暗号化キー入力チェック
If KeyText(0).Text = "" Then
MsgBox "暗号化キーを入力してください。"
Exit Sub
End If
' ファイル名入力チェック
If (OrgOption(1).Value = True And OrgFile.Text = "") Or _
(EncodeOption(1).Value = True And EncodeFile.Text = "") Then
MsgBox "ファイル名を入力してください。"
OrgFile.SetFocus
Exit Sub
End If
opt(0) = OrgOption(0).Value
opt(1) = EncodeOption(0).Value
EncodeText.Text = ""
OrgOption(0).Value = opt(0)
OrgOption(1).Value = Not opt(0)
EncodeOption(0).Value = opt(1)
EncodeOption(1).Value = Not opt(1)
' データ入力処理
canFlag = False
inpStr = ""
outStr = ""
ReDim inpByte(-1 To -1)
ReDim outByte(-1 To -1)
If OrgOption(0).Value = True Then
' 入力がテキストエリアの時
If OrgText.Text = "" Then
MsgBox "オリジナルの文字列を入力してください。"
Exit Sub
End If
inpStr = OrgText.Text
inpByte = StrConv(inpStr, vbFromUnicode)
Else
' 入力がファイル名エリアの時
fileNo = FreeFile
Open OrgFile.Text For Binary As fileNo
If LOF(fileNo) <= 0 Then
Close fileNo
MsgBox "オリジナルのファイルが存在しないか０バイトです。"
Exit Sub
Else
ReDim inpByte(LOF(fileNo) - 1)
Get fileNo, , inpByte
Close fileNo
inpStr = StrConv(inpByte, vbUnicode)
End If
End If
' 進捗メッセージを表示する
progress.ProgressRange 0, 0
progress.ProgressDsp 0, , "暗号化中"
canFlag = progress.GetCancelFlag
' 暗号化処理
If UBound(inpByte) >= 0 Then
If CryptOption(0) Then
' ＤＥＳ＋ＢＡＳＥ６４による暗号化
If canFlag = False Then
progress.ProgressRange 1, 80
kenByte = cryptDes.CryptDesBytes(inpByte, True, KeyText(0).Text)
canFlag = progress.GetCancelFlag
If canFlag = False Then
progress.ProgressRange 80, 99
outStr = cryptB64.Base64Encode(kenByte)
canFlag = progress.GetCancelFlag
outByte = StrConv(outStr, vbFromUnicode)
End If
End If
ElseIf CryptOption(1) Then
' トリプルＤＥＳ＋ＢＡＳＥ６４による暗号化
If canFlag = False Then
progress.ProgressRange 1, 80
kenByte = cryptDes.Crypt3DesBytes(inpByte, True, _
KeyText(0).Text, KeyText(1).Text, KeyText(2).Text)
canFlag = progress.GetCancelFlag
If canFlag = False Then
progress.ProgressRange 80, 99
outStr = cryptB64.Base64Encode(kenByte)
canFlag = progress.GetCancelFlag
outByte = StrConv(outStr, vbFromUnicode)
End If
End If
Else
' 独自の暗号化
If canFlag = False Then
progress.ProgressRange 1, 99
kenByte = cryptMin.CryptMinBytes(inpByte, True, KeyText(0).Text)
outByte = kenByte
canFlag = progress.GetCancelFlag
If UBound(outByte) >= 0 Then
outStr = StrConv(outByte, vbUnicode)
End If
End If
End If
End If
' エラーチェック
If canFlag Then
' キャンセルされた場合は以降の処理を中止する
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox "暗号化を中止しました。"
Exit Sub
Else
If UBound(outByte) < 0 Then
' 進捗メッセージを閉じる
progress.ProgressDsp 100
' エラーメッセージ表示
MsgBox "エラーが発生しました。" & vbCrLf & _
"入力データが正しい事を確認してください。"
Exit Sub
Else
If KenshouCheck.Value = 1 Then
' 検証開始
' 進捗メッセージを閉じる
progress.ProgressDsp 100
progress.ProgressDsp 0, , "検証中", True
progress.ProgressRange 1, 99
msg = KenshouFunc(inpByte, kenByte)
If msg <> "" Then
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox msg
Exit Sub
End If
End If
End If
End If
' データ出力処理
If EncodeOption(0).Value = True Then
' 出力がテキストエリアの時
EncodeText.Text = outStr
' 進捗メッセージを閉じる
progress.ProgressDsp 100
Else
If UBound(outByte) >= 0 Then
' 出力がファイル名エリアの時
If fso.FileExists(EncodeFile.Text) Then
fso.DeleteFile EncodeFile.Text
End If
fileNo = FreeFile
Open EncodeFile.Text For Binary As fileNo
Put fileNo, , outByte
Close fileNo
End If
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox "暗号化が完了しました。"
End If
Exit Sub
ErrHandler:
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : CryptOption_Click
'
' 返り値 : エラーメッセージ（正常時は空文字列””）
'
' 引き数 : orgByte (i) : オリジナルデータ
' : kenByte (i) : オリジナルデータを暗号化したデータ
'
' 機能説明 : 暗号化と複合化の検証
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Function KenshouFunc(orgByte() As Byte, kenByte() As Byte) As String
On Error GoTo ErrHandler
Dim i As Long
Dim tmpByte() As Byte
Dim canFlag As Boolean
KenshouFunc = ""
If CryptOption(0) Then
' ＤＥＳによる復号化の検証
tmpByte = cryptDes.CryptDesBytes(kenByte, False, KeyText(0).Text)
canFlag = progress.GetCancelFlag
ElseIf CryptOption(1) Then
' トリプルＤＥＳによる復号化の検証
tmpByte = cryptDes.Crypt3DesBytes(kenByte, False, _
KeyText(0).Text, KeyText(1).Text, KeyText(2).Text)
canFlag = progress.GetCancelFlag
Else
' 独自の復号化による検証
tmpByte = cryptMin.CryptMinBytes(kenByte, False, KeyText(0).Text)
canFlag = progress.GetCancelFlag
End If
If canFlag Then
' キャンセルされた場合は以降の処理を中止する
KenshouFunc = "検証を中止しました。"
Exit Function
Else
' 検証エラーチェック
For i = 0 To UBound(orgByte)
If orgByte(i) <> tmpByte(i) Then
KenshouFunc = "検証失敗（復号データ誤り）" & vbCrLf & _
"暗号化処理で原因不明のエラーが発生しました。"
Exit Function
End If
Next i
End If
Exit Function
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Function
End Function
' @(f)
' 関数名 : Command2_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 複合化ボタンクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub Command2_Click()
On Error GoTo ErrHandler
Dim fileNo As Integer
Dim inpStr As String
Dim outStr As String
Dim inpByte() As Byte
Dim outByte() As Byte
Dim tmpByte() As Byte
Dim opt(0 To 1) As Boolean
Dim fso As New FileSystemObject
Dim canFlag As Boolean
' 暗号化キー入力チェック
If KeyText(0).Text = "" Then
MsgBox "暗号化キーを入力してください。"
Exit Sub
End If
' ファイル名入力チェック
If (OrgOption(1).Value = True And OrgFile.Text = "") Or _
(EncodeOption(1).Value = True And EncodeFile.Text = "") Then
MsgBox "ファイル名を入力してください。"
OrgFile.SetFocus
Exit Sub
End If
opt(0) = OrgOption(0).Value
opt(1) = EncodeOption(0).Value
OrgText.Text = ""
OrgOption(0).Value = opt(0)
OrgOption(1).Value = Not opt(0)
EncodeOption(0).Value = opt(1)
EncodeOption(1).Value = Not opt(1)
' データ入力処理
canFlag = False
inpStr = ""
outStr = ""
ReDim inpByte(-1 To -1)
ReDim outByte(-1 To -1)
If EncodeOption(0).Value = True Then
' 入力がテキストエリアの時
If EncodeText.Text = "" Then
MsgBox "暗号化した文字列を入力してください。"
Exit Sub
End If
inpStr = EncodeText.Text
inpByte = StrConv(inpStr, vbFromUnicode)
Else
' 入力がファイル名エリアの時
fileNo = FreeFile
Open EncodeFile.Text For Binary As fileNo
If LOF(fileNo) <= 0 Then
Close fileNo
MsgBox "暗号化したファイルが存在しないか０バイトです。"
Exit Sub
Else
ReDim inpByte(LOF(fileNo) - 1)
Get fileNo, , inpByte
Close fileNo
inpStr = StrConv(inpByte, vbUnicode)
End If
End If
' 進捗メッセージを表示する
progress.ProgressRange 0, 0
progress.ProgressDsp 0, , "復号化中"
canFlag = progress.GetCancelFlag
' 復号化処理
If UBound(inpByte) >= 0 Then
If CryptOption(0) Then
' 文字列のＤＥＳ＋ＢＡＳＥ６４による復号化
progress.ProgressRange 1, 20
tmpByte = cryptB64.Base64Decode(inpStr)
canFlag = progress.GetCancelFlag
If canFlag = False Then
progress.ProgressRange 20, 99
outByte = cryptDes.CryptDesBytes(tmpByte, False, KeyText(0).Text)
outStr = StrConv(outByte, vbUnicode)
canFlag = progress.GetCancelFlag
End If
ElseIf CryptOption(1) Then
' 文字列のトリプルＤＥＳ＋ＢＡＳＥ６４による復号化
progress.ProgressRange 1, 20
tmpByte = cryptB64.Base64Decode(inpStr)
canFlag = progress.GetCancelFlag
If canFlag = False Then
progress.ProgressRange 20, 99
outByte = cryptDes.Crypt3DesBytes(tmpByte, False, _
KeyText(0).Text, KeyText(1).Text, KeyText(2).Text)
outStr = StrConv(outByte, vbUnicode)
canFlag = progress.GetCancelFlag
End If
Else
' 文字列の独自の復号化
progress.ProgressRange 1, 99
outByte = cryptMin.CryptMinBytes(inpByte, False, KeyText(0).Text)
canFlag = progress.GetCancelFlag
If UBound(outByte) >= 0 Then
outStr = StrConv(outByte, vbUnicode)
End If
End If
End If
' エラーチェック
If canFlag Then
' キャンセルされた場合は以降の処理を中止する
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox "暗号化を中止しました。"
Exit Sub
Else
If UBound(outByte) < 0 Then
' 進捗メッセージを閉じる
progress.ProgressDsp 100
' エラーメッセージ表示
MsgBox "エラーが発生しました。" & vbCrLf & _
"入力データが正しい事を確認してください。"
Exit Sub
End If
End If
' データ出力処理
If OrgOption(0).Value = True Then
' 出力がテキストエリアの時
OrgText.Text = outStr
' 進捗メッセージを閉じる
progress.ProgressDsp 100
Else
' 完了メッセージ表示
If canFlag Then
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox "復号化を中止しました。"
Else
If UBound(outByte) >= 0 Then
' 出力がファイル名エリアの時
If fso.FileExists(OrgFile.Text) Then
fso.DeleteFile OrgFile.Text
End If
fileNo = FreeFile
Open OrgFile.Text For Binary As fileNo
Put fileNo, , outByte
Close fileNo
End If
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox "複合化が完了しました。"
End If
End If
Exit Sub
ErrHandler:
' 進捗メッセージを閉じる
progress.ProgressDsp 100
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : OrgSanshou_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : オリジナルファイル参照ボタンクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub OrgSanshou_Click()
On Error GoTo ErrHandler
CommonDialog1.Filter = "全てのﾌｧｲﾙ(*.*)|*.*"
CommonDialog1.CancelError = True
CommonDialog1.ShowOpen
OrgFile.Text = CommonDialog1.FileName
Exit Sub
ErrHandler:
If Err.Number = cdlCancel Then
' コモンダイアログのキャンセルボタンクリック
Exit Sub
End If
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : EncodeSanshou_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化ファイル参照ボタンクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub EncodeSanshou_Click()
On Error GoTo ErrHandler
CommonDialog1.Filter = "全てのﾌｧｲﾙ(*.*)|*.*"
CommonDialog1.CancelError = True
CommonDialog1.ShowOpen
EncodeFile.Text = CommonDialog1.FileName
Exit Sub
ErrHandler:
If Err.Number = cdlCancel Then
' コモンダイアログのキャンセルボタンクリック
Exit Sub
End If
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : OrgText_Change
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : オリジナルテキスト変更時
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub OrgText_Change()
On Error GoTo ErrHandler
OrgOption(0).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : EncodeText_Change
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化テキスト変更時
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub EncodeText_Change()
On Error GoTo ErrHandler
EncodeOption(0).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : OrgText_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : オリジナルテキストクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub OrgText_Click()
On Error GoTo ErrHandler
OrgOption(0).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : EncodeText_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化テキストクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub EncodeText_Click()
On Error GoTo ErrHandler
EncodeOption(0).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : OrgFile_Change
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : オリジナルファイル変更時
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub OrgFile_Change()
On Error GoTo ErrHandler
OrgOption(1).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : EncodeFile_Change
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化ファイル変更時
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub EncodeFile_Change()
On Error GoTo ErrHandler
EncodeOption(1).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : OrgFile_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : オリジナルファイルクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub OrgFile_Click()
On Error GoTo ErrHandler
OrgOption(1).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : EncodeFile_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化ファイルクリック
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub EncodeFile_Click()
On Error GoTo ErrHandler
EncodeOption(1).Value = True
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : OrgExec_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : オリジナルファイルの実行
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub OrgExec_Click()
On Error GoTo ErrHandler
ExecuteFile OrgFile.Text
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : EncodeExec_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化ファイルの実行
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub EncodeExec_Click()
On Error GoTo ErrHandler
ExecuteFile EncodeFile.Text
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : CryptOption_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 暗号化方式の選択
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub CryptOption_Click(Index As Integer)
On Error GoTo ErrHandler
If Index <> 1 Then
KeyText(0).Width = KeyText(2).Left + KeyText(2).Width - KeyText(0).Left
KeyText(0).Visible = True
KeyText(1).Visible = False
KeyText(2).Visible = False
Else
KeyText(0).Width = KeyText(2).Width
KeyText(0).Visible = True
KeyText(1).Visible = True
KeyText(2).Visible = True
End If
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : ProgressCheck_Click
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 進捗表示有無の選択
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub ProgressCheck_Click()
On Error GoTo ErrHandler
' 進捗メッセージの表示有無と表示開始までの経過時間設定
Dim flag As Boolean
flag = False
If ProgressCheck.Value = 1 Then flag = True
progress.ProgressInit Me.hWnd, flag, Val(ProgressDelayText)
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : ProgressDelayText_Change
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 進捗表示開始時間の変更
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub ProgressDelayText_Change()
On Error GoTo ErrHandler
' 進捗メッセージの表示有無と表示開始までの経過時間設定
Dim flag As Boolean
flag = False
If ProgressCheck.Value = 1 Then flag = True
progress.ProgressInit Me.hWnd, flag, Val(ProgressDelayText)
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
' @(f)
' 関数名 : ProgressDelayText_KeyUp
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : 進捗表示開始時間のキーボード入力
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Private Sub ProgressDelayText_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo ErrHandler
' 進捗メッセージの表示有無と表示開始までの経過時間設定
Dim flag As Boolean
flag = False
If ProgressCheck.Value = 1 Then flag = True
progress.ProgressInit Me.hWnd, flag, Val(ProgressDelayText)
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
★CryptMin暗号化ライブラリ(VB6版)サンプルＡＰ(MainModule.bas)
Option Explicit
'**********************************************************************
' 機能名 : 暗号化サンプルＡＰ共通モジュール
'
' 機能説明 : メインおよび共通関数
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
' : このプログラムは、日本国著作権法および国際条約により保護
' : されています。このプログラムの全部または一部を無断で複製
' : したり、無断で複製物を頒布すると、著作権の侵害となります
' : のでご注意ください。
'**********************************************************************
'**********************************************************************
' ＷＩＮ３２ＡＰＩ定義
'**********************************************************************
' カレントディレクトリを変更するAPI
Public Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" ( _
ByVal CurrentDir As String) As Long
'デスクトップウィンドウのハンドル取得
Public Declare Function GetDesktopWindow Lib "USER32" () As Long
'指定されたファイルの実行
Public Const SW_SHOW = 5
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'**********************************************************************
' メソッド
'**********************************************************************
' @(f)
' 関数名 : Main
'
' 返り値 : 無し
'
' 引き数 : 無し
'
' 機能説明 : メイン関数
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Public Sub Main()
On Error GoTo ErrHandler
MainForm.Show
Exit Sub
ErrHandler:
If Err.Number = 339 Then
MsgBox "システムエラー" & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
"ＶＢ６ランタイムがインストールされていない可能性があります。"
Else
MsgBox "システムエラー" & vbCrLf & Err.Description
End If
Exit Sub
End Sub
' @(f)
' 機能名 : ExecuteFile
'
' 返り値 : 無し
'
' 引き数 : fname (i) : 実行するファイル
'
' 機能説明 : 指定されたファイルを実行する
'
' 備考 :
'
' 著作権 : Copyright(C) 2006 のん All right reserved
'
Public Sub ExecuteFile(ByVal fname As String)
On Error GoTo ErrHandler
Dim fso As FileSystemObject
Dim ret As Long
If fname <> "" Then
ret = ShellExecute(GetDesktopWindow, "open", fname, vbNullString, "", SW_SHOW)
If ret <= 32 Then
MsgBox "指定のファイルを起動出来ませんでした。"
End If
End If
Exit Sub
ErrHandler:
MsgBox "システムエラー" & vbCrLf & Err.Description
Exit Sub
End Sub
