投稿


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

アデニウム新横浜

posted Apr 17, 2017, 2:56 PM by Zhang Wenxu   [ updated Apr 17, 2017, 3:00 PM ]

MakeCab

posted Oct 19, 2016, 4:05 PM by Zhang Wenxu   [ updated Oct 20, 2016, 3:50 PM ]

VBAで指定フォルダーにあるファイルを集めて、MakeCabでcabファイルを作成する。
VBAでフィルターをかけられるので、あるパターンのみのファイルをバックアップすると便利。

Dim cel As Range
Dim rootFld As String
Dim outFld As String
Dim ts As TextStream

Public Const TemporaryFolder = 2
Public Sub listFiles()
    Dim fso  As New FileSystemObject
    Dim fld As Folder
    Dim ret As String
    
    rootFld = "C:\work\Demo_x86"
    outFld = "E:\Documents\backup"
    ret = runCmd("pushd " & outFld & " " & Chr(38) & " rd /S /Q . 2> nul ")
    
    Set ts = fso.OpenTextFile(outFld & "\cablist.txt", ForWriting, True)
    ts.WriteLine ".OPTION EXPLICIT"
    ts.WriteLine ".Set SourceDir = " & rootFld
    'ts.WriteLine ".Set DestinationDir=" & outFld
    ts.WriteLine ".Set CabinetNameTemplate=" & fso.GetFileName(rootFld) & ".CAB"
    ts.WriteLine ".Set Cabinet=on"
    ts.WriteLine ".Set Compress=on"
    'ts.WriteLine ".Set MaxCabinetSize=2000000000000"
    'ts.WriteLine ".Set MaxDiskSize=512000000"
    Set cel = ActiveCell
    Set fld = fso.GetFolder(rootFld)
    Call listFld(fld)
    ts.Close
    
    ret = runCmd("pushd " & outFld & " " & Chr(38) & " makecab /F " & """" & outFld & "\cablist.txt" & """ /L " & outFld)
    Debug.Print ret
End Sub

Public Sub listFld(fld As Folder)
    Dim subFld As Object
    Dim f As Object
    For Each f In fld.Files
        'Debug.Print f.name
        cel.Value = Mid(f.Path, Len(rootFld) + 2, 100)
        Set cel = cel.Offset(1, 0)
        ts.WriteLine """" & Mid(f.Path, Len(rootFld) + 2, 100) & """"
    Next
    For Each subFld In fld.SubFolders
        'Debug.Print subFld.name
        'cel.Value = Mid(subFld.Path, Len(rootFold) + 1, 100)
        'Set cel = cel.Offset(1, 0)
        ts.WriteLine ".Set DestinationDir=" & """" & Mid(subFld.Path, Len(rootFld) + 2, 100) & """"
        Call listFld(subFld)
    Next
End Sub

Public Function runCmd(strCmd As String) As String
    Dim fso As New FileSystemObject
    Dim tempFile As String
    Dim wsh As Object
    Dim waitOnReturn As Boolean
    Dim windowStyle As Integer

    Set wsh = CreateObject("WScript.Shell")
    tempFile = fso.GetSpecialFolder(TemporaryFolder) & "\" & Replace(fso.GetTempName(), ".tmp", ".txt")
    strCmd = "cmd /c " & strCmd & " > " & tempFile
    Debug.Print strCmd
    waitOnReturn = True
    windowStyle = 0
    wsh.Run strCmd, windowStyle, waitOnReturn
    On Error Resume Next
    runCmd = fso.OpenTextFile(tempFile, ForReading, False).ReadAll
End Function



参照設定:
Microsoft Scripting Runtime

1-10 of 83