忍者ブログ
~蛙が跳ぶ程度の更新速度~
[1]  [2]  [3]  [4]  [5]  [6]  [7]  [8]  [9]  [10]  [11
×

[PR]上記の広告は3ヶ月以上新規記事投稿のないブログに表示されています。新しい記事を書く事で広告が消えます。

Option Explicit
WScript.Sleep(1000)

’2016:16
’2010:14
’2003:11

Dim objParam
Dim strFilename 
Dim strPassword
Dim objExcel
Dim objOpendExcel
Set objParam = WScript.Arguments
strFilename = "FileAddress"'objParam(0)
strPassword = "0000"'objParam(1)
Set objExcel = CreateObject("Excel.Application.16") 
objExcel.Visible = True
Set objOpendExcel = objExcel.Workbooks.Open(strFilename,,,,strPassword)
Set objExcel = Nothing

再読み込み用にスリープさせているが、エクセルアプリケーション系が上手く起動しない事があるらしく、完全な対応が出来ない。起動バージョンによって16のところの数字変更。
0000はパスワード。

WSHでソフト指定して起動した方が早いし汎用性は高いのだけれど、エクセルアプリケーション系の関数なら当該ファイルのみとか、既に開いている場合はブック足すとか出来ないかなと微調整方法がないか確認している途中。オプションで有れば良いんだけど、バージョンによってブックが作られたり、ファイル選択画面が出てきたりまちまちで、対応に幅が出来るのが難しいところ。

とりあえず使う事があるのでメモ的に。
PR
ネットで拾ったソースコードをエクセル2016で使えるように改修したもの。
このおもちゃに一時間かかったと思うとかけすぎである。
まぁ 試してもらえれば効果は分かる。あと明度や彩度まで回転式になってるので、
嫌な人はSとVの値を0〜100になるようにクリップするなりコンプ作るなりしてくれろ。
とりあえず以下ソース。モジュールは分けてもらわないとテスト関数が暴発するはず。

’まず計算用モジュール。

Function Bigger(ByVal A As Single, B As Single)
Max = A
If A < B Then
    Max = B
Else
End If
Bigger = Max
End Function
Function Smaller(ByVal A As Single, B As Single)
Dim min
min = A
If A > B Then
        min = B
Else
End If
Smaller = min
End Function
Sub test()
    Dim Data(4) As Variant
'    Data(0) = 0
'    Data(1) = 1
    Data(2) = 2
'    Data(3) = 3
    Data(4) = 4
    
'    MsgBox "Max:" & Maximam(Data) & " ,Min:" & Minimam(Data)
    MsgBox "Max:" & Data(Biggest(Data)) & " ,Min:" & Data(Smallest(Data))
End Sub
Function Biggest(ByVal InData)
'最大値の入っていた配列番号を返す
    Dim crntmax
    Dim n
    For n = 0 To UBound(InData)
        If InData(n) = "" Then
            
        Else
            Exit For
        End If
    Next
    crntmin = InData(LBound(InData) + n)
    For i = LBound(InData) + n To UBound(InData)
        If UBound(InData) - LBound(InData) = i Then
            Exit For
        End If
        If InData(i) < InData(i + 1) Then
'            crntmax = InData(i + 1)
            crntmax = i + 1
        End If
    Next
    Biggest = crntmax
End Function
Function Smallest(ByVal InData)
'空白以外の最小値の配列番号を返す
    Dim crntmin
    Dim n
    For n = 0 To UBound(InData)
        If InData(n) = "" Then
            
        Else
            Exit For
        End If
    Next
    crntmin = InData(LBound(InData) + n)
    For i = LBound(InData) + n To UBound(InData)
        If UBound(InData) - LBound(InData) = i Then
            Exit For
        End If
        If InData(i + 1) = "" Then
        
        ElseIf InData(i) > InData(i + 1) Then
'            crntmin = InData(i + 1)
            crntmin = i + 1
        End If
    Next
    Smallest = crntmin
End Function


’次に色変換系

Sub TestColor()
    Dim BaseColor As Long
    Dim RGBData As Long
    Dim H As Single, S As Single, V As Single
    Dim Rad As Long
    Dim Sat As Long
    Dim Val As Long
    Dim rgb
    Rad = 12
    Val = -10
    Sat = 10
    BaseColor = ThisWorkbook.ActiveSheet.Range("B3").Interior.Color
    
    For i = 1 To 30
        ThisWorkbook.ActiveSheet.Range("B3").Offset(i, 0).Interior.Color = ChgColorHue(BaseColor, Rad * i)
        ThisWorkbook.ActiveSheet.Range("A3").Offset(i, 0).Interior.Color = MonoTone(ThisWorkbook.ActiveSheet.Range("B3").Offset(i, 0).Interior.Color)
    Next
    ThisWorkbook.ActiveSheet.Range("C3").Interior.Color = ChgColorVal(BaseColor, Val)
    ThisWorkbook.ActiveSheet.Range("C4").Interior.Color = ChgColorSat(BaseColor, Sat)
End Sub
Sub testrgbVal()
    Dim rgb As Variant
    rgb = RevRGB(ThisWorkbook.ActiveSheet.Range("B3").Interior.Color)
    MsgBox "RGB(" & rgb(1) & "," & rgb(2) & "," & rgb(3) & ")"
End Sub
Function RevRGB(Color As Long) As Variant
'RGBを配列で返す
Dim c, rgb(3) As Variant
c = Right("000000" & Hex(Color), 6)
rgb(1) = Val("&H" & Right(c, 2))
rgb(2) = Val("&H" & Mid(c, 3, 2))
rgb(3) = Val("&H" & Left(c, 2))
RevRGB = rgb
'MsgBox "RGB(" & r & "," & g & "," & B & ")"
End Function
Function MonoTone(ByVal Color) As Long
    Dim RGBData As Long
    Dim H As Single, S As Single, V As Single
    
    Call RGB_ToHSV(Color, H, S, V)
'    H = 0
    S = 0
    Call RGB_FromHSV(RGBData, H, S, V)
    MonoTone = RGBData
End Function
Function ChgColorHue(ByVal Color As Long, Rad As Long) As Long
    Dim RGBData As Long
    Dim H As Single, S As Single, V As Single
    
    Call RGB_ToHSV(Color, H, S, V)
    H = (H + Rad) Mod 360
    Call RGB_FromHSV(RGBData, H, S, V)
    ChgColorHue = RGBData
End Function
Function ChgColorSat(ByVal Color As Long, Sat As Long) As Long
    Dim RGBData As Long
    Dim H As Single, S As Single, V As Single
    
    Call RGB_ToHSV(Color, H, S, V)
    S = (S + Sat) Mod 100
    Call RGB_FromHSV(RGBData, H, S, V)
    ChgColorSat = RGBData
End Function
Function ChgColorVal(ByVal Color As Long, Val As Long) As Long
    Dim RGBData As Long
    Dim H As Single, S As Single, V As Single
    
    Call RGB_ToHSV(Color, H, S, V)
    V = (V + Val) Mod 100
    Call RGB_FromHSV(RGBData, H, S, V)
    ChgColorVal = RGBData
End Function
Sub RGB_ToHSV(ByVal iiRGB As Long, ByRef orH As Single, ByRef orS As Single, ByRef orV As Single)
    Dim rR As Single, rG As Single, rB As Single
    Dim rKr As Single, rKg As Single, rKb As Single
    Dim rMin As Single, rDiff As Single
    Dim c As String
    rMin = 1
    orV = 0
    '' 3原色を分離して百分率に。
    c = Right("000000" & Hex(iiRGB), 6)
    rR = Val("&H" & Right(c, 2))
    rR = rR / 255
    rG = Val("&H" & Mid(c, 3, 2))
    rG = rG / 255
    rB = Val("&H" & Left(c, 2))
    rB = rB / 255
    
    '' 明度は、RGB 各要素の最大のものと同等です。
    orV = Bigger(rG, rB)
    orV = Bigger(rR, orV)
    '' 彩度は、RGB 各要素の最小と最大の差を、最大で割ったもの。
    rMin = Smaller(rG, rB)
    rMin = Smaller(rR, rMin)
    rDiff = orV - rMin
    If orV <> 0 Then
        orS = (rDiff / orV)
    Else
        orS = 0
    End If
    '' 色相は、どの値が最大値だったかにより違い、以下の計算で求まります。
    ''  最大の値により、色相角が決まるのです。
    ''  またここで、0 =< and < 360 の範囲に収めます。
    ''  ただし、色がなければ、色相はゼロです。
    If orS = 0 Then
        orH = 0
    Else
        rKr = (orV - rR) / rDiff
        rKg = (orV - rG) / rDiff
        rKb = (orV - rB) / rDiff
        Select Case orV
            Case rR: orH = rKb - rKg
            Case rG: orH = 2 + rKr - rKb
            Case rB: orH = 4 + rKg - rKr
        End Select
        orH = orH * 60: If orH < 0 Then orH = orH + 360
    End If
    '' 明度・彩度を 0 ~ 100 にします。
    orV = orV * 100
    orS = orS * 100
End Sub
Sub RGB_FromHSV(ByRef oiRGB As Long, ByVal irH As Single, ByVal irS As Single, ByVal irV As Single)
    Dim rR As Single, rG As Single, rB As Single
    Dim iI As Integer
    Dim rF As Single, rP As Single, rQ As Single, rT As Single
        
    '' 数値を 1 以下に収めます。
    irS = irS / 100
    irV = irV / 100
    
    If irS = 0 Then
        rR = irV
        rG = irV
        rB = irV
    Else
        irH = irH / 60
        If irH = 6 Then irH = 0
        iI = Int(irH)
        rF = irH - iI
        rP = irV * (1 - irS)
        rQ = irV * (1 - irS * rF)
        rT = irV * (1 - (irS * (1 - rF)))
        Select Case iI
            Case 0: rR = irV:   rG = rT:    rB = rP
            Case 1: rR = rQ:    rG = irV:   rB = rP
            Case 2: rR = rP:    rG = irV:   rB = rT
            Case 3: rR = rP:    rG = rQ:    rB = irV
            Case 4: rR = rT:    rG = rP:    rB = irV
            Case 5: rR = irV:   rG = rP:    rB = rQ
        End Select
    End If
    oiRGB = rgb(Int(rR * 255.9999), Int(rG * 255.9999), Int(rB * 255.9999))
End Sub


’で、飾りで表示行検索

Function NextVisibleRow(ByVal CrntRow As Range, UorL) As Range
    If UorL = U Then
        For NofR = 1 To 1000
        If CrntRow.Offset(-NofR, 0).EntireRow.Hidden = False Then
            Exit For
        End If
        Next
        Set NextVisibleRow = CrntRow.Offset(-NofR, 0)
    Else
        For NofR = 1 To 10000
        If CrntRow.Offset(NofR, 0).EntireRow.Hidden = False Then
            Exit For
        End If
        Next
        Set NextVisibleRow = CrntRow.Offset(NofR, 0)
    End If
End Function
Function NextVisibleCol(ByVal CrntCol As Range, LorR) As Range
    If LorR = L Then
        For NofC = 1 To 1000
        If CrntCol.Offset(-NofC, 0).EntireColumn.Hidden = False Then
            Exit For
        End If
        Next
        Set NextVisibleCol = CrntCol.Offset(-NofC, 0)
    Else
        For NofC = 1 To 1000
        If CrntCol.Offset(NofC, 0).EntireColumn.Hidden = False Then
            Exit For
        End If
        Next
        Set NextVisibleCol = CrntCol.Offset(NofC, 0)
    End If
End Function
Sub test()
    Dim tgtrow As Range
    Set tgtrow = NextVisibleRow(Range("A9"), U)
    MsgBox tgtrow.Address
End Sub
題名の通り。例えば絵を描くであったり、写真を撮るであったり、
意図の実現方法はおいといて、まず意図を作るというのがまた難しい。

要するにそれをする理由をもっておかないと何も前に進まないんだけど、
いかんせん感情なんてものがあるもんで、それは理由の前の目的のはず。
で、目的を理由と取り違えて突き進んで論点が安定しない。
なんてことがよくあるわけで。それを治すにはもはや常に意図をもって
行動する以外にないはずなんだよな。

できない。

オーディオ組むのも方向性って言われるように、目標の音があって、
意図があって、方法によって改善する。
カメラだったらピントの浅いものはいい写真に見えるけど、
ピントが深くても同じように意図を押し出せないと上手くならないわけで。
これが不足するとこれがいい。で終わって、何故いいのか理解しないから、
次に手を出した時に路頭に迷う。

日常に加えて何か効果的なトレーニング方法がないか
という、楽をしたいくそみたいな根性が首をもたげているわけだけど、
割と真面目になんかないもんかね。

こういうのって文書しかり、芸術しかり、表現全般に言えるんだよな。

あ。誕生日は無事(何事もなく)終わりました。はい。
そんな感じの生存報告。
機材側の接点は1ヶ所にした方がいいみたいな結果になったので、
それで電源側にも仮想アースつくって入れたんですが、
威力が凄いです。

定位がきっちり来ます。
一番はこれなんですが、高音低音かなり改善して良かったです。
拍手とかの立ち上がりがいいので薄っぺらい音になってないので
ひとまず最低ライン達成したかなー。

このあとはケーブル変えていかないと無理かなと。

それにしても、1k程度の出費でこんだけ効果あると本当に
市販品の価格に驚くしかないなぁ。今100円均一の
お茶入れる水筒みたいなのに入れてるんですが、
多分端子式に変更して閉じてしまうのが一番楽なんだろうなとは思いながら結局直で接続。

とりあえずゆっくり進めていこうかなー。って所ですね。

TAKET外したけどまたつけたりしてみようかなー。
かなり音量差がってピーキーさがかなりなくなります。

というか付属がスイッチングだったためにかなり音がなまってたので、
比較する価値がないというか。正直電源からの電気を信号によって
出力を作り出すアンプの機能上、電源=音なので、電源の質が変われば
同じ機材でも別物みたいな音に鳴るんですよね。

電源回路前までの電源のノイズレベルももろに影響してくる点は謎ですが。
日本の2端子タイプでそんな差が出るもんなのかねと思って、
どう説明出来るのか知りたいところ。

話は戻って。
仕様の上ではコスパが非常に高いので買ってみたンですが、悪くないです。

この方向性だとベース電源部分にノイズ乗せないためにもアダプタ分は
全体をトランス化してしまうという手もありかなと。

直流対策もしてみたいんだけど、選択肢はKOJOくらいしかないかな?

おそらくタップだとPRO400は将来的に導入するだろうなと思うんだけど、
実際どこに使うかって言われると既にデジタル用電源タップは有るから、
実はそんなに急がなくてそのまま流れていきそうな予感。

チーターアースはほぼ購入確定かな。集合住宅の仮想アースは予想以上に効果がある。

色々やりたい事があるけど出来てない的な。

ファインメットも試せてないし、先は長いなぁ。
カレンダー
10 2024/11 12
S M T W T F S
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
フリーエリア
最新コメント
[05/01 ytn582]
[04/20 あまぎえる]
[03/25 みかん畑]
[01/25 あまぎえる]
[12/28 あまぎえる]
最新トラックバック
プロフィール
HN:
あまぎえる
性別:
男性
バーコード
ブログ内検索
最古記事
(10/12)
(10/13)
(10/13)
(10/14)
(10/14)
P R
忍者ブログ [PR]