投稿


リストファイル、サイズ、修正日時

posted Mar 12, 2019, 1:19 AM by Zhang Wenxu

' Mainサブルーチン
Sub Main ()
  Dim fn
    ' Excelアプリケーションのインスタンス生成
  Dim objXls : Set objXls = CreateObject("Excel.Application")
  Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")

  If objXls Is Nothing Then Exit Sub

  ' Excelの表示
  objXls.Visible = True
  'objXls.ScreenUpdating = False
  objXls.ScreenUpdating = True

  ' Workbookを新規作成
  Set objWorkbook = objXls.Workbooks.Add()

  'objWorkbooks.sheets(1).cells(1,1).value = WScript.Arguments(0)
  'objWorkbook.Sheets(1).Cells(1,1).value = "Test"
  objWorkbook.Sheets(1).Cells(1,1).value = WScript.Arguments(0)
 
  ret = runCmd("dir /b /s """ & WScript.Arguments(0) & """")
  'objWorkbook.Sheets(1).Cells(2,1).value = ret
  lines = Split(ret, vbCrLf)
  Set cel = objWorkbook.Sheets(1).Cells(2, 2)
  For Each line In lines
   If line <> "" and  InStr(line, ".svn") <= 0 then
    cel.value = line
    If fso.FileExists(line) Then
     Set fn = fso.GetFile(line)
     cel.offset(0, 1).value = "'" & fn.DateLastModified
     cel.offset(0, 2).value = fn.Size
    End If
    set cel = cel.offset(1, 0)
    
   end if
  Next
  ' Workbookを保存
  'objWorkbook.SaveAs(GetCurrentDirectory() & "\test2.xlsx")
  'objWorkbook.SaveAs("C:\work" & "\test2.xlsx")

  ' Workbookを閉じる
  'objWorkbook.Close

  ' Excelの終了
  'objXls.ScreenUpdating = True
  'objXls.Quit

  ' インスタンスの破棄
  Set objXls = Nothing
End Sub

Function runCmd(strCmd)
    Dim fso

    Dim tempFile

    Dim wsh

    Dim waitOnReturn

    Dim windowStyle
    Dim oFile
   
    set fso = CreateObject("Scripting.FileSystemObject")
    set wsh = CreateObject("WScript.Shell")
   
    tempFile = fso.GetSpecialFolder(TemporaryFolder) & "\" & Replace(fso.GetTempName(), ".tmp", ".txt")

    strCmd = "cmd /c " & strCmd & " > " & tempFile & " 2>&1"

    waitOnReturn = True

    windowStyle = 0

    wsh.Run strCmd, windowStyle, waitOnReturn

    On Error Resume Next

    'runCmd = fso.OpenTextFile(tempFile, ForReading, False).ReadAll
    Set oFile = fso.GetFile(tempFile)

    'If IsNull(oFile) Then MsgBox ("File not found: " & strPath): Exit Function
    If IsNull(oFile) Then
        runCmd = "File not found: " & tempFile
        Exit Function
    End If
   
    With oFile.OpenAsTextStream()
        runCmd = .Read(oFile.Size)
        .Close
    End With

End Function

' Mainサブルーチンの実行
Main

Listup folder command for explorer context menu

posted Jan 24, 2019, 9:38 PM by Zhang Wenxu

Add a explorer context menu for folder, listup all subfolders and files into an Excel file.

1. create vbs file
 listup.vbs

' Mainサブルーチン
Sub Main ()
  ' Excelアプリケーションのインスタンス生成
  Dim objXls : Set objXls = CreateObject("Excel.Application")
  If objXls Is Nothing Then Exit Sub
  ' Excelの表示
  objXls.Visible = True
  'objXls.ScreenUpdating = False
  objXls.ScreenUpdating = True
  ' Workbookを新規作成
  Set objWorkbook = objXls.Workbooks.Add()
  'objWorkbooks.sheets(1).cells(1,1).value = WScript.Arguments(0)
  'objWorkbook.Sheets(1).Cells(1,1).value = "Test"
  objWorkbook.Sheets(1).Cells(1,1).value = WScript.Arguments(0)
 
  ret = runCmd("dir /b /s """ & WScript.Arguments(0) & """")
  'objWorkbook.Sheets(1).Cells(2,1).value = ret
  lines = Split(ret, vbCrLf)
  Set cel = objWorkbook.Sheets(1).Cells(2, 2)
  For Each line In lines
   If InStr(line, ".svn") <= 0 then
    cel.value = line
    set cel = cel.offset(1, 0)
   end if
  Next
  ' Workbookを保存
  'objWorkbook.SaveAs(GetCurrentDirectory() & "\test2.xlsx")
  'objWorkbook.SaveAs("C:\work" & "\test2.xlsx")
  ' Workbookを閉じる
  'objWorkbook.Close
  ' Excelの終了
  'objXls.ScreenUpdating = True
  'objXls.Quit
  ' インスタンスの破棄
  Set objXls = Nothing
End Sub
Function runCmd(strCmd)
    Dim fso
    Dim tempFile
    Dim wsh
    Dim waitOnReturn
    Dim windowStyle
    Dim oFile
   
    set fso = CreateObject("Scripting.FileSystemObject")
    set wsh = CreateObject("WScript.Shell")
   
    tempFile = fso.GetSpecialFolder(TemporaryFolder) & "\" & Replace(fso.GetTempName(), ".tmp", ".txt")
    strCmd = "cmd /c " & strCmd & " > " & tempFile & " 2>&1"
    waitOnReturn = True
    windowStyle = 0
    wsh.Run strCmd, windowStyle, waitOnReturn
    On Error Resume Next
    'runCmd = fso.OpenTextFile(tempFile, ForReading, False).ReadAll
    Set oFile = fso.GetFile(tempFile)
    'If IsNull(oFile) Then MsgBox ("File not found: " & strPath): Exit Function
    If IsNull(oFile) Then
        runCmd = "File not found: " & tempFile
        Exit Function
    End If
   
    With oFile.OpenAsTextStream()
        runCmd = .Read(oFile.Size)
        .Close
    End With
End Function
' Mainサブルーチンの実行
Main

2. save vbs file in a folder, say: c:\work

3.  launch regedit.exe from the Start menu.

4. Expand the HKEY_CLASSES_ROOT key.
 
5. Find Directory\shell key.

6. Create listup key.

7. Create command key.

8. Change default data to "cscript.exe c:\work\listup.vbs "%V""
regedit

9. Right click a folder, "listup" is shown in the context menu.
context menu &quot;listup&quot;

10. Click "listup", all subfolders and files in the folder is listed up in an excel file.
list

Try it by yourself!


Add Shape At Cursor(zoom)

posted Nov 18, 2018, 2:02 AM by Zhang Wenxu

Option Explicit
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Create custom variable that holds two integers
Type POINTAPI
   Xcoord As Long
   Ycoord As Long
End Type
Declare Function GetSystemMetrics Lib "user32.dll" _
(ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Const DPI As Double = 96#
Const PPI As Double = 72#
Private Const LOGPIXELSX As Long = &H58&
Private Const LOGPIXELSY As Long = &H5A&
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hDc As Long, _
    ByVal nIndex As Long _
    ) As Long
Private Declare Function GetDC Lib "user32" ( _
    ByVal hWnd As Long _
    ) As Long
Private Declare Sub ReleaseDC Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal hDc As Long _
    )
Sub addShape()
'
' addShape Macro
'

'
    Dim lngMetricsValueCx As Long, lngMetricsValueCy As Long
  
    lngMetricsValueCx = GetSystemMetrics(SM_CXSCREEN)
    lngMetricsValueCy = GetSystemMetrics(SM_CYSCREEN)
    Debug.Print "Screen: " & lngMetricsValueCx & " * " & lngMetricsValueCy
   
    Dim shp As Shape
    
    'Set Shape = ActiveSheet.Shapes.addShape(msoShapeRectangle, 163.5, 133.5, 52.5, 15.75)
    Debug.Print "ActiveCell: " & ActiveCell.left & "," & ActiveCell.top & "," & ActiveCell.Width & "," & ActiveCell.Height
    Dim llCoord As POINTAPI
    ' Get the cursor positions
    GetCursorPos llCoord
    Debug.Print "X Cursor: " & llCoord.Xcoord & vbNewLine & "Y Cursor: " & llCoord.Ycoord

    Debug.Print "X Position: " & Application.ActiveWindow.PointsToScreenPixelsX(0) _
        + ActiveCell.left * DPI / PPI * (ActiveWindow.Zoom / 100) _
        & vbNewLine & "Y Position: " & Application.ActiveWindow.PointsToScreenPixelsY(0) _
        + ActiveCell.top * DPI / PPI * (ActiveWindow.Zoom / 100)

    'Debug.Print ActiveCell.left * DPI / PPI & "," & ActiveCell.top * DPI / PPI
    Dim p As POINTAPI
    p.Xcoord = (llCoord.Xcoord - Application.ActiveWindow.PointsToScreenPixelsX(0)) _
        * PPI / DPI / (ActiveWindow.Zoom / 100)
    p.Ycoord = (llCoord.Ycoord - Application.ActiveWindow.PointsToScreenPixelsY(0)) _
        * PPI / DPI / (ActiveWindow.Zoom / 100)
    Set shp = ActiveSheet.Shapes.addShape(msoShapeRectangle, p.Xcoord, p.Ycoord, 52.5, 15.75)
End Sub

Private Sub GET_DPI()
    Dim hWnd As Long
    Dim hDc As Long
    hWnd = Excel.Application.hWnd
    hDc = GetDC(hWnd)
    '水平方向DPI
        Debug.Print GetDeviceCaps(hDc, LOGPIXELSX)
    '垂直方向DPI
        Debug.Print GetDeviceCaps(hDc, LOGPIXELSY)
    ReleaseDC hWnd, hDc
End Sub

Add Shape At Cursor

posted Nov 18, 2018, 1:50 AM by Zhang Wenxu

Option Explicit
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Create custom variable that holds two integers
Type POINTAPI
   Xcoord As Long
   Ycoord As Long
End Type
Declare Function GetSystemMetrics Lib "user32.dll" _
(ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Const DPI As Long = 96
Const PPI As Long = 72

Sub addShape()
'
' addShape Macro
'

'
    Dim lngMetricsValueCx As Long, lngMetricsValueCy As Long
  
    lngMetricsValueCx = GetSystemMetrics(SM_CXSCREEN)
    lngMetricsValueCy = GetSystemMetrics(SM_CYSCREEN)
    Debug.Print "Screen: " & lngMetricsValueCx & " * " & lngMetricsValueCy
   
    Dim shp As Shape
    
    'Set Shape = ActiveSheet.Shapes.addShape(msoShapeRectangle, 163.5, 133.5, 52.5, 15.75)
    Debug.Print "ActiveCell: " & ActiveCell.left & "," & ActiveCell.top & "," & ActiveCell.Width & "," & ActiveCell.Height
    Dim llCoord As POINTAPI
    ' Get the cursor positions
    GetCursorPos llCoord
    Debug.Print "X Cursor: " & llCoord.Xcoord & vbNewLine & "Y Cursor: " & llCoord.Ycoord

    Debug.Print "X Position: " & Application.ActiveWindow.PointsToScreenPixelsX(0) _
        + ActiveCell.left * DPI / PPI _
        & vbNewLine & "Y Position: " & Application.ActiveWindow.PointsToScreenPixelsY(0) _
        + ActiveCell.top * DPI / PPI

    'Debug.Print ActiveCell.left * DPI / PPI & "," & ActiveCell.top * DPI / PPI
    Dim p As POINTAPI
    p.Xcoord = (llCoord.Xcoord - Application.ActiveWindow.PointsToScreenPixelsX(0)) _
        * PPI / DPI
    p.Ycoord = (llCoord.Ycoord - Application.ActiveWindow.PointsToScreenPixelsY(0)) _
        * PPI / DPI
    Set shp = ActiveSheet.Shapes.addShape(msoShapeRectangle, p.Xcoord, p.Ycoord, 52.5, 15.75)
End Sub

cat sel.sh

posted Oct 29, 2018, 1:24 AM by Zhang Wenxu   [ updated Oct 29, 2018, 2:10 AM ]

cat sel.sh
sqlplus -s username/password@oracle<<EOF > /dev/null
set heading off
set echo off
set lines 10000
set pages 0
set feedback off
set colsep '","'
set tab off
set trims on
set trim on
ALTER SESSION SET NLS_DATE_FORMAT='yyyy/mm/dd hh24:mi:ss';
spool regist.txt
select * from regist order by pan;
spool off
EOF
sed -i 's/ *",/",/g' regist.txt
sed -i 's/^/"/g' regist.txt
sed -i 's/$/"/g' regist.txt

readXML

posted Sep 3, 2018, 11:11 PM by Zhang Wenxu

Option Explicit

Public Sub readXML()
    Dim cel As Range
    Dim filename As String
    Dim elements  As MSXML2.IXMLDOMNodeList

    Dim element As MSXML2.IXMLDOMNode
    Dim contents As String
   
    Dim sh As Worksheet
    Dim rowData As Long
    Dim xmlDoc As New MSXML2.DOMDocument60
    Dim fso As New FileSystemObject
   
    rowData = 1
   
    Set cel = ActiveCell
    filename = Cells(1, 1).Value & cel.Value
   
    If Not fso.FileExists(filename) Then
        Debug.Assert False
    End If
   
    contents = readFileBinary(filename)
   
    'contents = Replace(contents, "encoding='UTF-8'", "")
    Call xmlDoc.LoadXML(contents)
    If Not xmlDoc.parseError Is Nothing Then
        Debug.Print xmlDoc.parseError.reason
        Debug.Print xmlDoc.parseError.line
    End If
    Set sh = Worksheets.Add

    Call iterateNode(xmlDoc.DocumentElement, sh, 1)
    Set xmlDoc = Nothing
End Sub

Public Sub iterateNode(node As MSXML2.IXMLDOMNode, sh As Worksheet, row As Integer)
    Dim childNode As MSXML2.IXMLDOMNode
    Dim length As Integer
    Dim index As Integer
   
    If node.ChildNodes.length = 0 Then
        Exit Sub
    End If
   
    If node.BaseName = "jdbc-system-resource" Then
        row = row + 1
    End If
   
    If node.ParentNode.BaseName = "jdbc-system-resource" Then
        If Application.WorksheetFunction.CountIf(sh.Rows(1), node.BaseName) > 0 Then
            index = Application.WorksheetFunction.Match(node.BaseName, sh.Rows(1), False)
        Else
            index = Application.WorksheetFunction.CountA(sh.Rows(1))
            sh.Cells(1, index + 1).Value = node.BaseName
            index = index + 1
        End If
       
        sh.Cells(row, index).Value = node.text
    End If
   
    For length = 0 To node.ChildNodes.length - 1
        Set childNode = node.ChildNodes(length)
        Call iterateNode(childNode, sh, row)
    Next
End Sub

'MSXML2.DOMDocument60

ファイル一覧作成

posted Aug 21, 2018, 10:34 PM by Zhang Wenxu

Public Sub ListAllFiles()
    Dim cmd As String
    Dim dir As String
    Dim lines As Variant
    Dim line As Variant
    Dim cel As Range
    Dim ret As String
   
    dir = Cells(1, 1).Value
    cmd = "dir /b /s " & dir
    ret = runCmd(cmd)
    lines = Split(ret, vbCrLf)
    Set cel = Cells(2, 2)
    For Each line In lines
        If InStr(line, ".svn") > 0 Then GoTo next_row
        cel.Value = line
        Set cel = cel.Offset(1, 0)
next_row:
    Next
End Sub

Public Function runCmd(strCmd As String) As String
    Dim fso As New FileSystemObject
    Dim tempFile As String
    Dim wsh As New WshShell
    Dim waitOnReturn As Boolean
    Dim windowStyle As Integer
    Dim oFile As Variant
   
    tempFile = fso.GetSpecialFolder(TemporaryFolder) & "\" & Replace(fso.GetTempName(), ".tmp", ".txt")
    strCmd = "cmd /c " & strCmd & " > " & tempFile & " 2>&1"
    waitOnReturn = True
    windowStyle = 0
    wsh.Run strCmd, windowStyle, waitOnReturn
    On Error Resume Next
    'runCmd = fso.OpenTextFile(tempFile, ForReading, False).ReadAll
    Set oFile = fso.GetFile(tempFile)
    'If IsNull(oFile) Then MsgBox ("File not found: " & strPath): Exit Function
    If IsNull(oFile) Then
        runCmd = "File not found: " & tempFile
        Exit Function
    End If
   
    With oFile.OpenAsTextStream()
        runCmd = .Read(oFile.Size)
        .Close
    End With
End Function

ファイルを開く

posted Aug 20, 2018, 6:25 PM by Zhang Wenxu   [ updated Aug 20, 2018, 6:25 PM ]

Public Sub openme()
    Dim filename As String
    Dim fso As New FileSystemObject
    Dim sh As Object
   
    filename = ActiveCell.Value
   
    If fso.GetExtensionName(filename) = "xls" Or fso.GetExtensionName(filename) = "xlsx" Then
        Call Workbooks.Open(filename)
        Exit Sub
    End If
    If fso.GetExtensionName(filename) = "js" Then
        Shell "C:\Program Files (x86)\sakura\sakura.exe " & filename
        Exit Sub
    End If
    If fso.GetExtensionName(filename) = "xml" Then
        Shell "C:\Program Files (x86)\sakura\sakura.exe " & filename
        Exit Sub
    End If
    If fso.GetExtensionName(filename) = "bat" Then
        Shell "C:\Program Files (x86)\sakura\sakura.exe " & filename
        Exit Sub
    End If
   
    'Set sh = CreateObject("Shell.Application")
    'Call sh.Open(filename)
    Shell "explorer.exe " & filename
End Sub

Public Sub showInExplorer()
    Dim filename As String
    Dim fso As New FileSystemObject
    Dim sh As Object
   
    filename = ActiveCell.Value
    filename = "C:\workspace\" & Replace(filename, "/", "\")
    If fso.GetExtensionName(filename) = "xls" Or fso.GetExtensionName(filename) = "xlsx" Then
        Call Workbooks.Open(filename)
        Exit Sub
    End If
   
    Shell "explorer.exe /select," & filename, vbNormalFocus
End Sub

oneclickでマーク

posted Aug 20, 2018, 6:24 PM by Zhang Wenxu

Sub mark()
'
' mark Macro
'

'
    Dim left
    Dim top
   
    If VarType(Selection) = vbObject Then
        left = Selection.ShapeRange(1).left
        top = Selection.ShapeRange(1).top
    Else
        left = ActiveCell.left
        top = ActiveCell.top
    End If
    ActiveSheet.Shapes.AddShape(msoShapeRectangularCallout, left, top, 82.5, _
        69.1666929134).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    With Selection.ShapeRange.line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With
    With Selection.ShapeRange.line
        .Visible = msoTrue
        .Weight = 2.25
    End With
   
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.text = "初期のエラーコードがない"
   
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 12).Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 12). _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignLeft
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 12).Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 11
        .Name = "+mn-lt"
    End With
End Sub

Sub markCell()
'
' Macro1 Macro
'
'
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Selection.Font.Bold = True
End Sub

Sub markRect()
'
' markRect Macro
'
'
    Dim left
    Dim top
   
    If VarType(Selection) = vbObject Then
        left = Selection.ShapeRange(1).left
        top = Selection.ShapeRange(1).top
    Else
        left = ActiveCell.left
        top = ActiveCell.top
    End If
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, left, top, 141, 18).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.line
        .Visible = msoTrue
        .Weight = 2.25
    End With
    With Selection.ShapeRange.line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With
End Sub

改行コード、エンコードを検出

posted Aug 20, 2018, 6:21 PM by Zhang Wenxu

Public Sub getFileEncode2()
    Dim cmd As String
    Dim ret As String
    Dim cel As Range
    Dim filename As String
    Dim fileContent As String
   
    For Each cel In Selection
        If cel.EntireRow.Hidden Then GoTo NEXT_ROW
        ret = ""
        filename = "C:\source" & cel.Value
        cmd = """""C:\tools\nkf.exe"""" -g " & filename
       
        ret = runCmd(cmd)
       
        Cells(cel.row, "M").Value = Replace(Replace(Replace(Replace(ret, Chr(10), ""), Chr(13), ""), "-", ""), "ASCII", "SJIS")
       
        If "BINARY" <> Cells(cel.row, "M").Value Then
            fileContent = readFileBinary(filename)
            If InStr(fileContent, Chr(13) & Chr(10)) > 0 Then
                Cells.Cells(cel.row, "N").Value = "CRLF"
            Else
                Cells.Cells(cel.row, "N").Value = "LF"
            End If
        Else
            Cells.Cells(cel.row, "N").Value = "-"
        End If
       
NEXT_ROW:
    Next
End Sub

Public Function runCmd(strCmd As String) As String
    Dim fso As New FileSystemObject

    Dim tempFile As String

    Dim wsh As New WshShell

    Dim waitOnReturn As Boolean

    Dim windowStyle As Integer
    Dim oFile As Variant
   
    tempFile = fso.GetSpecialFolder(TemporaryFolder) & "\" & Replace(fso.GetTempName(), ".tmp", ".txt")

    strCmd = "cmd /c " & strCmd & " > " & tempFile & " 2>&1"

    waitOnReturn = True

    windowStyle = 0

    wsh.Run strCmd, windowStyle, waitOnReturn

    On Error Resume Next

    'runCmd = fso.OpenTextFile(tempFile, ForReading, False).ReadAll
    Set oFile = fso.GetFile(tempFile)

    'If IsNull(oFile) Then MsgBox ("File not found: " & strPath): Exit Function
    If IsNull(oFile) Then
        runCmd = "File not found: " & tempFile
        Exit Function
    End If
   
    With oFile.OpenAsTextStream()
        runCmd = .Read(oFile.Size)
        .Close
    End With

End Function

Public Function readFileBinary(filename As String) As String
    Dim fso As New FileSystemObject
    Dim oFile As Variant
    If Not fso.FileExists(filename) Then
        readFileBinary = ""
        Exit Function
    End If
   
    Set oFile = fso.GetFile(filename)

    'If IsNull(oFile) Then MsgBox ("File not found: " & strPath): Exit Function
    If IsNull(oFile) Then
        readFileBinary = "File not found: " & filename
        Exit Function
    End If
   
    With oFile.OpenAsTextStream()
        readFileBinary = .Read(oFile.Size)
        .Close
    End With
End Function

1-10 of 85