2016-06-20

UWSCでクリップボード文字列を取得。

Option Explicit

Dim s
s = "こんにちは" & vbTab & """山田やま""" & vbTab & "さん"
PutInClipboardText s
MsgBox "文字列をクリップボードにコピーしました。" & vbCrLf & "文字列:" & s
Public Sub PutInClipboardText(ByVal str)
Dim cmd
cmd = "cmd /c ""echo " & str & "| clip"""
CreateObject("WScript.Shell").Run cmd, 0
End Sub

UWSCにクリップボードの文字列を送る。

str = GETSTR(0)
MSGBOX(str)

//常に姓と名の間にスペースがある前提
mojiretu = str
str = COPY(mojiretu,POS(" ",mojiretu)+1,LENGTH(mojiretu))
PRINT STR
MSGBOX(str)

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝参考URL＝＝＝＝＝＝＝＝＝＝＝＝

POS | UWSC コバヤシ式

POS関数

文字列に指定文字列があるか探す
戻値 = POS( 探す文字, 探される文字列 [,n個目] )
バイト処理の場合はPOSB関数を使用

引数

探す文字・・・探したい文字列
探される文字列・・・探される文字列
n個目・・・nを指定するとn個目の文字位置を返す(マイナス値で指定すると後ろからサーチ)

戻値

見つかった位置(１から)
見つからなければゼロを返す
大文字、小文字の区別はしない

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

2016-04-11

UWSC IE自動ログオン

IE=createoleobj("InternetExplorer.Application")
ie.visible=true
ie.navigate("https://hugahuga.com")
busywait(ie)
// iesetdata(ie,"AAAabc","username")
// まず，検索ボックスからフォーカスを外す
//window_id = 0
//sckey( window_id, VK_SHIFT, VK_TAB ) // shift + tab
//sleep( 0.5 )

//CUSTOMER_ID
IE.document.forms[0].elements[3].value = ""
//LOGON_ID
IE.document.forms[0].elements[4].value = "1234567890abc"
//PASS
IE.document.forms[0].elements[5].value = "1234567890abc"

//LOGONクリック
IE.document.forms[0].elements[6].click()

//直接書いてやる　tabで欄を飛ばしたり
// KBD(VK_TAB)
// KBD(VK_A)
// KBD(VK_I)

procedure busywait(ie)
repeat
sleep(0.5)
until !ie.busy and ie.readystate=4
fend

2015-11-06

pdfをtextに変換　特定行をエクセルに抽出マクロ

'標準モジュール
'※ Adobe Reader XI環境で実行
'※ その他環境では動作しない可能性があります。
Option Explicit

Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const GW_HWNDNEXT As Long = 2
Private Const TCM_SETCURFOCUS As Long = &H1330
Private Const WM_COMMAND As Long = &H111
Private Const AppPath As String = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe" 'Adobe Readerのパス
Private hPage As Long

Public Sub Sample()

'セルのクリア
Cells.Clear
'ファイルリスト作成
Dim dlg As FileDialog
Dim fd_path As String 'フォルダのフルパス
Dim fl_name As String 'ファイル名
Dim i As Long 'ファイル名を出力する行番号

Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
'キャンセル時にはマクロを終了
   If dlg.Show = False Then Exit Sub

   'フォルダのフルパスを格納
   fd_path = dlg.SelectedItems(1)

'フォルダ内の一つ目のファイル名を取得
   fl_name = Dir(fd_path & "\*")
If fl_name = "" Then
    MsgBox fd_path & " にはファイルが存在しません。"
    Exit Sub
End If

'Worksheets.Add Before:=Sheets(1)

Range("A1").Value = fd_path
Range("A2").Value = "のファイル一覧"
Range("A4").Value = "ファイル名"

'A5セルから下にファイル名を書き出し
i = 5
Do Until fl_name = ""
    Cells(i, 1).Value = fl_name
    i = i + 1
    '次のファイル名を取得
     fl_name = Dir
Loop

'MsgBox Sheets(1).Name & "にファイル名一覧を作成しました。"

'========================

Dim num, j As Long
Dim filename1 As Variant

For j = 5 To Range("A65536").End(xlUp).Row

