vba 杂记

 

Public Function GetClipboardText()     Dim a As New DataObject     a.GetFromClipboard     GetClipboardText = a.GetText

End Function

Sub CopyStr(ByVal str As String)     Dim STRAA As String     Dim MyData As DataObject         STRAA = str         Set MyData = New DataObject         MyData.SetText STRAA         MyData.PutInClipboard     Set MyData = Nothing End Sub

 

'找ie

Function FindIEWinByName(ByVal strRef As String) As Object     Dim objWin As Object     Dim i As Integer      i = 1      For Each objWin In CreateObject("Shell.Application").Windows          Do While objWin.ReadyState <> 4 Or objWin.Busy              DoEvents              Sleep2 500              i = i + 1

             If i > 5 And InStr(objWin.LocationName, "https://globe7aoa.nestle.com:26001/irj/servlet/prt") <> Empty Then

                objWin.Quit                 GoTo end_ie              End If          Loop          If LCase(TypeName(objWin.Document)) = "htmldocument" Then              If objWin.LocationName Like "*" & strRef & "*" Then                  Set FindIEWinByName = objWin                  Exit For              End If          End If end_ie:      Next      Set objWin = Nothing  End Function

 

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Const SC_MINIMIZE As Long = &HF020& Const SC_MAXMIZE As Long = &HF030& Const SC_CLOSE = &HF060& Const WM_SYSCOMMAND = &H112

Sub SetTop10NWindow()   'Dim objwindow As MSHTML.HTMLWindow2     Set objwindow = FindWinByName("Balance Display")     If objwindow.hwnd <> 0 Then     SendMessage objwindow.hwnd, WM_SYSCOMMAND, SC_MAXMIZE, ByVal 0&      SetForegroundWindow objwindow.hwnd      End If

End Sub

Sub SetBottom10NWindow()   'Dim objwindow As MSHTML.HTMLWindow2     Set objwindow = FindWinByName("Balance Display")     If objwindow.hwnd <> 0 Then     SendMessage objwindow.hwnd, WM_SYSCOMMAND, SC_MINIMIZE, ByVal 0&     ' SetForegroundWindow objwindow.hwnd      End If   End Sub

Sub IeClose()      For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='iexplore.exe'")          Process.Terminate (0)      Next End Sub

 

'设置value ,函数

Sub setNrtValue(ByVal filepath As String, ByVal index As Integer)

 Application.DisplayAlerts = False

 'ShNRT.Range("F9").Formula = "='C:\Users\nbluoli\Desktop\work NRT\NRT10.11\account\[CN14_2084000_IG Payable_201709.xlsb]Reconciliation'!$O$7"

 ShNRT.Range("F" & index).Formula = "='" & filepath & "Reconciliation'!$O$7"  ShNRT.Calculate  ShNRT.Range("F" & index).Copy  ShNRT.Range("F" & index).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _         :=False, Transpose:=False     'ShNRT.Range("F9").Paste

End Sub

 

Function FunArray(ByVal str As String)

FunArray = Split(str, "_")

End Function

strPriod = Format(priod, "yyyymm")

 

Public Function GetImageFolder() As String     GetImageFolder = Application.Workbooks("fbl.xlsm").Path & "\temp\image\" End Function

 

Sub DelFile(ByVal filepath As String)          If Dir(filepath) <> "" Then         Kill filepath      End If       End Sub

Sub InsertImage(ByVal SH As Worksheet, ByVal picpath As String)     'del  image     Dim Shp As Shape     For Each Shp In SH.Shapes        ' If Shp.Type = msoPicture Then             Shp.Delete        ' End If     Next         SH.Shapes.AddPicture picpath, True, True, 10, 10, 600, 380     Workbooks(xlsmMain).Save            'sh.Pictures.Insert (picpath) '????

End Sub

'sap  danamic  Set Connection = Application1.Children(CLng(i))

 

 

ActiveWorkbook.Save     Call Shell(Application.ActiveWorkbook.Path & "\open.bat")     Application.Quit

 

Sub test_oledb()

Dim objconn As ADODB.Connection Dim objrs As ADODB.Recordset Set objconn = New ADODB.Connection objconn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=C:\Users\nbluoli\Desktop\work NRT\NRT10.11\account\CN14_2057070_Accrual 1_201709.xlsb" objconn.Open

End Sub

Function GetRegularNum(values As String) As Integer     Dim mRegExp As RegExp     Dim mMatches As MatchCollection      '?????????     Dim mMatch As Match        '?????

    Set mRegExp = New RegExp     With mRegExp         .Global = True                              'True??????, False???????????         .IgnoreCase = True                          'True????????, False???????         .Pattern = "([0-9])?([0-9])+|([0-9])+"   '??????         Set mMatches = .Execute(values)   '??????,???????????,????,???          GetRegularNum = mMatches(0).Value     End With         Set mRegExp = Nothing     Set mMatches = Nothing End Function

Sub test()     dd = GetRegularNum("Additional Documentation ( 1 )|Additional Documentation ( 3 )")

End Sub

 

  targetfile = folderT & strCompany & "_" & strAccount & "_" & strDetail & "_" & strPriod & ".xlsb"

    If Dir(targetfile) = "" Then          Sheet1.Range("O" & i) = "error:" & targetfile & " not exits!"          GoTo query_error     End If

       ' Application.GetObject(targetfile)        ' Workbooks.Open(targetfile)         Application.DisplayAlerts = False       Set Wb2 = Workbooks.Open(targetfile, False)         Set wb = GetObject(strFile)                     Set SH = wb.Sheets(1)                     rowLast = SH.Range("A60000").End(xlUp).Row + 5                     SH.Range("A2", "Q" & rowLast).Copy                     SH.Range("A2", "Q" & rowLast).Copy sh2.Range("E10")

   Dim shimage As Worksheet       'insert into image        For Each shitem In Wb2.Sheets          If shitem.Name = "Additional Requirements" Then             Set shimage = shitem             Exit For          End If       Next

 

Sub callWindowTh()

    Set AppAttach = New Application     AppAttach.Visible = True

    Dim objWB As Workbook     Set objWB = AppAttach.Workbooks.Open(GetCurrentPath & "\window.xlsm", False, True)     'objApp.Run "window.xlsm!Test_Attach"     AppAttach.Left = 1     AppAttach.Top = 1     AppAttach.Width = 800     AppAttach.Height = 600         End Sub

 

Private Sub Workbook_Open()     updateExcel     Sleep (2000)     ReNameFile End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)      If Application.ActiveSheet.codeName = "ShNRT" Then     Call Shell(Application.Workbooks(xlsmMain).Path & "\close.bat")  End If   End Sub

 years = Left(Sheet1.Range("H2").Value, 4)    months = Right(Sheet1.Range("H2").Value, 2)      priod = DateSerial(years, months, 1)     priodEnd = DateSerial(years, months + 1, 0)

 

Function FindWnd(ByVal wName As String) As Long     If Val(Application.Version) < 9 Then         FindWnd = FindWindow("ThunderXFrame", wName) 'XL97     Else         FindWnd = FindWindow("ThunderDFrame", wName) 'XL2000     End If     If FindWnd = 0 Then FindWnd = FindWindow(vbNullString, wName)     End Function