Attribute VB_Name = "nMailCheckerModule" Option Explicit '受信バッファサイズ Public Const RECV_BUFF_SIZE As Long = 1024 'アクセスポート Public Const ACCESS_PORT As Integer = 110 '通常ＩＰアドレス Public Const INADDR_ANY As Long = &H0 'internetwork: UDP, TCP, etc. Public Const AF_INET = 2 'stream socket Public Const SOCK_STREAM = 1 'Windowsソケット初期化情報 Public Type WSAData wVersion As Integer wHighVersion As Integer szDescription(256) As Byte szSystemStatus(128) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As String End Type Public WinsockInfo As WSAData 'ソケットアドレス Public Type in_addr S_addr As Long End Type 'ソケット情報 Public Type sockaddr_in sin_family As Integer sin_port As Integer sin_addr As in_addr sin_zero(7) As Byte End Type 'ホスト情報 Type hostent h_name As Long h_aliases As Long h_addrtype As Integer h_length As Integer h_addr_list As Long End Type 'ソケットセットアップ Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequested As Integer, lpWSAData As WSAData) As Long 'ソケットを作成 Declare Function socket Lib "WSOCK32.DLL" (ByVal af As Long, ByVal lngType As Long, ByVal protocol As Long) As Long 'ホスト変換 Declare Function htons Lib "WSOCK32.DLL" (ByVal hostshort As Integer) As Integer 'バインド Declare Function bind Lib "WSOCK32.DLL" (ByVal s As Long, name As sockaddr_in, ByVal namelen As Long) As Long 'ソケット接続受け入れ Declare Function listen Lib "WSOCK32.DLL" (ByVal s As Long, ByVal backlog As Long) As Long 'ソケット接続待ち Declare Function WSAAccept Lib "WSOCK32.DLL" (ByVal s As Long, addr As Any, addrlen As Long, ByVal lpfnCondition As Long, ByVal dwCallbackData As Long) As Long 'ソケット受信 Declare Function recv Lib "WSOCK32.DLL" (ByVal s As Long, ByVal buf As String, ByVal namelen As Long, ByVal flags As Long) As Long 'ソケットクローズ Declare Function closesocket Lib "WSOCK32.DLL" (ByVal s As Long) As Long 'ソケットクリーンアップ Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long 'ホスト名取得 Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal name As String) As Long 'ムーブメモリー Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 'ソケット接続 Declare Function connect Lib "WSOCK32.DLL" (ByVal s As Long, name As sockaddr_in, ByVal namelen As Long) As Long 'ソケット送信 Declare Function send Lib "WSOCK32.DLL" (ByVal s As Long, ByVal buf As String, ByVal namelen As Long, ByVal flags As Long) As Long 'スリープ Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) Public Declare Function WSAAsyncGetHostByName Lib "WSOCK32.DLL" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal host_name As String, buf As Any, ByVal buflen As Long) As Long Public Const WM_USER = &H400 Public Const WM_WSAAsyncGetHostByName = WM_USER + 1000 Public Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal s As String) As Long 'NOTIFYICONDATA構造体 Public Type NOTIFYICONDATA cbSize As Long 'NOTIFYICONDATA構造体のサイズ hWnd As Long '通知メッセージを受けるウィンドウハンドル uID As Long 'タスクバーアイコンのアプリケーションが定義された識別子 uFlags As Long 'その他のメンバーのどれが有効なデータを含むかを示すフラグ uCallbackMessage As Long 'マウス・イベントが返ってくるコールバックメッセージ hIcon As Long '追加・修正・削除するアイコンのハンドル szTip(63) As Byte 'トレイのアイコンに表示するツールチップテキスト End Type 'Shell_NotifyIcon 関数に関連する定数 Public Const NIM_ADD = &H0 'タスクトレイにアイコンを追加します Public Const NIM_DELETE = &H2 'タスクトレイのアイコン、ツールチップテキスト、通知メッセージを変更します Public Const NIM_MODIFY = &H1 'タスクトレイからアイコンを削除します Public Const NIF_ICON = &H2 'hIconメンバーは有効です Public Const NIF_MESSAGE = &H1 'uCallbackMessageメンバーは有効です Public Const NIF_TIP = &H4 'szTipメンバーは有効です 'マウス関連の通知メッセージ定数 Public Const WM_MOUSEMOVE = &H200 'マウスムーブ Public Const WM_LBUTTONDOWN = &H201 '左ボタンダウン Public Const WM_LBUTTONUP = &H202 '左ボタンアップ Public Const WM_LBUTTONDBLCLK = &H203 '左ボタンダブルクリック Public Const WM_RBUTTONDOWN = &H204 '右ボタンダウン Public Const WM_RBUTTONUP = &H205 '右ボタンアップ Public Const WM_RBUTTONDBLCLK = &H206 '右ボタンダブルクリック Public Const WM_MBUTTONDOWN = &H207 '中央ボタンダウン Public Const WM_MBUTTONUP = &H208 '中央ボタンアップ Public Const WM_MBUTTONDBLCLK = &H209 '中央ボタンダブルクリック 'レジストリキー定数 Public Const HKEY_CLASSES_ROOT = &H80000000 Public Const HKEY_CURRENT_USER = &H80000001 Public Const HKEY_CURRENT_CONFIG = &H80000005 Public Const HKEY_DYN_DATA = &H80000006 Public Const HKEY_LOCAL_MACHINE = &H80000002 Public Const HKEY_USERS = &H80000003 Public Const ERROR_SUCCESS = 0& Public Const READ_CONTROL = &H20000 Public Const STANDARD_RIGHTS_READ = (READ_CONTROL) Public Const STANDARD_RIGHTS_WRITE = (READ_CONTROL) Public Const SYNCHRONIZE = &H100000 Public Const STANDARD_RIGHTS_ALL = &H1F0000 Public Const KEY_CREATE_LINK = &H20 Public Const KEY_CREATE_SUB_KEY = &H4 Public Const KEY_ENUMERATE_SUB_KEYS = &H8 Public Const KEY_NOTIFY = &H10 Public Const KEY_QUERY_VALUE = &H1 Public Const KEY_SET_VALUE = &H2 Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE)) Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) Public Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE)) Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE)) 'タスクトレイのアイコンを追加・修正・削除 Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long 'レジストリキーを開く Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long 'レジストリ情報を読取 Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Public Declare Function SHEnumKeyEx Lib "SHLWAPI.DLL" Alias "SHEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal pszName As String, pcchName As Long) As Long 'レジストリキーを閉じる Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long 'ユーザ構造体 Public Type SettingUserInfo UserID As String 'ユーザＩＤ Password As String 'パスワード ServerAddress As String 'サーバアドレス MailerFlg As Long '起動メーラー選択フラグ NormalMailerPath As String '標準メーラー起動パス MailerPath As String '独自メーラー起動パス MailCheckInterval As String 'チェック間隔 LastUpdate As String '最終更新日付 CheckSum As String 'チェックサム End Type Public gtypUser As SettingUserInfo 'レジストリ書込み位置 Public Const REG_DIR_NAME As String = "soniun" Public bytPA() As Byte Public Function MAKEWORD(ByVal strA As Byte, ByVal strB As Byte) As Integer 'ビットシフト MAKEWORD = CInt(strA) Or CInt(strB) * 2 ^ 8 End Function Public Function PathConvertEnviron(ByVal strNormalPath As String) As String Dim strWork As String Dim strPathWork As String Dim lngPathPoint As Long '編集する文字列を設定 strPathWork = strNormalPath strWork = "" '％が無くなるまで繰り返す Do While InStr(1, strPathWork, "%", vbTextCompare) > 0 '％の位置を取得 lngPathPoint = InStr(1, strPathWork, "%", vbTextCompare) '％より前に文字列がある場合 If lngPathPoint > 1 Then '文字列を追加 strWork = strWork & Left(strPathWork, lngPathPoint - 1) '追加した文字列を削除 strPathWork = Mid(strPathWork, lngPathPoint + 1) End If '後方の％を検索 lngPathPoint = InStr(1, strPathWork, "%", vbTextCompare) 'ウィンドウズ標準設定より正式パスを取得 strWork = strWork & Environ(Left(strPathWork, lngPathPoint - 1)) '変換した部分の文字列を削除 strPathWork = Mid(strPathWork, lngPathPoint + 1) Loop '後方の文字列を追加 strWork = strWork & strPathWork 'パラメータがある場合は削除 If InStr(1, strWork, "/", vbTextCompare) > 0 Then strWork = Trim(Left(strWork, InStr(1, strWork, "/", vbTextCompare) - 1)) End If '戻り値を設定 PathConvertEnviron = strWork End Function Public Function RegisterNormalStringRead(ByVal lngRootLocate As Long, ByVal strRegisterPath As String) As String Dim lngRet As Long Dim lngRegLen As Long Dim lngRegHand As Long Dim strRegData As String '戻り値初期化 RegisterNormalStringRead = strRegisterPath 'レジストリオープン lngRet = RegOpenKeyEx(lngRootLocate, strRegisterPath, 0, KEY_ALL_ACCESS, lngRegHand) 'オープン成功の場合 If lngRet = ERROR_SUCCESS Then 'キー情報読込 lngRegLen = 512 strRegData = String(lngRegLen, vbNullChar) 'レジストリより標準を読み込み lngRet = RegQueryValueEx(lngRegHand, "", 0, ByVal 0, ByVal strRegData, lngRegLen) '戻り値に標準を設定 RegisterNormalStringRead = Left(strRegData, lngRegLen - 1) 'レジストリクローズ lngRet = RegCloseKey(lngRegHand) End If 'レジストリ読込手法２ ' 'レジストリ読込 ' Set WshShell = CreateObject("WScript.Shell") ' 'レジストリ情報取得 ' RegisterNormalStringRead = WshShell.RegRead(strRegisterPath) ' Set WshShell = Nothing End Function Public Sub RegisterEdit(ByVal lngRegMode As Long, ByVal RegisterDir As String, ByVal RegisterApp As String) 'レジストリ操作 Select Case lngRegMode Case 1000 'レジストリ読込 gtypUser.UserID = GetSetting(RegisterDir, RegisterApp, "UserID", "") gtypUser.Password = GetSetting(RegisterDir, RegisterApp, "Password", "") gtypUser.ServerAddress = GetSetting(RegisterDir, RegisterApp, "ServerAddress", "") gtypUser.MailCheckInterval = GetSetting(RegisterDir, RegisterApp, "MailCheckInterval", "3") gtypUser.MailerFlg = GetSetting(RegisterDir, RegisterApp, "MailerFlg", "0") gtypUser.NormalMailerPath = GetSetting(RegisterDir, RegisterApp, "NormalMailerPath", "") gtypUser.MailerPath = GetSetting(RegisterDir, RegisterApp, "MailerPath", "") gtypUser.LastUpdate = GetSetting(RegisterDir, RegisterApp, "LastUpdate", "") gtypUser.CheckSum = GetSetting(RegisterDir, RegisterApp, "CheckSum", "") Case 2000 'レジストリ書込 Call SaveSetting(RegisterDir, RegisterApp, "UserID", gtypUser.UserID) Call SaveSetting(RegisterDir, RegisterApp, "Password", gtypUser.Password) Call SaveSetting(RegisterDir, RegisterApp, "ServerAddress", gtypUser.ServerAddress) Call SaveSetting(RegisterDir, RegisterApp, "MailCheckInterval", gtypUser.MailCheckInterval) Call SaveSetting(RegisterDir, RegisterApp, "MailerFlg", gtypUser.MailerFlg) Call SaveSetting(RegisterDir, RegisterApp, "NormalMailerPath", gtypUser.NormalMailerPath) Call SaveSetting(RegisterDir, RegisterApp, "MailerPath", gtypUser.MailerPath) Call SaveSetting(RegisterDir, RegisterApp, "LastUpdate", gtypUser.LastUpdate) Call SaveSetting(RegisterDir, RegisterApp, "CheckSum", 255) Case 9000 'レジストリ削除 Call DeleteSetting(RegisterDir, RegisterApp, "UserID") Call DeleteSetting(RegisterDir, RegisterApp, "Password") Call DeleteSetting(RegisterDir, RegisterApp, "ServerAddress") Call DeleteSetting(RegisterDir, RegisterApp, "MailCheckInterval") Call DeleteSetting(RegisterDir, RegisterApp, "MailerFlg") Call DeleteSetting(RegisterDir, RegisterApp, "NormalMailerPath") Call DeleteSetting(RegisterDir, RegisterApp, "MailerPath") Call DeleteSetting(RegisterDir, RegisterApp, "LastUpdate") Call DeleteSetting(RegisterDir, RegisterApp, "CheckSum") '全削除 Call DeleteSetting(RegisterDir, RegisterApp) Case Else Exit Sub End Select End Sub