Ugrás a fő tartalomra

VBA / VBS használat



Megjegyzés:
' Ez egy megjegyzés






MINTA:
' --------------- SQL ripport  ---------------
'********************************************************************
'*
'* Copyright Kecskeméti Lajos
'*
'* Module Name:    sql_xls.vbs 
'*
'* SQL eredmény XLS-be töltése
'*
'*
'********************************************************************

' alap beállítások
Option Explicit

ON ERROR RESUME NEXT
Err.Clear

' valtozók
Dim objRootDSE, strDNSDomain, adoConnection
Dim strBase, strFilter, strAttributes, strQuery, adoRecordset
Dim strName, strDN, objManagerList, strManagerDN
Dim objExcel, objWorkbook, objWorkSheet, x, y, celx,cely, eField, objRange, objRange2
Dim strExcelPath
Dim strCon

Const xlAscending = 1
Const xlDescending = 2
Const xlYes = 1

wscript.echo date 
wscript.echo now 

'--------- Oracle konnekció
strCon = "Driver={Microsoft ODBC for Oracle}; " & _
         "CONNECTSTRING=(DESCRIPTION=" & _
         "(ADDRESS=(PROTOCOL=TCP)" & _
         "(HOST=szerver)(PORT=1521))" & _
         "(CONNECT_DATA=(SID = DB))); uid=nev;pwd=jelszo;"

Dim oCon: Set oCon = WScript.CreateObject("ADODB.Connection")
Dim oRs: Set oRs = WScript.CreateObject("ADODB.Recordset")
oCon.Open strCon

'Set oRs = oCon.Execute(" SELECT sysdate FROM DUAL union SELECT to_char(sysdate,'YYYYMMDD') FROM DUAL ")
Set oRs = oCon.Execute(" select * from kz_heti_teny  where 1=1 and period ='20110129' ")

strExcelPath = "d:\tmp\seredmeny_01.xlsx"

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = FALSE
objExcel.ScreenUpdating = FALSE
objExcel.DisplayAlerts = FALSE 
Set objWorkbook = objExcel.Workbooks.Add

wscript.echo time 

'objExcel.Visible = True

'Set objWorkbook = objExcel.Workbooks.Add
Set objWorksheet = objWorkbook.Worksheets(1)
wscript.echo now & "elso 1" 

celx = 1
cely = 0
x = 1
y = 1

'While Not oRs.EOF  
do until oRs.EOF
    for each eField in oRs.Fields
 If x = 1 Then
 ' fejléc
  objExcel.Cells((celx + x - 1), (cely + y )).Value = eField.name
  objExcel.Cells((celx + x), (cely + y)).Value = eField.value
 else
  objExcel.Cells((celx + x), (cely + y)).Value = eField.value
 End If  
  y = y + 1
'   WSCript.Echo "Valami-1"
'   WSCript.Echo celx
'      WSCript.Echo eField.value
next
y = 1
    x = x + 1
    oRs.MoveNext
'Wend
'WSCript.Echo x
loop

set objWorksheet = objWorkbook.Worksheets(2).Activate
Dim valodi_ketdtomb() 'dynamic array
ReDim valodi_ketdtomb(x-1,oRs.Fields.Count) 'redim 4 rows, 3 cols

oRs.MoveFirst
x = 0
y = 0
do until oRs.EOF
    for each eField in oRs.Fields
 If x = 0 Then
  valodi_ketdtomb(x, y) = eField.value
 else
  valodi_ketdtomb(x, y) = eField.value
 End If  
  y = y + 1
'   WSCript.Echo "Valami-1"
'   WSCript.Echo celx
'      WSCript.Echo eField.value
next
y = 0
    x = x + 1
    oRs.MoveNext
'Wend
'WSCript.Echo x
loop

'valodi_ketdtomb=array(null,1,2,3, 4,0,11,22,33,44,0,111,222,333,444,null)

Dim valodi_ketdtomb_regi() 'dynamic array
ReDim valodi_ketdtomb_regi(4,3) 'redim 4 rows, 3 cols
valodi_ketdtomb_regi(0,0) = 1
valodi_ketdtomb_regi(0,1) = 2
valodi_ketdtomb_regi(0,2) = 3
valodi_ketdtomb_regi(1,0) = 10
valodi_ketdtomb_regi(1,1) = 200
valodi_ketdtomb_regi(1,2) = 300

objExcel.Range("E1").Value = oRs.Fields.Count
objExcel.Range("E2").Value = x 'oRs.Records.Count

'Populate by column and row

objExcel.Range("A1:D20").Value = 5
'objExcel.Range("F1:T100").Value= valodi_ketdtomb
objExcel.Range( objExcel.Cells(2,6), objExcel.Cells(x+2,6+oRs.Fields.Count) ).Value = valodi_ketdtomb

objExcel.Range( objExcel.Cells(3,5), objExcel.Cells(5,5) ).Value = "E3-R1C5"
'Range(Cells(3,5),Cells(5,5)).Select

wscript.echo now & "masodik 2" 

' XLS  megjelenítés
 'objExcel.Visible = True
wscript.echo now 

' Save the spreadsheet.
'objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.SaveAs strExcelPath
objExcel.ActiveWorkbook.Close

' Quit Excel
objExcel.Application.Quit

wscript.echo now 

' Clean up.
adoRecordset.Close
adoConnection.Close 

oCon.Close
Set oRs = Nothing
Set oCon = Nothing

wscript.echo now 

' --------------- LDAP ---------------

'********************************************************************
'*
'* Copyright Kecskeméti Lajos
'*
'* Module Name:    sql_xls.vbs 
'*
'* SQL eredmény XLS-be töltése
'*
'*
'*


'********************************************************************
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection

Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")
strBase = "<LDAP://" & strDNSDomain & ">"

strFilter = "(&(objectClass=user))"
strAttributes = "sAMAccountName, distinguishedName"
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 10000
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
Set adoRecordset = adoCommand.Execute


adoRecordset.MoveFirst

strResults = "User Login Names" 

Do Until adoRecordset.EOF 
'Retrieve values and display
strName = adoRecordset.Fields("sAMAccountName").Value 
strDN = adoRecordset.Fields("distinguishedName").Value
strResults = strResults & VbCrLf & strName & " | " & strDN
adoRecordset.MoveNext
Loop

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("eredmeny.txt", True)
objFile.Write strResults
objFile.Close
Set objFile = Nothing
MsgBox "Elkészültem nézz bele a 'eredmeny.txt' -be."



Használata
cscript sql_xls.vbs 
wscript sql_xls.vbs 

Megjegyzések