CALENDAR
Sun Mon Tue Wed Thu Fri Sat
      1
2345678
9101112131415
16171819202122
23242526272829
30      
<< September 2018 >>
SELECTED ENTRIES
CATEGORIES
ARCHIVES
CLOCK
MOBILE
qrcode
PROFILE
RECENT COMMENTS
RECENT TRACKBACK
OTHERS

だめぽブログ

tacoさんの暇つぶしブログ
スポンサーサイト

一定期間更新がないため広告を表示しています

| Posted by スポンサードリンク | | - | - |
ファイル名に欧州言語系のヘンテコ文字が含まれて非Unicode系ソフトで読めなくて(略
クラシック音楽あるあるかも知れないんだが、CDからリップした音声ファイル。
ファイル名が曲名になっちゃうものもあったりして、日本語ドイツ語フランス語が混在(; ・`д・´)
日本語と英語以外受け付けない古めのソフトウェアだと、この手のファイルはファイルすら読み込めない。
一時は手でちょっとずつリネームしてたんだが、さすがに七面倒臭いことこの上ない!!
大変困った挙げ句いくつかリネームソフトを試しても駄目だったので VBS スクリプトを作成した(๑•̀ㅂ•́)و✧
続きを読む >>
| Posted by tacoさん | 15:28 | comments(0) | trackbacks(0) |
Word で Font 列挙
久々に VB。
任意の文字にインストールされている全部のフォントを当ててテストするよ。
---

Sub allfont()
Dim inputString As String
inputString = InputBox("Please enter text you like")
If inputString = "" Then End

For Each f In Application.FontNames
Selection.Text = inputString & VBA.vbNewLine
Selection.Font.Name = f
Selection.MoveDown
Next f
End Sub

---
だめぽ
| Posted by tacoさん | 23:11 | comments(0) | trackbacks(0) |
Excelでファイルリストを管理する人向けの関数
Excelでファイルリストとか管理したい人向けの関数一式です。

新規ブックを作る

以下のコードをVBEにコピペ

XLA 形式に保存

アドインとして利用すれば結構便利です。


----------

Function GetFileName(FileName As String) As String
'引数に指定されたフルパスからファイル名を返します。
'
'使い方
'GetFileName(filename)
'filename ・・・・ フルパスのファイル名が記入されているセル番号、または文字列を指定します。
'
'例
'A1 セルが "C:¥WINDOWS¥system32¥calc.exe" の場合、B1 セルを以下のように記述すると
'=GetFileName(A1)
'↓
'B1 セルに calc.exe と表示されます。
Dim MyLen As Integer, i As Integer
MyLen = VBA.Len(FileName)
For i = 1 To MyLen
    If VBA.Right(FileName, i) Like "¥*" Then
        GetFileName = VBA.Right(FileName, i - 1)
        Exit Function
    End If
Next i
GetFileName = FileName
End Function

Function GetFileNameWOExtension(FileName As String) As String
'引数に指定されたフルパスから拡張子を除いたフルパスのファイル名を返します。
'
'使い方
'GetFileNameWOExtension(filename)
'filename ・・・・ フルパスのファイル名が記入されているセル番号、または文字列を指定します。
'
'例
'A1 セルが "C:¥WINDOWS¥system32¥calc.exe" の場合、B1 セルを以下のように記述すると
'=GetFileNameWOExtension(A1)
'↓
'B1 セルに C:¥WINDOWS¥system32¥calc と表示されます。
'
'こんな感じに組み合わせて使うと
'=GetFileNameWOExtension(GetFileName(A1))
'↓
'B1 セルに calc と表示されます。
Dim MyLen As Integer, i As Integer
MyLen = VBA.Len(FileName)
For i = 1 To MyLen
    If VBA.Right(FileName, i) Like ".*" Then
        GetFileNameWOExtension = VBA.Left(FileName, MyLen - i)
        Exit Function
    End If
Next i
GetFileNameWOExtension = FileName
End Function


Function GetPathName(FileName As String) As String
'引数に指定されたフルパスからファイル名を除いたフルパスのフォルダ名を返します。
'
'使い方
'GetPathName(filename)
'filename ・・・・ フルパスのファイル名が記入されているセル番号、または文字列を指定します。
'
'例
'A1 セルが "C:¥WINDOWS¥system32¥calc.exe" の場合、B1 セルを以下のように記述すると
'=GetPathName(A1)
'↓
'B1 セルに C:¥WINDOWS¥system32 と表示されます。
Dim MyLen As Integer, i As Integer
MyLen = VBA.Len(FileName)
For i = 1 To MyLen
    If VBA.Right(FileName, i) Like "¥*" Then
        GetPathName = VBA.Left(FileName, MyLen - i)
        Exit Function
    End If
Next i
GetPathName = FileName
End Function

Function GetExtensionName(FileName As String) As String
'引数に指定されたフルパスまたはファイル名から拡張子名を返します。
'
'使い方
'GetExtensionName(filename)
'filename ・・・・ フルパスのファイル名、またはファイル名が記入されているセル番号、または文字列を指定します。
'
'例
'A1 セルが "C:¥WINDOWS¥system32¥calc.exe" の場合、B1 セルを以下のように記述すると
'=GetExtensionName(A1)
'↓
'B1 セルに exe と表示されます。
Dim MyLen As Integer, i As Integer
MyLen = VBA.Len(FileName)
For i = 1 To MyLen
    If VBA.Right(FileName, i) Like ".*" Then
        GetExtensionName = VBA.Right(FileName, i - 1)
        Exit Function
    End If
Next i
GetExtensionName = FileName
End Function

Function FileExist(FullPath As String) As Boolean
'引数に指定されたフルパスのファイル名が存在するか調べて、結果をブール型 (Boolean) で返します。
'
'使い方
'FileExist(filename)
'filename ・・・・ フルパスのファイル名が記入されているセル番号、または文字列を指定します。
'
'例
'A1 セルが "C:¥WINDOWS¥system32¥calc.exe" の場合、B1 セルを以下のように記述すると
'=FileExist(A1)
'↓
'B1 セルに TRUE と表示されます。
'
'A1 セルを "C:¥WINDOWS¥system32¥calc.txt" などに変更してみると
'↓
'B1 セルに FALSE と表示されます。
On Error GoTo Err1

   If VBA.FileLen(FullPath) >= 0 Then FileExist = True
   Exit Function
Err1:
Select Case Err.Number
  Case 53
      FileExist = False
  Case Else
      Err.Raise Err.Number
  End Select
End Function

'↓おまけ
Function GetForeColor(sCell As Range) As String
'引数に指定されたセルの文字色を数値で返します。
'
'使い方
'GetForeColor(cell)
'cell ・・・・ セル番号を指定します。
GetForeColor = sCell.Font.Color
End Function

Function GetBackColor(sCell As Range) As String
'引数に指定されたセルの背景色を数値で返します。
'
'使い方
'GetBackColor(cell)
'cell ・・・・ セル番号を指定します。
GetBackColor = sCell.Interior.Color
End Function





今考えると Windows Scripting Host で結構簡単に出来るんですけどね。
まあそんなに難しいことはやってないんですけれども^^;


試してみたい方は自己責任でお願いします( ´∀`)

| Posted by tacoさん | 10:52 | comments(0) | trackbacks(0) |
クリップボードの設定と取得
VB 用のクリップボードの設定と取得の関数
VBA だと Clipboard オブジェクトが(多分)無いので、Webを漁って適当に作ってみました。動けばおkとしてるんで結構適当に作ってあります^^;

おいらは GetClipData でクリップボードのデータ取得して、文字列型の変数に入れて、置換したりしつつ、その変数を SetClipData クリップボードに戻すのに使ったりしてます。


----------------------------------------



Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long

Private Function GetClipData() As String
Dim hMem As Long
Dim p As Long
Dim RetVal As Long
Const MAXSIZE = 67108864 '<- 適当

If OpenClipboard(ByVal 0&) Then
    hMem = GetClipboardData(1)
    If hMem Then
        p = GlobalLock(hMem)
        If Not IsNull(p) Then
            GetClipData = Space$(MAXSIZE)
            RetVal = lstrcpy(GetClipData, p)
            RetVal = GlobalUnlock(hMem)
            GetClipData = Mid(GetClipData, 1, InStr(1, GetClipData, Chr$(0), 0) - 1)
        Else
            Err.Raise 51
        End If
    End If
    CloseClipboard
End If
End Function

Private Sub SetClipData(strLetter As String)
Dim hText As Long
Dim pText As Long

If OpenClipboard(ByVal 0&) Then
    hText = GlobalAlloc(&H42, LenB(strLetter) + 1)
    pText = GlobalLock(hText)
    If Not IsNull(pText) Then
        pText = lstrcpy(pText, strLetter)
        Call GlobalUnlock(hText)
        EmptyClipboard
        hText = SetClipboardData(1 Or 7, hText)
    Else
        Err.Raise 51
    End If
    CloseClipboard
End If

End Sub

----------------------------------------

PC が物故割れたりしても当ブログは責任を負えません><
自己責任でお願いします( ´∀`)
| Posted by tacoさん | 12:45 | comments(0) | trackbacks(1) |