|
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 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
Option Explicit Private mOraSession As Object Private mOraDatabase As Object Private Sub InsOra() Dim dblTotal As Double Dim lngIn As Long Dim lngOu As Long Dim lngTrans As Long Dim strSQL As String Dim strBuf As String On Error GoTo ERR_HND Const strBASE As String = "INSERT INTO TEST002 VALUES (" Set mOraSession = CreateObject("OracleInProcServer.XOraSession") Set mOraDatabase = mOraSession.OpenDatabase("mura", "mura/mura", 0&) On Error Resume Next mOraSession.BeginTrans ' mOraDatabase.ExecuteSQL ("BEGIN TRANS") For lngOu = 1 To 10 For lngIn = 0 To 10000 dblTotal = dblTotal + 1 Debug.Print dblTotal If lngTrans = 1000 Then mOraSession.CommitTrans mOraSession.BeginTrans lngTrans = 0 End If lngTrans = lngTrans + 1 ' strBuf = Int((Int((lngOu * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((10 * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((4 * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((9 * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((5 * Rnd) + lngIn) * Rnd) + lngIn) strBuf = Int((Int((lngOu * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((5 * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((9 * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((4 * Rnd) + lngIn) * Rnd) + lngIn) _ & Int((Int((10 * Rnd) + lngIn) * Rnd) + lngIn) 'Debug.Print Left$(strBuf, 5) strBuf = Left$(strBuf, 5) strSQL = "'" & strBuf & "'," _ & "'" & Left$("B2-" & lngIn & String(10, "0"), 10) & "'," _ & "'" & Left$("B3-" & lngIn & String(10, "0"), 10) & "'," _ & "'" & Left$("B4-" & lngIn & String(10, "0"), 10) & "'," _ & "'" & Left$("B5-" & lngIn & String(10, "0"), 10) & "')" mOraDatabase.ExecuteSQL (strBASE & strSQL) If Error <> 0 Then ' Beep Err.Clear End If Next lngIn Next lngOu mOraSession.CommitTrans ERR_HND: On Error Resume Next Beep Err.Clear End Sub |
|
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 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
Option Explicit Sub GetFileList(ByRef objFSO As Object, _ ByRef FileList As Collection, _ ByVal FolderPath As String) 'フォルダの存在確認 If Not objFSO.FolderExists(FolderPath) Then MsgBox ("指定のフォルダは存在しません") Exit Sub End If '再帰処理モジュールのコール Call GetDirFiles(objFSO.GetFolder(FolderPath), FileList) End Sub Sub GetDirFiles(ByRef objFolder As Object, _ ByRef FileList As Collection) Dim objFSO As Object Dim objFile As Object Dim objFolderSub As Object Set objFSO = CreateObject("Scripting.FileSystemObject") 'サブフォルダの取得 For Each objFolderSub In objFolder.SubFolders ' Debug.Print objFolderSub.Name Call GetDirFiles(objFolderSub, FileList) Next 'ファイルの取得 For Each objFile In objFolder.Files With objFile If Left$(objFile.Name, 1) = "~" Then Else FileList.Add objFile.ParentFolder & "\" & objFile.Name End If End With Next 'オブジェクトの解放 Set objFolderSub = Nothing Set objFile = Nothing End Sub Sub 実行_Click() Dim ScrString As String Dim desString As String Dim strTime As String Dim dupuli As Boolean Dim curRow As Integer Dim SheetCnt As Long Dim FileCnt As Long Dim FindCnt As Long Dim PlotCnt As Long Dim wb As Workbook Dim mainWs As Worksheet Dim curWs As Worksheet Dim TargetRange As Range Dim FoundCell As Range Dim FirstCell As Range Dim PlotMsg As Collection Dim FileList As Collection Dim WordApp As Object Dim WordDoc As Object Dim objFSO As Object Const strRow As Integer = 12 Const strCol As Integer = 4 Set objFSO = CreateObject("Scripting.FileSystemObject") Set mainWs = Worksheets("検索") Set FileList = New Collection Set WordApp = CreateObject("Word.Application") strTime = Time ScrString = mainWs.Range("C4") desString = mainWs.Range("C6") mainWs.Range("B" & strRow & ":XFD10000").Clear dupuli = (mainWs.Range("C6") = "あり") curRow = strRow Call GetFileList(objFSO, FileList, mainWs.Range("C2")) For FileCnt = 1 To FileList.Count mainWs.Cells(curRow, 2) = curRow - (strRow - 1) mainWs.Cells(curRow, 3) = objFSO.GetFileName(FileList(FileCnt)) Set PlotMsg = New Collection If Left$(objFSO.GetExtensionName(FileList(FileCnt)), 3) = "doc" Then ' ワード Set WordDoc = WordApp.Documents.Open(FileList(FileCnt)) 'WordApp.Visible = True FindCnt = 0 With WordDoc.Content.Find .Text = ScrString Do .Forward = True .Execute If .Found = False Then Exit Do Else FindCnt = FindCnt + 1 End If Loop End With WordDoc.Close Set WordDoc = Nothing If FindCnt = 0 Then Call AddCollect(PlotMsg, "－") Else Call AddCollect(PlotMsg, Trim(FindCnt)) End If ElseIf Left$(objFSO.GetExtensionName(FileList(FileCnt)), 3) = "xls" Then Application.ScreenUpdating = False ' ファイルオープン Set wb = Workbooks.Open(FileList(FileCnt)) mainWs.Cells(curRow, strCol) = "－" mainWs.Cells(10, 3) = strTime & " ～ " DoEvents For SheetCnt = 1 To wb.Sheets.Count If wb.Worksheets(SheetCnt).Name = "変更履歴" Then Else Set curWs = wb.Worksheets(SheetCnt) If Right$(wb.Name, 4) = "xlsx" Then Set TargetRange = curWs.Range("A1", "XFD10000") Else Set TargetRange = curWs.Range("A1", "IV10000") End If ' 検索(部分一致) Set FoundCell = TargetRange.Find(What:=ScrString, LookAt:=xlPart) If FoundCell Is Nothing Then Else Set FirstCell = FoundCell Do '検索 FoundCell.Value = desString Call AddCollect(PlotMsg, "'" & curWs.Name, dupuli) ' 次を検索 Set FoundCell = TargetRange.FindNext(FoundCell) If FoundCell Is Nothing Then Exit Do Else If FoundCell.Address = FirstCell.Address Then Exit Do Else Call AddCollect(PlotMsg, "'" & curWs.Name, dupuli) End If End If Loop End If End If Next SheetCnt ' 終了 Application.DisplayAlerts = False wb.Close SaveChanges:=False Application.DisplayAlerts = True Else ' Excel/Word以外 Call AddCollect(PlotMsg, "－") With mainWs .Cells(curRow, 2).Font.Color = vbRed .Cells(curRow, 3).Font.Color = vbRed .Cells(curRow, 4).Font.Color = vbRed End With Application.DisplayAlerts = True End If ' 結果出力 Application.ScreenUpdating = True DoEvents If PlotMsg.Count = 0 Then Else For PlotCnt = 1 To PlotMsg.Count mainWs.Cells(curRow, strCol + (PlotCnt - 1)) = PlotMsg(PlotCnt) Next End If curRow = curRow + 1 Set FoundCell = Nothing Set FirstCell = Nothing Set TargetRange = Nothing Set curWs = Nothing Set wb = Nothing Next FileCnt mainWs.Cells(10, 3) = strTime & " ～ " & Time Set mainWs = Nothing Set objFSO = Nothing Set FileList = Nothing Set WordApp = Nothing MsgBox "作業が完了しました｡" End Sub Private Sub AddCollect(ByRef chkCol As Collection, _ ByRef chkStr As String, _ Optional ByVal dupuli As Boolean = False) Dim i As Long Dim MatchStr As Boolean If dupuli Then chkCol.Add chkStr Else For i = 1 To chkCol.Count If chkCol(i) = chkStr Then MatchStr = True Exit For End If Next If MatchStr Then Else chkCol.Add chkStr End If End If End Sub |
|
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 31 32 33 34 35 36 37 38 39 40 41 42 43 |
Public Function GetFile(ByRef strFileName As String, _ ByRef strBuf As String) As Boolean GetFile = False On Error GoTo GetFile_ErrHnd Screen.MousePointer = 11 Dim intFNum As Integer 'ファイル番号 Dim strBuf As String Dim strGet As String intFNum = FreeFile 'ファイル番号取得 If Len(Dir(strFileName)) = 0 Then 'ファイルの存在を確認 MsgBox strFileName & vbCr _ & "ファイルが見つかりません！", vbOKOnly + vbCritical, "FileRead" GoTo FileRead_Exit End If Open strFileName For Input As #intFNum '読み込み用ファイルを開く Do While Not EOF(intFNum) 'データ取得 Line Input #intFNum, strGet 'データの読込 strBuf = strBuf & strGet & vbCrLf Loop Close #intFNum 'ファイルを閉じる strBuf = Left$(strBuf,Left$(strBuf,Len(strBuf)-2)) GetFile = True GetFile_Exit: Screen.MousePointer = 0 On Error Resume Next Close #intFNum 'ファイルを閉じる exit function GetFile_ErrHnd: MsgBox Err.Number & "：" & Error$, vbOKOnly + vbCritical, "GetFile" resume FileRead_Exit End Function |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
Public Sub PutFile(ByRef strFilename As String, _ ByRef strText As String, _ Optional ByVal intMode As Integer = gintPUTMODE_OUTPUT) Dim intFileNum As Integer ' If gblnPrint Then intFileNum = FreeFile If intMode = gintPUTMODE_OUTPUT Then Open strFilename For Output As #intFileNum Else Open strFilename For Append As #intFileNum End If Print #intFileNum, strText Close #intFileNum ' End If End Sub |
|
1 2 3 4 5 6 7 8 |
Dim intCnt As Integer With DBEngine.Workspaces(0).Databases(0) For intCnt = (.TableDefs.Count - 1) To 0 Step -1 If Right$(.TableDefs(intCnt).Name, 2) = "_V" Then .TableDefs.Delete (.TableDefs(intCnt).Name) End If Next End With |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
Public Sub test() Dim w As Object For Each w In Worksheets 'If w.Name = strSheet Then Debug.Print w.Name If InStr(w.Name, "_old") = 0 Then w.Select ActiveWindow.Zoom = 85 End If 'w.Select Range("A1").Select 'Exit For 'End If Next w End Sub |
|
1 2 3 4 5 6 7 8 9 |
With Sheets.Item("テーブル一覧") intRowCnt = 2 Do While .Cells(intRowCnt, 2).Value <> vbNullString .Cells(intRowCnt, 2) = vbNullString .Cells(intRowCnt, 3) = vbNullString .Cells(intRowCnt, 4) = vbNullString intRowCnt = intRowCnt + 1 Loop End With |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
Public Function FixLineEnd(ByRef strVal As String) As String Dim strBuf As String strBuf = Trim(strVal) Do While Right$(strBuf, 1) = Chr(10) If Right$(strBuf, 2) = vbCrLf Then strBuf = Left$(strBuf, Len(strBuf) - 2) End If If Right$(strBuf, 1) = vbLf Then strBuf = Left$(strBuf, Len(strBuf) - 1) End If Loop FixLineEnd = strBuf End Function |
|
1 2 3 4 5 6 7 8 9 |
Sub test() Do While True With CreateObject("Wscript.Shell") .SendKeys "^(A)", True 'Ctrl + A End With Application.Wait [Now() + "00:00:05"] DoEvents Loop End Sub |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
Sub Find(strTar As String) Dim textbox As Object Dim strTxt As String strTar = Trim(strTar) If Not strTar = vbNullString Then For Each textbox In ActiveSheet.Shapes strTxt = Trim(textbox.AlternativeText) If Not strTxt = vbNullString Then strTxt = Replace(strTxt, "#", vbNullString) Debug.Print strTxt If Len(strTxt) > 10 Then strTxt = Mid$(strTxt, 12) If strTxt = strTar Then textbox.Select Selection.Characters(Start:=1, Length:=Len(strTxt)).Font.ColorIndex = 3 Exit For End If End If End If Next textbox End If End Sub |
|
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 |
Private Function UserPwd(ByRef strUserName As String) As String Dim intRowCnt As Integer Dim strBuf As String Const intBGNROW As Integer = 5 Const intUSER_NAME As Integer = 2 Const intUSER_PWD As Integer = 3 On Error GoTo ErrHnd With Sheets.Item(“7-ユーザ”) intRowCnt = intBGNROW Do While .Cells(intRowCnt, intUSER_NAME).Value <> vbNullString strBuf = .Cells(intRowCnt, intUSER_NAME).Value If Upper(strBuf) = Upper(strUserName) Then UserPwd = .Cells(intRowCnt, intUSER_PWD).Value Exit Do End If intRowCnt = intRowCnt + 1 Loop End With Exit Function ErrHnd: MsgBox Err.Description & ” CODE:” & Err.Number End Function |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
Sub 共通_MACアドレス調査() Dim objConf, objMACEna, strIP Set objConf = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration Where (IPEnabled = TRUE)") For Each objMACEna In objConf For Each strIP In objMACEna.IPAddress Debug.Print ("IPｱﾄﾞﾚｽ(" & strIP & ")のMACｱﾄﾞﾚｽは(" & objMACEna.MACAddress & ")です") Exit For Next Next End Sub |
|
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 31 32 33 34 35 36 |
Private Sub Put_BLOB(ByRef strUser As String, _ ByRef strPwd As String, _ ByRef strService As String, _ ByRef strPath As String) Dim objSession As Object Dim objDatabase As Object Dim objRecBlob As Object Dim strSQL As String Dim strPutDir As String Dim intCnt As Integer Set objSession = CreateObject("OracleInProcServer.XOraSession") Set objDatabase = objSession.DbOpenDatabase(strService, strUser & "/" & strPwd, 0) intCnt = 0 strPutDir = "D:\Oracle\admin\PLAN\Iji\ikou\" strSQL = "SELECT accountxml FROM accountsvxml" & vbCrLf _ & "ORDER BY actkey,orderno,enforcementdate" Set objRecBlob = objDatabase.DbCreateDynaset(strSQL, 0&) With objRecBlob Do Until .EOF intCnt = intCnt + 1 .Fields(0).Value.CopyToFile StrConv(strPath & strService & "BLOB_" & intCnt & ".txt", vbFromUnicode) .DbMoveNext Loop End With MsgBox intCnt & "ファイル出力しました。" Set objRecBlob = Nothing Set objDatabase = Nothing Set objSession = Nothing End Sub |
|
1 |
Application.ScreenUpdating = False |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
Sub work() Dim ws As Worksheet For Each ws In Worksheets 'Debug.Print ws.Name ws.Activate ' If Left$(Range("BR1"), 6) = "テストPDB" Then ' Columns("BR:BS").Select ' Selection.ColumnWidth = 37.25 ' Columns("BT:BZ").Select ' Selection.ColumnWidth = 6 ' Columns("CA:CI").Select ' Selection.ColumnWidth = 7.63 ' End If ActiveWindow.Zoom = 70 Range("A1").Select Next End Sub |