' num = GetPDFPages("C:\Test\001.pdf")
filename1 = Cells(j, 1).Value
' num = GetPDFPages(Cells(j, 1).Value)
num = GetPDFPages(fd_path & "\" & filename1)
If num = 0& Then
    Debug.Print "Err."
Else
    Debug.Print "ページ数:" & num
    Cells(j, 2).Value = num
End If
Next

'=====================PDFの特定行からテキスト抽出
'PDFからテキスト抽出

Dim k As Long
'Dim filename2 As Variant
For k = 5 To Range("A65536").End(xlUp).Row

'aaaaaaaaaa
'Set sh = CreateObject("WScript.Shell")
'sh.Run "cmd /c C:\xd2tx213\command\xdoc2txt.exe" & fd_path & " \ " & filename1 & "> C:\xd2tx213\aaa\tmp.txt", 0, True

CreateObject("WScript.Shell").Run "cmd /c C:\xd2tx213\command\xdoc2txt.exe" & fd_path & " \ " & filename1 & "> C:\xd2tx213\aaa\tmp.txt", 0, True

'テキストの５行目を出力してエクセルに書き出す
    Dim FSO As Object, buf As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    '5行目を読み込んで表示します
    With FSO.GetFile("C:\xd2tx213\aaa\tmp.txt").OpenAsTextStream
        .SkipLine
        .SkipLine
        .SkipLine
        .SkipLine
        buf = .ReadLine
        .Close
    End With
    MsgBox buf
    Cells(5, k).Value = buf
    Set FSO = Nothing
Next

End Sub

Public Function GetPDFPages(ByVal PdfPath As String) As Long
Dim hApp As Long, hDlg As Long, hTab As Long, hPageNum As Long
Dim cmd As String
Dim winName As String
Dim buf As String * 255
Dim ret As Long
Dim timeLimit As Date

ret = 0& '初期化
cmd = """" & AppPath & """" & " " & """" & PdfPath & """"
Shell cmd, vbNormalFocus 'Adobe Reader起動
'CreateObject("Shell.Application").ShellExecute """" & PdfPath & """" '関連付けされている場合はこちらでも可
timeLimit = DateAdd("s", 5, Now()) 'ループの制限時間:5秒
Do
    hApp = FindWindowEx(0&, 0&, "AcrobatSDIWindow", vbNullString)
    Sleep 500&
    DoEvents
    If Now() > timeLimit Then Exit Do '制限時間を過ぎたらループを抜ける
Loop While hApp = 0&
If hApp = 0& Then GoTo Err
PostMessage hApp, WM_COMMAND, &H1788, 0& '文書のプロパティ表示
timeLimit = DateAdd("s", 5, Now()) 'ループの制限時間:5秒
Do
    hDlg = FindWindowEx(0&, 0&, "#32770", "文書のプロパティ")
    Sleep 500&
    DoEvents
    If Now() > timeLimit Then Exit Do '制限時間を過ぎたらループを抜ける
Loop While hDlg = 0&
If hDlg = 0& Then GoTo Err
hTab = FindWindowEx(hDlg, 0&, "GroupBox", vbNullString)
hTab = FindWindowEx(hTab, 0&, "SysTabControl32", vbNullString)
If hTab = 0& Then GoTo Err
SendMessage hTab, TCM_SETCURFOCUS, 0&, 0& '「概要」タブ選択
EnumChildWindows hDlg, AddressOf EnumChildProc, 0&
If hPage = 0& Then GoTo Err
hPageNum = GetWindow(hPage, GW_HWNDNEXT)
If hPageNum = 0& Then GoTo Err
If GetWindowText(hPageNum, buf, Len(buf)) = 0& Then GoTo Err
winName = Left$(buf, InStr(buf, vbNullChar) - 1)
ret = CLng(winName)
SendMessage hDlg, WM_COMMAND, vbOK, 0& 'ダイアログを閉じる
SendMessage hApp, WM_COMMAND, &H1791, 0& 'アプリケーション終了
Err:
GetPDFPages = ret
End Function

Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim clsName As String, winName As String
Dim buf1 As String * 255, buf2 As String * 255

If GetClassName(hWnd, buf1, Len(buf1)) <> 0& Then
    clsName = Left$(buf1, InStr(buf1, vbNullChar) - 1)
    If clsName = "Static" Then
      If GetWindowText(hWnd, buf2, Len(buf2)) <> 0& Then
        winName = Left$(buf2, InStr(buf2, vbNullChar) - 1)
        If winName = "ページ数 :" Then
          hPage = hWnd
          EnumChildProc = False
          Exit Function
        End If
      End If
    End If
End If
EnumChildProc = True
End Function

http://ebstudio.info/home/xdoc2txt.html

2015-11-03

PDFページ数取得マクロ（adobeから取得）

マクロ

Option Explicit
Public Sub Sample()

'フォルダ内の一つ目のファイル名を取得
   fl_name = Dir(fd_path & "\*")
If fl_name = "" Then
    MsgBox fd_path & " にはファイルが存在しません。"
    Exit Sub
End If

'Worksheets.Add Before:=Sheets(1)

Range("A1").Value = fd_path
Range("A2").Value = "のファイル一覧"
Range("A4").Value = "ファイル名"

'A5セルから下にファイル名を書き出し
i = 5
Do Until fl_name = ""
    Cells(i, 1).Value = fl_name
    i = i + 1
    '次のファイル名を取得
     fl_name = Dir
Loop

'MsgBox Sheets(1).Name & "にファイル名一覧を作成しました。"

'========================

Dim num, j As Long
Dim filename1 As Variant

For j = 5 To Range("A65536").End(xlUp).Row
filename1 = Cells(j, 1).Value
num = GetPDFPages(fd_path & "\" & filename1)
If num = 0& Then
    Debug.Print "Err."
Else
    Debug.Print "ページ数:" & num
    Cells(j, 2).Value = num
End If
Next
End Sub

Public Function GetPDFPages(ByVal PdfPath As String) As Long
Dim ret As Long

ret = 0& '初期化
With CreateObject("AcroExch.AVDoc")
    If .Open(PdfPath, vbNullString) Then
      ret = CLng(.GetPDDoc.GetNumPages)
      .Close 1&
    End If
End With
GetPDFPages = ret
End Function

2015-11-03

フォルダ内のpdfフォルダ配下のpdfページ取得マクロ

マクロ

'標準モジュール
'※ Adobe Reader XI環境で実行
'※ その他環境では動作しない可能性があります。
Option Explicit

Public Sub Sample()

'フォルダ内の一つ目のファイル名を取得
   fl_name = Dir(fd_path & "\*")
If fl_name = "" Then
    MsgBox fd_path & " にはファイルが存在しません。"
    Exit Sub
End If

'Worksheets.Add Before:=Sheets(1)

Range("A1").Value = fd_path
Range("A2").Value = "のファイル一覧"
Range("A4").Value = "ファイル名"

'A5セルから下にファイル名を書き出し
i = 5
Do Until fl_name = ""
    Cells(i, 1).Value = fl_name
    i = i + 1
    '次のファイル名を取得
     fl_name = Dir
Loop

'MsgBox Sheets(1).Name & "にファイル名一覧を作成しました。"

'========================

Dim num, j As Long
Dim filename1 As Variant

For j = 5 To Range("A65536").End(xlUp).Row

2015-10-11

マクロ参考HP

マクロ参考HPリンク

すぐに役立つエクセルVBAマクロ集 - Excel VBA Macro Collection

サンプルとマクロ集の説明

Office TANAKA - Excel VBA Tips[エラーに負けない]

エラー回避　goto構文

2015-10-11

マクロサンプル（データ取り込み）

マクロ

Sub データ取り込み()
'取り込み前にデータクリア（アクティブシートの全クリア）
'ActiveSheet.Cells.Clear

'取り込み前にデータクリア（指定したセルをクリア）
    On Error GoTo myError
    Range("A1:ZZ9999").SpecialCells(xlConstants, 23).ClearContents 'アクティブシートの特定範囲をクリア
    'Sheets("Sheet1").Range("A2:ZZ9999").SpecialCells(xlConstants, 23).ClearContents　'
myError:
    MsgBox "エラーでたのでクリアしません。", vbExclamation

' データ取り込み Macro
Dim varFileName As Variant

    varFileName = Application.GetOpenFilename(FileFilter:="ファイル(*.xlsx),*.xlsx", _
                                        Title:="ファイルの選択")
    If varFileName = False Then
        Exit Sub
    End If

     Workbooks.Open Filename:=varFileName
    Sheets("Sheet1").Cells.Copy ThisWorkbook.ActiveSheet.Cells '取り込み元のsheet1を指定して取り込み
    ActiveWorkbook.Close SaveChanges:=False

'項目行を挿入
Rows("1:1").Insert Shift:=xlDown '※１行番号で指定する方法
' Range("B2").EntireRow.Insert '※２セルで指定

'行を削除する
' Rows("4:5").Delete Shift:=xlUp '※１行番号で指定する方法
' Range("B2").EntireRow.Delete '※２セルで指定

'列の挿入

    Columns("E:F").Insert Shift:=xlToRight      '※３列名で指定する方法　EFの２列に挿入される
    'Range("B2").EntireColumn.Insert             '※４セルで指定

'---------------------------------------------------------------------------------
'列の削除
    Columns("H:I").Delete Shift:=xlToLeft       '※３列名で指定する方法　挿入された後のHI列を削除
    'Range("B2").EntireColumn.Delete             '※４セルで指定

'項目ごとのタイトルを入力
    Range("A1") = "項目1"                         'A1セルに「項目1」をセット
    Range("B1") = "項目2"                         'A1セルに「項目1」をセット
    Range("C1") = "項目3"                         'A1セルに「項目1」をセット
    Range("D1") = "項目4"                         'A1セルに「項目1」をセット
    Range("E1") = "項目5"                         'A1セルに「項目1」をセット
    Range("F1") = "項目6"                         'A1セルに「項目1」をセット
    Range("G1") = "項目7"                         'A1セルに「項目1」をセット
    Range("H1") = "項目8"                         'A1セルに「項目1」をセット
    Range("I1") = "項目9"                         'A1セルに「項目1」をセット

'フィルターをかける　（Sheet1に）
    Dim FilterRange As Range
    With Worksheets("Sheet1")
        Set FilterRange = .Range("A1").CurrentRegion
    End With

'アクティブシート（Sheet1）の内容をフィルター
    FilterRange.AutoFilter Field:=1, Criteria1:="1"    'Criteria1:="1"　←ここにフィルターしたい値
    FilterRange.AutoFilter Field:=2, Criteria1:="1"    'Criteria1:="1"　←ここにフィルターしたい値
    Cells(1, 1).Sort Key1:=Cells(1, 3), Order1:=xlAscending, Header:=xlYes    '←c列昇順

'sheet1のフィルタ条件のみをsheet2へコピー
    With Worksheets("Sheet2")
        .UsedRange.ClearContents
        FilterRange.SpecialCells(xlCellTypeVisible).Copy .Range("A1")
    End With

End Sub