ロゴ（図形）の濃度を変更する方法
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
' ' 'メニュー画面処理 '####################################################################### 'ロゴ濃度設定 '####################################################################### Sub ChngLogoBrightns() Dim i_NoudoPercentDefault As Integer Dim i_NoudoPercent01 As Variant Dim d_NoudoData01 As Double '2024/10/02 修正・追加 パスワード保護機能を追加したため。 Dim s_PassWdInput01 As String Dim s_PassWdSvr01 As String '2024/10/31 修正追加 Dim Answ01 As String '濃度を指定するインプットボックスに値を入れるときに、 '半角英数モードに戻したいため。 '2024/11/12 修正追加 Dim i_GenzaiNoudo As Integer Dim i_Answ02 As Integer '上の２行は、「プログラムの最初に現在の濃度を知りたい」ので、そのチェックプログラム用の変数。 Dim s_LogoTitle As String 'どのロゴの濃度を変えるかをメッセージに出したいので、そのための変数。 On Error GoTo error1: '2024/11/12 修正追加 'プログラムの最初に、現在の濃度を知りたいので、そのチェックプログラム Let i_GenzaiNoudo = Worksheets("マスタシート").Range("P2").Value Let s_LogoTitle = Worksheets("マスタシート").Range("O2").Value Let i_Answ02 = MsgBox("現在のロゴ濃度は「 " & i_GenzaiNoudo & " 」です。" _ & vbCrLf & "" _ & vbCrLf & "変更しますか？" _ & vbCrLf & "" _ & vbCrLf & "変更する場合は「はい」を、しない場合は「いいえ」を押してください。" _ & vbCrLf & "", vbYesNo + vbExclamation + vbDefaultButton2, "最後の確認") If i_Answ02 = 6 Then ElseIf i_Answ02 = 7 Then Exit Sub Else Exit Sub End If '2024/10/02 修正・追加 パスワード保護機能を追加したため。 Let s_PassWdSvr01 = Read_ByDaoGetPasswd01( _ "\\data1\TYDATA\売上管理\#OPENや接触や操作厳禁\各種設定01.xls", _ "SELECT パスワード FROM [設定01$] WHERE 機能名 = '東邦ガスロゴ濃度設定'") Let s_PassWdInput01 = InputBox("パスワードを入力してください。", "パスワード入力") '2024/10/02 修正・追加 パスワード保護機能を追加したため。 If s_PassWdInput01 = s_PassWdSvr01 Then 'パスワードが合っていたらOK。 '何もしないで次へ。 ElseIf s_PassWdInput01 = "" Then 'キャンセルのとき、終わる。 Exit Sub Else MsgBox "パスワードが違います。" Exit Sub End If '2024/10/31 修正追加 濃度を指定するインプットボックスに値を入れるときに、半角英数モードに戻したいため。 '●チェック01 If IMEStatus = vbIMEModeOff Then 'すでにオフなら何もしない。 ElseIf IMEStatus = 2 Then 'vbIMEOffもvbIMEModeOffも「２」なので、一応、誤作動防止で追加した。 Else 'オンやひらがなの場合は,オフにする。 SendKeys "{kanji}", True 'とりあえず、今回はTrueを書かないと、モードが切り替わらなかった。 End If '↑IMEモードがオフならそのままで、オフ以外ならオフにする。 '「SendKeys "{kanji}"」は「半角/全角」キーを押すのと同じ。 '2024/10/31 修正追加 ここまで ' Worksheets("メニュー").Unprotect '2024/11/09 修正追加 ' Let i_NoudoPercentDefault = Worksheets("メニュー").Range("D1").Value '2024/11/09 修正追加 Let i_NoudoPercentDefault = Worksheets("マスタシート").Range("P2").Value Let i_NoudoPercent01 = InputBox(" 「" & s_LogoTitle & "」 のロゴの濃度をパーセンテージで指定してください。" & vbCrLf & "50以上で薄く・50以下で濃くなります。" & vbCrLf & "初期値は50です。" & vbCrLf & "OKボタン押下後の設定反映に10～20秒ほどかかります。") '入力された値が、「数字のみ」かどうかのチェック。（全角の数字も許可。） If IsNumeric(i_NoudoPercent01) = True Then Let i_NoudoPercent01 = CInt(i_NoudoPercent01) ElseIf IsNumeric(i_NoudoPercent01) = False Then 'キャンセルが押されたときも、ここに含まれる。 MsgBox "数字以外が入力されたか、キャンセルされました。最初からやり直してください。" Exit Sub Else End If 'Stop If i_NoudoPercent01 = 0 Then '0が入力されたとき、終わる。 MsgBox "「0」以外の整数を入力してください。最初からやりなおしてください。" '少数でもエラー出ないけど。 Exit Sub ElseIf 1 <= i_NoudoPercent01 Then '何らかの数値（＝濃度）が指定されていたらOK。 '何もしないで次へ。 Else MsgBox "エラーです。管理者に連絡してください。" Exit Sub End If ' Let Worksheets("メニュー").Range("D1").Value = i_NoudoPercent01 '2024/11/09 修正追加 Let Worksheets("マスタシート").Range("P2").Value = i_NoudoPercent01 ' Call Worksheets("メニュー").Protect '2024/11/09 修正追加 d_NoudoData01 = i_NoudoPercent01 / 100 ' Worksheets("Ｐ見積書").Pictures("くらしショップロゴ01").ShapeRange.PictureFormat.Brightness = d_NoudoData01 Call ShapeBrightnsCange("Ｐ見積書", "くらしショップロゴ01", d_NoudoData01) ThisWorkbook.Save MsgBox "完了しました。" Exit Sub error1: Debug.Print Err.Number Debug.Print Err.Description Debug.Print i_NoudoPercent01 ' If i_NoudoPercent01 = 0 Then Exit Sub Let i_NoudoPercent01 = i_NoudoPercentDefault Let Worksheets("マスタシート").Range("P2").Value = i_NoudoPercent01 ' Call Worksheets("メニュー").Protect '2024/11/09 修正追加 '2024/11/09 修正追加 d_NoudoData01 = i_NoudoPercent01 / 100 ' Worksheets("Ｐ見積書").Pictures("くらしショップロゴ01").ShapeRange.PictureFormat.Brightness = d_NoudoData01 Call ShapeBrightnsCange("Ｐ見積書", "くらしショップロゴ01", d_NoudoData01) ThisWorkbook.Save MsgBox "エラーです。管理者の方に連絡してください。" End Sub ============================================================= Sub ShapeBrightnsCange(s_WsNm As String, s_ShapeNm As String, d_NoudoNum01 As Double) Worksheets(s_WsNm).Pictures(s_ShapeNm).ShapeRange.PictureFormat.Brightness = d_NoudoNum01 '生の数値を指定するときは、１００で割らないとエラーになる。 End Sub ============================================================= Function Read_ByDaoGetPasswd01(s_SrcWbNm As String, _ s_SqlStr As String) As String '参照設定でMicrosoft DAO 3.6 Object Library にチェックを入れておく。 Dim o_Db01 As DAO.Database '読込対象のXLSファイル用のDAOオブジェクト用の変数 Dim o_RsWsSettei01 As DAO.Recordset '読込対象のシートのDAOオブジェクト用の変数 ' Dim s_SrcWbNm As String '読込対象のXLSファイルのフルパス格納用の変数 ' Dim s_SrcWsNm As String '今回、不要。 読込対象のシート名の格納用の変数 '' Dim StrData01 As String 'Debug.Print用 ' Dim s_SqlStr As String '読込対象としたいXLSファイルのフルパスを指定する ' s_SrcWbNm = "D:\DAOテスト.xls" ' s_SrcWbNm = "\\data1\TYDATA\売上管理\#OPENや接触や操作厳禁\各種設定01.xls" '読込対象としたいシートの名前を指定する ' s_SrcWsNm = "設定01$" '「Sheet1」をシステムテーブルとして読み込む。 '「$」を付けるとシステムテーブルになる。 'データベースファイル(s_SrcWbNm)を開く。ここではxlsファイル。（＝DAOとしてのデータベースを定義） 'HDR=NO →1行目を読込む。（すべてのシートで） 'HDR=YES →1行目を読込まない。（すべてのシートで） 'IMEX=1→表示されているセル書式の値でデータを吸い込む。 ' ただし、https://support.microsoft.com/ja-jp/help/194124/prb-excel-values-returned-as-null-using-dao-openrecordset ' や http://blog.sorceryforce.net/?p=154 を参照 'Excel 8.0→「VBA Excel バージョン番号」でGoogle検索。 ' 8.0で2000でも2010でも動いた。 ' Set o_Db01 = OpenDatabase(s_SrcWbNm, False, False, "Excel 8.0;HDR=NO;IMEX=1") Set o_Db01 = OpenDatabase(s_SrcWbNm, False, False, "Excel 8.0;HDR=YES;IMEX=1") ' '読み込み対象のシートをレコードセット化する。 '' Set o_RsWsSettei01 = o_Db01.OpenRecordset(s_SrcWsNm) ' Set o_RsWsSettei01 = o_Db01.OpenRecordset("SELECT パスワード FROM [設定01$] WHERE 機能名 = '東邦ガスロゴ濃度設定'") Set o_RsWsSettei01 = o_Db01.OpenRecordset(s_SqlStr) ' Debug.Print o_RsWsSettei01.Fields(0) Let Read_ByDaoGetPasswd01 = o_RsWsSettei01.Fields(0) ' 'レコードセット化したシートの内容の読み込みテスト ' Do Until o_RsWsSettei01.EOF ' ' With o_RsWsSettei01 'A列・B列・C列のデータを取得 ' ' '「HDR=NO」＝1行目を列名として読み込まない場合その1→列名を「Index番号」で表現して変数に吸い込む '' StrData01 = StrData01 & .Fields(0) & vbTab & .Fields(1) & vbTab & .Fields(2) & vbCrLf ' ' '「HDR=NO」＝1行目を列名として読み込まない場合その2→列名を「システムテーブルとしての列名」で表現して変数に吸い込む '' StrData01 = StrData01 & .Fields("F1") & vbTab & .Fields("F2") & vbTab & .Fields("F3") & vbCrLf ' ' '「HDR=YES」＝1行目を列名として読み込む場合→列名を1行目の「セルの列名」で表現して変数に吸い込む '' StrData01 = StrData01 & .Fields("リスト番号") & _ '' vbTab & .Fields("社員コード") & _ '' vbTab & .Fields("氏名") & _ '' vbTab & .Fields("リストに表示される値") & vbCrLf ' ' Debug.Print _ ' .Fields("連番") & "---" & _ ' .Fields("機能名") & "---" & _ ' .Fields("パスワード") & "---" & _ ' .Fields("設定項目名") & "---" & _ ' .Fields("値") ' ' ' .MoveNext '次のレコード（行）に移動 ' ' End With ' ' ' ' Loop ' Debug.Print StrData01 o_RsWsSettei01.Close o_Db01.Close Set o_RsWsSettei01 = Nothing Set o_Db01 = Nothing End Function ' ' |
|
1 2 3 4 5 6 |
' ' ' ' |
