A Christmas Present (that you didn't ask for)...
This is a multi-part message in MIME format.
--------------080603000702030103020107
Content-Type: text/plain; charset=ISO-8859-1; format=flowed
Content-Transfer-Encoding: 7bit
In the great tradition of (most) Christmas Presents,
this is one you didn't ask for, you didn't want,
and you will probably never use.
It is a status message / progressbar utility.
A StatusMsg/ProgBar capability is one of the most
serious omissions of wsh/vbs, if not _the_ most
serious omission. Every other scripting language
(that I know of) does have a StatusMsg/ProgBar
capability.
As you know, scripters have not stood idly by and
accepted this deficiency. There are a great number
of StatusMsg/ProgBar utilities already available out
there (and most are offered for free). They are
usually written in vb, but any competent language
could be used.
What is unusual about _THIS_ StatusMsg/ProgBar utility
is that it is written in script. More specifically,
it is written in vbs using api's called by DynaWrap to
create the graphical interface. I know what you're
thinking -- DynaWrap is a 3rd-party control, and
not "pure" script.
I would assert that DynaWrap is "almost pure" script.
Here's the argument. For one, it comes with code,
and so you can reassure yourself that nothing under-
handed is going on. For another, the code was
originally published in the Microsoft Developer's
Journal, and so by implication it bears the imprimature
of Microsoft. DynaWrap is no stranger to the scripting
ng's. It has been mentioned in the scripting ng's for
years (since 1999) and is frequently suggested for use
when somebody wishes to do something outside the realm
of "pure" script. Finally, it is "lite weight". The dll
is only 36kb, and there are no vbRuntimes used. Compared
with (bloated) InternetExplorer, which is the usual
suggestion here for use as a scripting StatusMsg/ProgBar
dialog, DynaWrap is exceedingly "lite weight".
Yes, DynaWrap is lacking in features for use with serious
heavy-duty api's. Most importantly for gui programming,
it is lacking in any typedef capability, and there is no
provision for callbacks. With this in mind, a StatusMsg/
ProgBar utility is about as far as one can go with DynaWrap,
because it is a "dialog" -- but the dialog is only "one-way"
(you are telling the user something, but not allowing him/her
to talk back). It is the "talking-back" part that requires
callbacks. That is, you need to make provisions for the
system send to you notification messages indicating that
the user is interacting with your dialog (buttons were
clicked, etc).
So here it is, for what it's worth. The first attachment
is the StatusMsg/ProgBar utility, wrapped up as a scripting
component in a "wsc" file. You may regester the wsc and
call it from script, or you may also just load it from a
local file. Or, if you don't like dealing with components,
you can just extract the relevant code and stick it directly
into your script. The other attachment is a demo script.
The "boilerplate" below describes how to get DynaWrap,
just in case you don't have it.
cheers, jw
--- <DynaWrap Boilerplate> ---
It is possible to declare-and-call an api from script,
but you must use a third-party control to do so,
or else write one yourself.
It has already been correctly pointed out that there
is no api-capability in "pure" script.
If you are willing to use a third-party control, then
one such control, called "DynaWrap", can be found on
Guenter Born's website (note: Guenter refers to it as
"DynaCall"). Here is the link to it:
http://people.freenet.de/gborn/WSHBazaar/WSHDynaCall.htm
On that page you will find a download for the control,
plus some code samples.
Note: you may find additional sample code by searching
the archives of the wsh and vbscript ng's.
Note also: DynaWrap does have its limitations. There are
certain things it can't do. For example, you can't call
api's which take typedefs as parameters, and you can't call
api's "by ordinal". But it will work for most of the
"usual suspects".
And finally, DynaWrap doesn't work entirely as advertised.
For example, it is supposed to allow for the declaration of
several api definitions in one instance of itself. I could
never get that to work (in win9x). You will need a new
instance of DynaWrap for every api, or else re-instantiate
the object for every api. Someday I'm going to learn enough
c++ to fix that...
--- </DynaWrap Boilerplate> ---
--------------080603000702030103020107
Content-Type: text/plain;
name="StatusMsgProgBarDialog.wsc.txt"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="StatusMsgProgBarDialog.wsc.txt"
<?xml version="1.0"?>
<component>
<?component error="true" debug="true"?>
<registration
description="StatusMsgProgBarDialog"
progid="StatusMsgProgBarDialog.WSC"
version="1.00"
classid="{e3638360-6d72-11da-a061-d0265bc1a60b}"
>
</registration>
<public>
<property name="pbBackColor">
<get/>
<put/>
</property>
<property name="pbForeColor">
<get/>
<put/>
</property>
<property name="titlebarCaption">
<get/>
<put/>
</property>
<property name="txtStatusMessage">
<get/>
<put/>
</property>
<property name="iPctComplete">
<get/>
<put/>
</property>
<method name="Create_ProgbarDialog">
<PARAMETER name="sCaption"/>
</method>
<method name="PostStatusAndPct">
<PARAMETER name="sStatusMsg"/>
<PARAMETER name="iPct"/>
</method>
<method name="CloseDialog">
</method>
</public>
<script language="VBScript">
<![CDATA[
Option Explicit
'
' --- description block --------------------------
' Title: A Status Message / Progressbar Utility...
'
' Description: O.K., so there are plenty of these dialogs around,
' but it was in intriguing challenge to program this
' with DynaWrap...
'
' Author: mr_unreliable
'
' Usage: Use at you own risk, tested on win98se...
'
' --- revision history ---------------------------
' 10Dec05: original attempt, using the wshATO "MakeWindow" script as inspiration...
' 11Dec05: couldn't get valid instance handle for THIS script, and so using
' the desktop instance handle, for now. (Maybe inspiration will strike later)...
' 11Dec05: in an attempt to get color into the progbar, used "SetTextColor" but
' that didn't work(?). So, used "DrawText" to draw the text (i.e., the blocks)
' to the textbox, but that apparently draws "on" the box, not "in" the box,
' that is, the image doesn't "persist" (ugh!)...
' 12Dec05: changing approach to using a static control, and inserting a bitmap
' image (i.e., a "rectangle" drawn in to resemble a progbar)...
' 14Dec05: redraw the bitmap "every time" (rather than attempting to retain/modify it)...
' 15Dec05: move the status msg / progbar dialog code to a "wsc" component,
' for the "usual reasons", i.e., "packaging"...
' --- end of description block -------------------
'
' --- global variables ---------------------------
Dim oDW ' as object (instantiated later)...
Dim m_hWndDlg, m_hStatic, m_hProgbar ' as long(s) (handles)
Dim m_hFontMsg, m_hFontLogo ' as font handle(s)
Dim m_hInstance ' as instance handle
Dim wdDlg : wdDlg = 440
Dim htDlg : htDlg = 115
Dim wdProgbar, htProgbar ' as long
'
Dim hDCProgbar, hDCPBSave ' as long
Dim hBmp : hBmp = 0 : Dim hDCMem : hDCMem = 0 ' as handles to system objects
Dim hBackPen, hBackBrush ' as long (handles)
Dim hBarPen, hBarBrush ' as long (handles)
'
Dim pbBackColor : pbBackColor = "&HFFFFFF" ' white
Dim pbForeColor : pbForeColor = "&HFF0000" ' blue
Dim titlebarCaption : titlebarCaption = " StatusMsg / ProgressBar Dialog "
Dim txtStatusMessage: txtStatusMessage = " StatusMsg goes here... "
Dim iPctComplete : iPctComplete = 0
' system constants (oops, can't use constants here -- FOR SHAME MICROSOFT!!!)
Dim SW_HIDE : SW_HIDE = 0 ' showwindow constants
Dim SW_SHOW : SW_SHOW = 5
Dim FW_NORMAL : FW_NORMAL = 400 ' 100=Light, 400=Normal, 700=Bold, 900=Heavy
Dim FW_BOLD : FW_BOLD = 700
'
Dim nRtn ' as long (hold api return value)
' --- End of declarations and constants ----------
Public Function get_pbBackColor()
get_pbBackColor = pbBackColor
End function
Public Function put_pbBackColor(crNew)
pbBackColor = crNew
End function
Public Function get_pbForeColor()
get_pbForeColor = pbForeColor
End function
Public Function put_pbForeColor(crNew)
pbForeColor = crNew
End function
Public Function get_titlebarCaption()
get_titlebarCaption = titlebarCaption
End function
Public Function put_titlebarCaption(sNewCaption)
titlebarCaption = sNewCaption
' todo: add code to insert this caption into the titlebar...
End function
Public Function get_txtStatusMessage()
get_txtStatusMessage = txtStatusMessage
End function
Public Function put_txtStatusMessage(sNewMsg)
txtStatusMessage = sNewMsg
' stick the new status message into the static control...
Call SetWindowText(m_hStatic, txtStatusMessage)
Call UpdateWindow(m_hWndDlg) ' otherwise known as: form.refresh
End function
Public Function get_iPctComplete()
get_iPctComplete = iPctComplete
End function
Public Function put_iPctComplete(iNewPctComp)
iPctComplete = iNewPctComp
Call RepaintProgBar(iPctComplete) ' update progbar...
Call UpdateWindow(m_hWndDlg) ' otherwise known as: form.refresh
End function
' --- CREATE PROGBAR DIALOG ----------------------
Public Function Create_ProgbarDialog(sCaption, pxLeft, pxTop)
' MsgBox(sCaption)
Dim hWndDlg, hLogo ' as long(s) handles
Dim dwStyle, dwExStyle ' as long
'
Const WS_VISIBLE = &H10000000 ' window style bits
Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Const WS_POPUP = &H80000000
Const WS_CHILD = &H40000000
'
Const WS_EX_NOPARENTNOTIFY = &H4
Const WS_EX_CLIENTEDGE = &H200
'
Const SS_BITMAP = &H0000000E ' static control style bits
'
Const WM_SETFONT = &H30
'
Const PS_SOLID = 0 ' pen style
'
Const SWP_NOMOVE = &H2
Const SWP_NOZORDER = &H4
Const SWP_NOSIZE = &H1
Const SWP_SHOWWINDOW = &H40
Const HWND_TOPMOST = -1
'
Dim swpFlags ' as long
' --- end of declarations and constants ----------
titlebarCaption = sCaption
' get an instance handle for THIS instance of wscript (tricky)...
m_hInstance = GetInstanceHandle()
dwStyle = WS_POPUP Or WS_CAPTION
dwExStyle = WS_EX_NOPARENTNOTIFY
' ----------------------------------------------
' note: typically, one would set up a window class of one's own, so as to
' be able to define the look-and-feel of the window. That is, the icon
' the cursor, the background/text colors, etc. But more importantly,
' you also supply a wndproc address, i.e., a routine to process messages
' coming from the window (i.e., to detect "events").
' But that requires a typedef, and a wndproc, things that are way
' beyond the capabilities of DynaWrap. And so, we will attempt to
' get by with a "system standard" window class, namely: "#32770"...
' That is the standard "dialog class", and as such there is a "default
' wndproc" built into the system, which will handle the minimal functions
' expected of a window. (Good Luck!)...
' ----------------------------------------------
hWndDlg = CreateWindowEx(0, "#32770", titlebarCaption, dwStyle, _
pxLeft,pxTop, wdDlg,htDlg, 0, 0, m_hInstance, 0) ' was CStr(m_sWndClass)
' ----------------------------------------------
' add some (child) controls to the window (note: static = label)...
m_hStatic = CreateWindowEx(0, "Static", "Script Status Messages go here.. ", _
WS_CHILD Or WS_VISIBLE, 20, 5, wdDlg - 20, 20, hWndDlg, 0, m_hInstance, 0)
' create the "progbar" window (i.e., using a "static" showing a bitmap)...
wdProgbar = wdDlg - 25 - 6 : htProgbar = 22
m_hProgbar = CreateWindowEx(WS_EX_CLIENTEDGE, "Static", "", _
WS_CHILD Or WS_VISIBLE Or SS_BITMAP , 10, 35, wdProgbar, htProgbar, hWndDlg, 0, m_hInstance, 0)
hLogo = CreateWindowEx(0, "Static", "brought to you by jawar productions (all rights reserved)... ", _
WS_CHILD Or WS_VISIBLE, wdDlg - 290, 75, 380, 25, hWndDlg, 0, m_hInstance, 0)
' (note: should probably go get these colors from sysinfo)...
hBackPen = CreatePen(PS_SOLID, 1, pbBackColor) ' C0C0C0) ' msGray
hBackBrush = CreateSolidBrush(pbBackColor) ' C0C0C0) ' aka, Silver
hBarPen = CreatePen(PS_SOLID, 1, pbForeColor) ' crBlue)
hBarBrush = CreateSolidBrush(pbForeColor) ' crBlue)
Call RepaintProgBar(0) ' paint in background...
' create fonts (otherwise the default fonts for this system will be used)...
m_hFontMsg = GetFontHandle("MS Sans Serif", 10, 0, FW_BOLD, False)
m_hFontLogo = GetFontHandle("Arial", 7, 0, FW_NORMAL, True) ' aspect ratio = 0 is default
' now, set prepared fonts into their respective controls.
Call SendMessage(m_hStatic, WM_SETFONT, m_hFontMsg, 0)
Call SendMessage(hLogo, WM_SETFONT, m_hFontLogo, 0)
' Call ShowWindow(hWndDlg, SW_SHOW) ' show the window here...
' msgbox("ck static")
' show the window here, and attempt to push it to the front...
swpFlags = SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
Call SetWindowPos(hWndDlg, HWND_TOPMOST, 0, 0, 0, 0, swpFlags)
' note: this "ought not" to be necessary, but without it the logo
' seems to be reluctant to initially appear (paint itself)???
Call UpdateWindow(hWndDlg) ' otherwise known as: form.refresh
Create_ProgbarDialog = hWndDlg ' return value (window handle)
End Function
' --- POST STATUS MSG _AND_ PCT COMPLETE ---------
Public Function PostStatusAndPct(sNewMsg, iNewPctComp)
txtStatusMessage = sNewMsg
iPctComplete = iNewPctComp
' stick the new status message into the static control...
Call SetWindowText(m_hStatic, txtStatusMessage)
Call RepaintProgBar(iPctComplete) ' update progbar...
Call UpdateWindow(m_hWndDlg) ' otherwise known as: form.refresh
End function
' --- CLOSE DIALOG -------------------------------
Public Function CloseDialog()
Call ShowWindow(m_hWndDlg, SW_HIDE) ' hide the window, before messing around...
' nota bene: if you save/restore the COMPLETE device context, then
' you don't need to put the dc back the way it was before exiting...
' clean-up gdi system objects...
Call RestoreDC(hDCProgbar, hDCPBSave) ' return progbar DC to original state
Call DestroyWindow(m_hWndDlg)
' release "system objects" (we do our bit to help prevent "memory leaks")...
Call DeleteObject(hBmp)
Call DeleteObject(hBackPen) ' return system object(s)
Call DeleteObject(hBackBrush)
Call DeleteObject(hBarPen) ' return system object(s)
Call DeleteObject(hBarBrush)
Call DeleteObject(m_hFontMsg)
Call DeleteObject(m_hFontLogo)
End Function
' ================================================
' PRIVATE (INTERNAL) FUNCTIONS, (from here on out)
' ================================================
' --- REPAINT PROGBAR ----------------------------
Private Function RepaintProgBar(iPct)
Const STM_SETIMAGE = &H172 ' winuser.h
Const IMAGE_BITMAP = 0
' ==============================================
' Discussion: dealing with the problem of "persistance". You can get a reference
' to the device context of a static control, set the fore/back colors and then
' draw shapes or text on it, and it looks ok. BUT what is happening is that
' you are drawing on the screen. You can see what you draw, at least when
' you draw it -- but if your window gets hidden and then re-appears that drawing
' will have disappeared. In geek-speak, your image didn't "persist".
'
' In vb, that "persistance" issue is auto-magically taken care of for you.
' VB intercepts any system messages telling you to re-draw the control, and
' does it. However, in this case we are "flying-without-the-net", i.e., we
' are relying on the "default wndproc's" because we can't setup a callback
' wndproc for our window with dynawrap.
'
' And so, we are going to have to take other measures to insure that we get
' "persistance" of the progbar graphics. We are going to use "brute force".
' That is, we are going to make up a "memory bitmap" with the graphics we want,
' and then insert the bitmap into an appropriately-styled static control,
' which will then take over and resolutely display the graphics "come-what-may"...
' ==============================================
' get device context (of the progbar/static control)...
hDCProgbar = GetDC(m_hProgbar)
' save existing device context of control, before messing around (DA, pg 490)...
hDCPBSave = SaveDC(hDCProgbar)
Dim hNewBmp
' create a bitmap (compatible with the display), in memory...
hNewBmp = CreateCompatibleBitmap(hDCProgbar, wdProgbar, htProgbar)
BugAssert (hNewBmp <> 0), " could not create compatible bitmap"
' then create a "memory device" compatible DC...
hDCMem = CreateCompatibleDC(hDCProgbar)
BugAssert (hDCMem <> 0), " could not create compatible dc"
' select the new bitmap, pen and brush objects into the (memory) device context...
Dim hPrevBmp, hPrevPen, hPrevBrush ' as long
hPrevBmp = SelectObject(hDCMem, hNewBmp)
hPrevPen = SelectObject(hDCMem, hBackPen) ' select pen into DC...
hPrevBrush = SelectObject(hDCMem, hBackBrush)
' clean up (erase) the memory bitmap, by painting in a rectangle with the
' background (msGray) color. This is being done because the progressbar bar
' doesn't initially fill up the static control...
' Windows draws the outline of the figure with the current pen selected,
' and the figure is filled with the current brush selected (CP 558)...
nRtn = Rectangle(hDCMem, 0,0, wdProgbar, htProgbar)
BugAssert (nRtn <> 0), " .. Rectangle returned an error"
' --- draw in the progbar, if any --------------
If (iPct > 0) then
' change pens (to draw color portion)...
hPrevPen = SelectObject(hDCMem, hBarPen) ' select pen into DC...
hPrevBrush = SelectObject(hDCMem, hBarBrush)
' calculate the length of the progbar. Let 100pct be (wdProgbar - 2).
' then, the length is iPct/100 * (wdProgbar - 2)...
Dim pxProgbar : pxProgbar = iPct/100 * (wdProgbar - 2)
nRtn = Rectangle(hDCMem, 2,2, pxProgbar, htProgbar - 1) ' allowance for frame
BugAssert (nRtn <> 0), " .. Rectangle returned an error"
End If ' test iPct
' --- finished with drawing the progbar --------
' set bitmap image into the static control...
nRtn = SendMessage(m_hProgbar, STM_SETIMAGE, IMAGE_BITMAP, hNewBmp)
' cleanup time...
Call SelectObject(hDCMem, hPrevBmp) ' probably not necessary (see RestoreDC)
if (hBmp <> 0) then Call DeleteObject(hBmp) ' release old bitmap...
hBmp = hNewBmp ' preserve this (new) bitmap, while it's being displayed
' finished drawing, restore device context, release system resources...
Call RestoreDC(hDCMem, hDCPBSave) ' note PB DC same as original hDCMem(?)
Call DeleteDC(hDCMem)
Call ReleaseDC(m_hProgbar, hDCProgbar)
' ==============================================
' Call UpdateWindow(m_hWndDlg) ' otherwise known as: form.refresh
End Function
' --- GET INSTANCE HANDLE (of Desktop -- cheat, cheat) ---
Private Function GetInstanceHandle()
' Dim hInstance
' Discussion: getting an instance handle with vb is easy, as there is
' an already defined hInstance property of the vbApp object.
' Unfortunately, wscript doesn't provide this, so we will have to
' go get it using "brute force" (i.e., go get it the hard way).
' That involves some tricky-dicky stuff. First, we are going to
' have to find wscript's "hidden window" (yes Dorothy, there _IS_
' a wscript window -- how do you think wscript communicates with
' the system, eh?). Assuming we can find that hidden window, then
' we can use that go get our hInstance, using gwl_hInstance which
' gets the instance handle for a window...
' --- end of discussion --------------------------
' get an instance handle (from vbApp object, for now),
' but that's not a "pure" DynaWrap play...
' hInstance = oATO.vbApp.hInstance ' requires wshATO, verboten here...
' More Discussion: had to temporarily give up on getting the hInstance
' for THIS script. Enumming the "thread windows" would have found it
' directly, but that requires a "callback routine" which can't be done in
' script without using something with more capabilities than DynaWrap.
' Another approach would be enumming ALL the desktop windows, which would
' work with DynaWrap, using getDesktop window and then GetNextWindow on
' down the chain, but then, if you have more than one wscript instance
' running, how do you detect which one is yours??? (Maybe comparing
' command lines would work -- if one could guarantee a unique command line)...
'
' And so for now, we will be using the "desktop instance", which is easy
' to get. (Caveat Emptor: if your window uses the wscript instance, then
' the window auto-magically goes away when your script terminates.
' But, if you use the "desktop instance" then you better make sure that
' you kill the window BEFORE you close, or the window is most likely to
' hang around forever). Yes, yes, I know, it's ugly...
' --- end of discussion (part2) ------------------
Dim hDesktop ' as long (handle)
Const GWL_HINSTANCE = (-6)
Dim hDeskInstance ' as long (handle)
hDesktop = GetDesktopWindow()
hDeskInstance = GetWindowLong(hDesktop, GWL_HINSTANCE)
GetInstanceHandle = hDeskInstance ' hInstance ' return result
End Function
' --- GET FONT HANDLE ----------------------------
Private Function GetFontHandle(sFontName, ptSiz, AspectRatio, fntWeight, vItalic)
Dim hFont ' as font handle
' font-related constants, (note: the "weight constants defined globally)...
' Const FW_NORMAL = 400 ' 100=Light, 400=Normal, 700=Bold, 900=Heavy
' Const FW_BOLD = 700
'
Const DEFAULT_ASPECTRATIO = 0
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_DONTCARE = 0
'
Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
' --- end of declarations and constants ----------
' Make it negative, so as to apply to "glyph", rather than "cell".
' Dim cf_PtSize : cf_PtSize = - CSng(GetDeviceCaps(GetDC(hWndDlg), LOGPIXELSY) / 72)
' forget the api's for now, just plug it in...
Dim cf_PtSize : cf_PtSize = - CSng(96 / 72) ' micron crt logpixelsy = 96
' --- finished with font conversion factor -----
Dim htFont, wdFont ' as long
htFont = Int(ptSiz * cf_PtSize)
wdFont = Int((ptSiz * cf_PtSize) * AspectRatio) ' was DEFAULT_ASPECTRATIO
' convert vbScript boolean to system true/false...
Dim bItalic ' as system t/f
If vItalic then
bItalic = 1 ' system true, i.e., want it as italic
Else
bItalic = 0 ' system false, i.e. not italic (regular)
End If
hFont = CreateFont(htFont, wdFont, 0, 0, fntWeight, bItalic, _
0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, _
DEFAULT_QUALITY, DEFAULT_PITCH Or FF_DONTCARE, sFontName)
GetFontHandle = hFont
End Function
' ================================================
' ================================================
' === "WRAPPERS" FOR API CALLS (DynaWrap style) ==
'
' the DynaWrap doc is rather inscrutable, but as best I can make out,
' DynaWrap can only accomodate ONE api declaration at a time.
' (If I'm wrong, maybe you experts can straighten me out on this).
'
' Assuming that my one-at-a-time hypothesis is correct,
' then one has two choices:
' - you need to set up a separate obj for EVERY api (ugh!), or
' - declare the api's to be used (one-at-a-time) as you go,
' which is what you see here (yes, it's "ugly")...
' ----------------------------------------------
' the DynaWrap parameters are:
' i => the number and data type of the function's parameters
' f => type of call _stdcall or _cdecl.
' (Default to _stdcall. If that doesn't work use _cdecl).
' r => return data type.
' the data type declarations are:
' c => VT_I4: c signed char
' d => VT_R8: d 8 byte real
' f => VT_R4: f 4 byte real
' h => VT_I4: h HANDLE
' l => VT_I4: l long
' p => VT_PTR: p pointer
' s => VT_LPSTR: s string
' t => VT_I2: t short
' u => VT_UINT: u unsigned int
' w => VT_LPWSTR: w wide string
' r => VT_BYREF: (pass by reference) for strings only.
'
' the call type declarations are:
' s => _stdcall (standard vb-type call)
' => _cdecl (c++ type call)
' ----------------------------------------------
' ================================================
' ================================================
Private Function CreateWindowEx(dwExStyle, sClassName, sWindowName, dwStyle, dwLeft,dwTop, _
dwWidth,dwHeight, hWndParent, hMenu, hInstance, lpParam)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "CreateWindowExA", "i=lsslllllllll", "f=s", "r=h"
CreateWindowEx = oDW.CreateWindowExA(CLng(dwExStyle), CStr(sClassName), CStr(sWindowName), _
CLng(dwStyle), CLng(dwLeft),CLng(dwTop), CLng(dwWidth),CLng(dwHeight), _
CLng(hWndParent), CLng(hMenu), CLng(hInstance), CLng(lpParam))
End Function
' Declare Function CreatePen Lib "gdi32" Alias "CreatePen" _
' (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Function CreatePen(nPenStyle, nWidth, crColor)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "CreatePen", "i=lll", "f=s", "r=l"
CreatePen = oDW.CreatePen(CLng(nPenStyle), CLng(nWidth), CLng(crColor))
End Function
' Declare Function CreateSolidBrush Lib "gdi32" Alias "CreateSolidBrush" _
' (ByVal crColor As Long) As Long
Private Function CreateSolidBrush(crColor)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "CreateSolidBrush", "i=l", "f=s", "r=l"
CreateSolidBrush = oDW.CreateSolidBrush(CLng(crColor))
End Function
' Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
' (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Function SendMessage(hWnd, wMsg, wParam, lParam)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "SendMessageA", "i=llll", "f=s", "r=l"
SendMessage = oDW.SendMessageA(CLng(hWnd), CLng(wMsg), CLng(wParam), CLng(lParam))
End Function
' Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _
' (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Function SetWindowText(hWnd, lpString)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "SetWindowText", "i=ls", "f=s", "r=l"
SetWindowText = oDW.SetWindowText(CLng(hWnd), CStr(lpString))
End Function
' Declare Function ShowWindow Lib "user32" Alias "ShowWindow" _
' (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Function ShowWindow(hWnd, nCmdShow)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "ShowWindow", "i=ll", "f=s", "r=l"
ShowWindow = oDW.ShowWindow(CLng(hWnd), CLng(nCmdShow))
End Function
' Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" _
' (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
Function SetWindowPos(hWnd, hWndInsertAfter, x,y, cx,cy, wFlags)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "SetWindowPos", "i=lllllll", "f=s", "r=l"
SetWindowPos = oDW.SetWindowPos(CLng(hWnd), CLng(hWndInsertAfter), _
CLng(x), CLng(y), CLng(cx), CLng(cy), CLng(wFlags))
End Function
' Declare Function UpdateWindow Lib "user32" Alias "UpdateWindow" _
' (ByVal hWnd As Long) As Long
Private Function UpdateWindow(hWnd)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "UpdateWindow", "i=l", "f=s", "r=l"
UpdateWindow = oDW.UpdateWindow(CLng(hWnd))
End Function
' Declare Function DeleteObject Lib "gdi32" Alias "DeleteObject" _
' (ByVal hObject As Long) As Long
Function DeleteObject(hObject)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "DeleteObject", "i=l", "f=s", "r=l"
DeleteObject = oDW.DeleteObject(CLng(hObject))
End Function
' Declare Function DestroyWindow Lib "user32" Alias "DestroyWindow" _
' (ByVal hWnd As Long) As Long
Function DestroyWindow(hWnd)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "DestroyWindow", "i=l", "f=s", "r=l"
DestroyWindow = oDW.DestroyWindow(CLng(hWnd))
End Function
' Declare Function GetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
Private Function GetDesktopWindow()
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "GetDesktopWindow", "f=s", "r=h" ' no inputs
GetDesktopWindow = oDW.GetDesktopWindow()
End Function
Private Function GetWindowLong(hWnd, nIndex)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "GetWindowLong", "i=ll", "f=s", "r=l"
GetWindowLong = oDW.GetWindowLong(CLng(hWnd), CLng(nIndex))
End Function
' Declare Function GetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long
Private Function GetDC(hWnd)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "GetDC", "i=l", "f=s", "r=l"
GetDC = oDW.GetDC(CLng(hWnd))
End Function
' Declare Function SaveDC Lib "gdi32" Alias "SaveDC" (ByVal hDC As Long) As Long
Private Function SaveDC(hDC)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "SaveDC", "i=l", "f=s", "r=l"
SaveDC = oDW.SaveDC(CLng(hDC))
End Function
' Declare Function CreateCompatibleBitmap Lib "gdi32" Alias "CreateCompatibleBitmap" _
' (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Function CreateCompatibleBitmap(hDC, nWidth, nHeight)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "CreateCompatibleBitmap", "i=lll", "f=s", "r=h"
CreateCompatibleBitmap = oDW.CreateCompatibleBitmap(CLng(hDC), CLng(nWidth), CLng(nHeight))
End Function
' Declare Function CreateCompatibleDC Lib "gdi32" Alias "CreateCompatibleDC" _
' (ByVal hDC As Long) As Long
Private Function CreateCompatibleDC(hDC)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "CreateCompatibleDC", "i=l", "f=s", "r=l"
CreateCompatibleDC = oDW.CreateCompatibleDC(CLng(hDC))
End Function
' Declare Function CreatePen Lib "gdi32" Alias "CreatePen" _
' (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Function CreatePen(nPenStyle, nWidth, crColor)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "CreatePen", "i=lll", "f=s", "r=l"
CreatePen = oDW.CreatePen(CLng(nPenStyle), CLng(nWidth), CLng(crColor))
End Function
' Declare Function CreateSolidBrush Lib "gdi32" Alias "CreateSolidBrush" _
' (ByVal crColor As Long) As Long
Private Function CreateSolidBrush(crColor)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "CreateSolidBrush", "i=l", "f=s", "r=l"
CreateSolidBrush = oDW.CreateSolidBrush(CLng(crColor))
End Function
' Declare Function SelectObject Lib "gdi32" Alias "SelectObject" _
' (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Function SelectObject(hDC, hObject)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "SelectObject", "i=ll", "f=s", "r=l"
SelectObject = oDW.SelectObject(CLng(hDC), CLng(hObject))
End Function
' Declare Function Rectangle Lib "gdi32" Alias "Rectangle" _
' (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, _
' ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Function Rectangle(hDC, X1,Y1, X2,Y2)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "Rectangle", "i=lllll", "f=s", "r=l"
Rectangle = oDW.Rectangle(CLng(hDC), CLng(X1), CLng(Y1), CLng(X2), CLng(Y2))
End Function
' Declare Function ReleaseDC Lib "user32" Alias "ReleaseDC" _
' (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Function ReleaseDC(hWnd, hDC)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "USER32.DLL", "ReleaseDC", "i=ll", "f=s", "r=l"
ReleaseDC = oDW.ReleaseDC(CLng(hWnd), CLng(hDC))
End Function
' Declare Function DeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hDC As Long) As Long
Private Function DeleteDC(hDC)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "DeleteDC", "i=l", "f=s", "r=l"
DeleteDC = oDW.DeleteDC(CLng(hDC))
End Function
' Declare Function RestoreDC Lib "gdi32" Alias "RestoreDC" _
' (ByVal hDC As Long, ByVal nSavedDC As Long) As Long
Private Function RestoreDC(hDC, nSavedDC)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "RestoreDC", "i=ll", "f=s", "r=l"
RestoreDC = oDW.RestoreDC(CLng(hDC), CLng(nSavedDC))
End Function
' Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" _
' (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, _
' ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, _
' ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
' ByVal PAF As Long, ByVal F As String) As Long
Private Function CreateFont(Ht, Wd, Es, Ox, Wt, It, Ul, St, Cs, Op, Cp, Q, PAF, sFontName)
Set oDW = nothing ' clear any previous instance
Set oDW = CreateObject("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
oDW.Register "GDI32.DLL", "CreateFontA", "i=llllllllllllls", "f=s", "r=h"
CreateFont = oDW.CreateFontA(CLng(Ht), CLng(Wd), CLng(Es), CLng(Ox), _
CLng(Wt), CLng(It), CLng(Ul), CLng(St), CLng(Cs), CLng(Op), CLng(Cp), _
CLng(Q), CLng(PAF), CStr(sFontName))
End Function
Private Sub BugAssert (bTest, sErrMsg)
Dim sDblSpace : sDblSpace = vbCrLf & vbCrLf
' BugAssert is a Bruce McKinney creation.
' It is used to test for intermediate results...
if bTest then Exit Sub ' normally (hopefully) test returns true...
MsgBox "Error Message reported by BugAssert: " & sDblSpace _
& sErrMsg & sDblSpace & " this script will terminate NOW. ", _
vbCritical, " << BugAssert FAILED in Script: " & Wscript.ScriptName & " >> "
WScript.Quit
End Sub
]]>
</script>
</component>
--------------080603000702030103020107
Content-Type: text/plain;
name="wshStatusMsgProgBarDemoScript.vbs.txt"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="wshStatusMsgProgBarDemoScript.vbs.txt"
' make an api window using DynaWrap, jw 10Dec05
Option Explicit
'
' --- description block --------------------------
' Title: A Status Message / Progressbar Utility...
'
' Description: O.K., so there are plenty of these dialogs around,
' but it was in intriguing challenge to program this
' with DynaWrap...
'
' Author: mr_unreliable
'
' Usage: Use at you own risk, tested on win98se...
'
' --- revision history ---------------------------
' 10Dec05: original attempt, using the wshATO "MakeWindow" script as inspiration...
' 11Dec05: couldn't get valid instance handle for THIS script, and so using
' the desktop instance handle, for now. (Maybe inspiration will strike later)...
' 11Dec05: in an attempt to get color into the progbar, used "SetTextColor" but
' that didn't work(?). So, used "DrawText" to draw the text (i.e., the blocks)
' to the textbox, but that apparently draws "on" the box, not "in" the box,
' that is, the image doesn't "persist" (ugh!)...
' 12Dec05: changing approach to using a static control, and inserting a bitmap
' image (i.e., a "rectangle" drawn in to resemble a progbar)...
' 14Dec05: redraw the bitmap "every time" (rather than attempting to retain/modify it)...
' 15Dec05: move the status msg / progbar dialog code to a "wsc" component,
' for the "usual reasons", i.e., "packaging"...
' --- end of description block -------------------
'
' instantiate ActX components here...
Dim oDlg : Call Instantiate_LocalWSC(oDlg, "StatusMsgProgBarDialog.wsc", "") ' no events
'
' --- module level variables ---------------------
Const m_sCaption = " << A StatusMsg / Progressbar Dialog (made with dynawrap api calls).. >> "
Const sGoodby = "Good-bye folks, and thanks for watching the show... "
'
Dim iPct, iBye ' as long
Dim sStatusMsg ' as string
'
Const tDoEvents = 300 ' 100
'
Dim crBlue : crBlue = RGB(0, 0, &HFF)
Dim crGreen: crGreen= RGB(0, &H80, &H80) ' dk cyan (a.k.a. "teal")
Dim crGrey : crGrey = RGB(&HE0, &HE0, &HE0) ' (lt grey)
' --- end of declarations and constants ----------
' ----------------------------------------------
' Note: this script is using a Progbar Dialog, (created with DynaWrap)...
' ----------------------------------------------
oDlg.pbBackColor = crGrey
oDlg.pbForeColor = crGreen ' crBlue
Call oDlg.Create_ProgbarDialog(m_sCaption, 150,150)
' ----------------------------------------------
' Demo Loop, moving along two pct per loop, to speed things up a bit...
' ----------------------------------------------
For iPct = 2 to 100 step 2
WScript.Sleep tDoEvents
' prepare "status message" text...
sStatusMsg = "Current Status: Script Processing is " & CStr(iPct) & "% complete."
' oDlg.txtStatusMessage = sStatusMsg ' set statusmsg only
' oDlg.iPctComplete = iPct ' set pct only
oDlg.PostStatusAndPct sStatusMsg, iPct ' update status msg and progbar pct...
Next ' iPct
MsgBox " ..when ready to close the progbar dialog, click OK. ", vbInformation, _
" < Pause Here to Review and Admire the Progbar Dialog Results > "
' say good-bye to all the good folks out there,
' (reset the statusmsg one last time, and "flash" it)...
For iBye = 1 to 5
oDlg.txtStatusMessage = sGoodby
WScript.Sleep 500
oDlg.txtStatusMessage = ""
WScript.Sleep 200
Next ' iBye
oDlg.CloseDialog ' (and clean up system resources)
Set oDlg = nothing
WScript.Quit
' ------------------------------------------------
' --- Get Local Directory (of this script) -------
' ------------------------------------------------
'
' Note: when fso has been instantiated, then use this:
' GetLocalDirectory = fso.GetFile(WScript.ScriptFullName).ParentFolder
'
' --- other suggestions found in the wsh ng, (mikHar)...
' set shell = createobject("wscript.shell") ' appropriate for wsh 5.6
' currentDirectory = shell.currentdirectory ' (note: not necessarily OF THIS SCRIPT)
' set fso = createobject("scripting.filesystemobject") ' for wsh 5.5
' currentDirectory = fso.getabsolutepathname(".") ' can't find this one documented(?)
' --- end of other suggestions -------------------
'
' (however, if fso or oShell are NOT instantiated, use the following code,
' it's more efficient as there are NO additional ole instantiations
' required, with all that ugly and slow "late-binding")...
'
Function GetLocalDirectory()
Const sMe = "[GetLocalDirectory], "
Dim iFile ' as integer
' find the LAST backslash...
iFile = InStrRev(Wscript.ScriptFullName, "\")
BugAssert (iFile > 0), sMe & " file path problem " ' if backslash not found...
' get the path to this script...
GetLocalDirectory = Left(Wscript.ScriptFullName, iFile) ' path (inc "\")...
End Function ' getLocalDirectory
' ================================================
' === INSTANTIATE AN UNREGISTERED WSC COMPONENT ==
' ================================================
' (Note: this technique was suggested by Mike Harris (mvp - scripting),
' see news://microsoft.public.scripting.vbscript, entitled: "wsf vs wsc",
' and timestamped: 2002-03-26 19:10:05 PST).
'
' suggested syntax:
'
' set obj = getobject("script:component path#component id")
'
' where component path can be:
' c:\mypath\mywsc.wsc
' _or_ \\server\share\mypath\mywsc.wsc
' _or_ http://server/mysite/mypath/mywsc.wsc
'
' and, #component id is optional.
' You get the 1st component in the WSC by default.
' You only need #component id if there is more than one in the WSC,
' and you want some other component than the first...
'
' A more exhaustive discussion can be found in the Windows Script Component
' documentation, at the bottom of the page entitled:
' "Using a Script Component in an Application"
' --- end of discussion --------------------------
Sub Instantiate_LocalWSC(oWSC, sComponentFileName, sEventPrefix)
' get the path to the local directory...
Dim sLocalDir : sLocalDir = GetLocalDirectory()
Dim sComponentPath : sComponentPath = sLocalDir & sComponentFileName
' MsgBox(sComponentPath)
' go get the (wsc) object...
' Set oWSC = WScript.GetObject("script:" & sComponentPath,, sEventPrefix)
' uh-oh. It appears that this approach only works with the VBS getobject
' and not the wscript.getobject flavor.
Set oWSC = GetObject("script:" & sComponentPath)
' (step two:) connect the events, (after making sure you need it)...
if (sEventPrefix <> "") then WScript.ConnectObject oWSC, sEventPrefix
End Sub ' Instantiate_LocalWSC
' --- INSTANTIATE ACTX OBJECT (or class) AND CHECK ----
' (using a sub to get this ugly instantiation code out of main line code)...
Sub Instantiate (oObject, sProgramID, sEventPrefix)
Const sME = "[sub Instantiate], "
' check variant sub-type parameters...
BugAssert (VarType(sProgramID) = vbString), sME & "sProgramID must be a STRING!"
BugAssert (VarType(sEventPrefix) = vbString), sME & "sEventPrefix must be a STRING!"
On Error Resume Next ' turn on error checking
Set oObject = WScript.CreateObject(sProgramID, sEventPrefix)
BugAssert (err.number = 0), sME & "This script requires: " & sProgramID & vbCrlf _
& " kindly INSTALL and REGISTER this ActX component... "
On Error goto 0 ' turn off error checking...
End Sub
' --- BUGASSERT (yes, it's for debugging) --------
Sub BugAssert (bTest, sErrMsg)
Dim sDblSpace : sDblSpace = vbCrLf & vbCrLf
' BugAssert is a Bruce McKinney creation.
' It is used to test for intermediate results...
if bTest then Exit Sub ' normally (hopefully) test returns true...
MsgBox "Error Message reported by BugAssert: " & sDblSpace _
& sErrMsg & sDblSpace & " this script will terminate NOW. ", _
vbCritical, " << BugAssert FAILED in Script: " & Wscript.ScriptName & " >> "
WScript.Quit
End Sub
--------------080603000702030103020107-- Tag: Virtual Path Error 0x80004005 Tag: 185175
getting information
how can i get hardware information of a printer on a particular
server,with only server name as the input?
cheers,
nuti Tag: Virtual Path Error 0x80004005 Tag: 185163
Enumerating through shares and listing out permissions
I am looking for examples of enumerating through the network shares on a
machine(XP/2003) and saving the share name, users/groups, and the permissions
to a audit file. Does anyone know how to do this or where examples can be
found? I guess I would like to add that any places that have common audit
tasks that are scripted in vbscript or something similiar for Windows systems
would be interesting as well. Thanks.
--
bscgmcc Tag: Virtual Path Error 0x80004005 Tag: 185151
Enabling windows messenging service?
Since XP SP2 came out, messenger service was disabled on workstations.
Is there some way within a script to enable the service and start the
service? I can imagine a way to start and stop the service if it is enabled,
but not disabled.
I know very, very little about scripting. If there is a way to do this, it
would be great because it would allow me to make it part of our agency's
logon script(s) so that we could use mass NET SENDs again for administrative
purposes on our LANs. Tag: Virtual Path Error 0x80004005 Tag: 185150
T Lavedas' WSH Scripts
I am using T Lavedas' WSH Scripts for msgbox function. It takes more than a
few seconds for the "msgbox" to appear. Is there any way to speed it up?
Thanks,
dra Tag: Virtual Path Error 0x80004005 Tag: 185148
Trying to get the username of the person logged in on a remote machine.
Here is the code that I have attached to a button on an Access 2000
form. I can get information such as the IP Address, Processor, RAM,
etc. However, when I try to retrieve the logged in user, it returns
nothing. Unless the person is an administrator on the machine. Can
any one help with this?
strsystem = UnitName.Value
Set objWMIService = GetObject("winmgmts:" &
"{impersonationLevel=impersonate}!\\" & strsystem & "\root\cimv2")
Set loggeduser = objWMIService.ExecQuery("select Username from
Win32_ComputerSystem")
For Each logged In loggeduser
struser = logged.Username
Next
Username.Value = Mid(struser, 9) Tag: Virtual Path Error 0x80004005 Tag: 185147
Mapping renmae works in XP/2003 not in 2000
Hey guys I can't seem to get the mapping rename to work in this script
on 2000 Workstations, it works fine on XP and 2003 the windows scripting
host is 5.6 on the 2000 workstation.
Option Explicit
Dim objNetwork, strDrive, objShell, objUNC
Dim strRemotePath, strDriveLetter, strNewName
'
on error resume next
strDriveLetter = "P:"
strRemotePath = "\\libad4\department share$"
strNewName = "Department Share"
' Section to map the network drive
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter, strRemotePath
' Section which actually (re)names the Mapped Drive
Set objShell = CreateObject("Shell.Application")
objShell.NameSpace(strDriveLetter).Self.Name = strNewName
Wscript.Echo "Check drive "& strDriveLetter & " in My Computer for " &
strNewName
WScript.Quit
I get the following error
Error: Object required: 'objShell.namespace(...)'
Code: 800A01A8
Source: Microsoft VBScript runtime error
Thanks guys! Tag: Virtual Path Error 0x80004005 Tag: 185146
Delete a certain url shortcut off a user's desktop
I have figured out the way to delete a file using vbscript, but I can't
figure out how to delete the file, off of the user's desktop, when they
log-in.
This is what I have so far, but I am not sure how to tell the Set
MyFile that the path is the desktop.
Set oShell = CreateObject("WScript.Shell")
FolderSpec = oShell.SpecialFolders("Desktop")
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.GetFile("Ceridian Time and Attendance.url")
MyFile.Delete
Any help will be greatly appreciated!
Thank you, in advance. Tag: Virtual Path Error 0x80004005 Tag: 185138
Query csv file using ado when header is not first row
Is there a way in vbscript to query a csv file using ado and use a
header when the header info is not the first row?
I want to query a file that I do not control. The first four lines
are not data. The fifth line is the header info (field names.) The
rest of the rows are the data. I have yet to find an example in
vbscript of how to tell ado to start at a particular row. I see that
this is possible using VBA in Excel. I guess I could also create the
filesystem object to create a temp file without the first four rows. I
was hoping there was a direct solution with ado.
Anyone know?
Thanks, Steve. Tag: Virtual Path Error 0x80004005 Tag: 185132
[help] how to change timezone by using VBS
Hi all:
Does anybody know if there is a way to change a computer's
timezone by using VBS.
we found our pcs' timezone are not uniform. so we expect a
script to detect and corrtect it. I found a sample on internet but it
did not work. does anyone Have a fine solution for that?
thanks for your help!
sample code:
On Error Resume Next
strComputer = "."
'Change value to reflect desired GMT offset in minutes.
intGMTOffset = -480
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer &
"\root\cimv2")
Set colCompSys = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
For Each objCompSys in colCompSys
objCompSys.CurrentTimeZone = intGMTOffset
If Err = 0 Then
Wscript.Echo "Time zone set to specified value."
Else
Wscript.Echo "Unable to set time zone."
End If
Err.Clear
Next
best regards
Denton Tag: Virtual Path Error 0x80004005 Tag: 185130
Script to set Recycled Bin properties
Hi All,
I have been trying to find a way (programatically using either WMI or
standard WSH) to set/get the properties of the Recycle Bin : Maximum size in
Percentage (applied to all drives), delete permanently or not, etc,
configuration global or independent for each drive, etc
Is there any way to do it by scripting?
Regards
Ramon Tag: Virtual Path Error 0x80004005 Tag: 185129
need to grab the name of the file??
I have the path as a string
"E:\\xxxxx\\Data\\To_PUC\\reports\\3535_12222005_072537.xml"
How do I just get the file name from that string
"3535_12222005_072537.xml"
So I would need everything the the right of the last \
Dave Tag: Virtual Path Error 0x80004005 Tag: 185126
FileSystemObject.CreateTextFile cannot create Arabic text file (Wi
Hi,
I am unable to create text file with arabic content in Windows 2000 using
IIS 5.0 using the Scripting.FileSystemObject object.
I have used and ASP file with the following code to create a text document
with Arabic content.
Set fso = Server.CreateObject("Scripting.FileSystemObject")
reportFile = Server.MapPath("../upload") & "\test.doc"
Set textStream = fso.CreateTextFile(reportFile, true, true)
textStream.Write strFileContent
Set textStream = nothing
The variable strFileContent contains the Arabic text.
My development environment is Win XP SP 2 / IIS 5.1 and the above code works
perfectly fine creating an Arabic word document. The dev system also has
Microsoft Office 2003.
The staging environment is Win 2000 / IIS 5.0 and DO NOT have any Office
system.
However, when I run the ASP file in the staging system, it creates the text
file but with junk data (non Arabic).
In the staging system I could type arabic in a notepad (My inference is that
UNICODE is available on my staging server).
Could you help please?
Thanks.
--
Nahom Tijnam
Dubai, UAE Tag: Virtual Path Error 0x80004005 Tag: 185121
rename file function
How do I rename three system files even if the renamed files already
exists?
I get an error that object "msi.dll" is required.
***************************************************************
Dim objShell
Dim fileSys
Dim fFile
Set objShell = CreateObject("WScript.Shell")
Set filesys = CreateObject("Scripting.FileSystemObject")
WindowsDir = fileSys.GetSpecialFolder(1).Path
wscript.echo "******* Repairing Windows Installer "
wscript.echo " Please Wait ....."
wscript.echo ""
Myarray = Array("msi.dll","msiexec.exe","msihnd.dll")
For Each fFile In MyArray
If fileSys.FileExists(WindowsDir & fFile & ".bak") Then
fileSys.DeleteFile(WindowsDir & fFile), True
End If
fileSys.MoveFile WindowsDir & fFile, WindowsDir & "\temp\" & fFile.bak
Next
Set objShell = Nothing
Set fileSys = Nothing Tag: Virtual Path Error 0x80004005 Tag: 185119
Run Access Report from Web Page
I am an Assembler Programmer who is not a bad VB programmer with very little
Web experience. I am helping several small school districts with a request.
I need to know if there is a command line or script that can run a report
within access on the server when a client requests a certain page.
FYI: The information is the University requesting a student's test scores.
The report will naturally show the university who has the high school
passwords so that the school knows who requested the information.
All I want to do is add this to an existing page in asp.
Thanks for any help
Len Tag: Virtual Path Error 0x80004005 Tag: 185118
vbScript to detect DC
Does anyone have a small vbScript function that can determine if the machine
running the script is a Domain Controller or not??
Thanks,
Troy Tag: Virtual Path Error 0x80004005 Tag: 185111
open any file with vbscript ?
Dear vbscript experts,
Is it possible with vbscript to open a file no knowing which application it
corresponds to ? For example, if extension is xls it should start Excel, if
extension is psd it should open photoshop, etc.
Thank you !
Jean-Marie Tag: Virtual Path Error 0x80004005 Tag: 185108
ForeignSecurityPrincipals
I am trying to develop an informal login script. Users are from one
domain and the server is in another. Trust has been established. I
need to determine if the user is in a group, the group is not in the
same domain as the user. I can list the members of the group but it
shows the user's Foreign Security Principal. I would like to determine
what the logged on users's FSP is and use that for the isMember or
compare the strings or something. Any ideas how to enumerate the
objects in the ForeignSecurityPrincipals container? Tag: Virtual Path Error 0x80004005 Tag: 185105
Applying Registry ACLs with VBS
Hi everyone,
Is it possible to apply/enforce ACLs in the registry with the use of VBS?
Can this post get a code example?
Thank you,
rusga Tag: Virtual Path Error 0x80004005 Tag: 185102
Document.Location ...
Hi, all,
The very same statement: Document.Location = "default.htm" works in some ASP
file but not the other. I would like to know why and how to get around. For
example, it works on 'code #1' and it gave me error: "Object 'Document' not
defined" on 'code #2'. I appreciate your help. - Fan
Here are particials of the codes:
------------------------
<!-- Code #1 -->
<HTML>
<HEAD>
<SCRIPT LANGUAGE="VBScript">
Sub ConfirmRemove
Set Form = Document.RemoveForm
Dim Anychecked
Anychecked = 0
FOR EACH product in Form.ProductID
IF product.Checked THEN
Anychecked = Anychecked + 1
END IF
NEXT
IF Anychecked > 0 THEN
removeconfirmed = MsgBox ("Remove the selected product(s)?", vbYesNo)
IF removeconfirmed = 6 THEN
MsgBox "Removing..."
document.RemoveForm.submit
END IF
ELSE
rtn = MsgBox ("No record set to remove. Return to Main Menu?", vbYesNo)
IF rtn = 6 THEN
Document.Location = "default.htm"
END IF
END IF
END Sub
</SCRIPT>
</HEAD>
<BODY>
.... (more codes here)
</HTML>
-----------------------------------------------------------------------
<!-- Code #2 -->
<HTML>
....
<BODY>
<%
sqlcmd = "DELETE Products WHERE productID = " & Request.Form("ProductID")
cn = Session("cnn")
Set cmd = Server.CreateObject("ADODB.Command")
cmd.CommandText = sqlcmd
cmd.ActiveConnection = cn
On Error Resume Next
cmd.Execute nRecordsAffected
If Err Then
'codes for pop-ups here
Document.Location = "default.htm"
Else
'codes here to display removed item
End If
%> Tag: Virtual Path Error 0x80004005 Tag: 185099
Parsing xml file in .asp page
I'm trying to parse xml file using asp in Windows 2006 service pack 4.
I got Object required error. What is wrong with the code? any help is
appreciated.
<%
Dim objXML, objDocElem, objNodes
Dim x
Set objXML = Server.CreateObject("Microsoft.XMLDOM")
objXML.async = False
objXML.load("mycomputer.xml")
Set objNodes = objXML.documentElement.childNodes
For x = 0 To objNodes.length
Response.Write objNodes.item(x).nodeName & ": " & objNodes.item(x).text
& "<br>"
Next Tag: Virtual Path Error 0x80004005 Tag: 185098
Mail Enable Users
I have written this script but this script is not mail enabling users.
I don't get any errors but for some reason it is not working. Would
someone tell me what might be wrong with this?
Dim sUser, sMailNick, oUser, sLastName, sFirstName, sUserName,
sDisplayName, sLine, sDN
Const ForReading = 1
Set oFSO = CreateObject("scripting.filesystemobject")
Set oTF = oFSO.OpenTextFile("d:\AD Scripts\mailenable.txt", ForReading,
True)
Do Until oTF.AtEndOfLine
sLine = oTF.ReadLine
sUserName = sLine
WScript.Echo sUserName
sMail = sUserName
sMailNick=sUserName
sDN=UserNameDN(sUserName)
WScript.Echo "DN is " & sDN
'sUser = "LDAP://xx/" & sDN
'wScript.Echo sUser
Set oUser = GetObject("LDAP://xx/" & sDN)
sLastName=oUser.sn
wscript.echo sLastName
sFirstName=oUser.cn
wscript.echo sFirstName
sDisplayName=sLastName & ", " & sFirstName
wscript.echo sDisplayName
If oUser.mail="" Then
oUser.put "mail", sMail & "@xx.yy"
oUser.put "mailNickname", sMailNick
oUser.put "displayName", sDisplayName
oUser.put "proxyAddresses", Array("SMTP:" & sMail & "@xx.yy", "smtp:" &
sMail & "@xx.yy")
oUser.put "targetAddress", "SMTP:" & sMail & "@xx.yy"
wscript.echo oUser.mail
wscript.echo oUser.mailNickname
wscript.echo oUser.displayName
wscript.echo oUser.targetAddress
Else
wscript.echo "Already Exists"
End If
Loop
Public Function UserNameDN(sUserName)
On Error Resume next
Set oRootDSE = GetObject("LDAP://rootDSE")
Set oConnection = CreateObject("ADODB.Connection")
oConnection.Open "Provider=ADsDSOObject;"
Set oCommand = CreateObject("ADODB.Command")
oCommand.ActiveConnection = oConnection
oCommand.CommandText = "<LDAP://" &
oRootDSE.get("defaultNamingContext") &
">;(&(objectCategory=User)(samAccountName=" & _
sUserName & "));distinguishedName;subtree"
Set oRecordSet = oCommand.Execute
UserNameDN = oRecordSet.Fields("distinguishedName")
If Err <> 0 Then
outFile.WriteLine "There was an error getting the DN for " &
strUser & "." & " " & Err.Num
strBadCount = strBadCount + 1
End If
Err.Clear
On Error Goto 0
End Function Tag: Virtual Path Error 0x80004005 Tag: 185096
creating xml file using asp (vbscript)
I'm trying to write a recordset to an xml file.. and I get this error:
gave WRITE access to the folder where i store the xml file --> still
didnt work
gave IUSR write access --> still didnt work
msxml4.dll (0x80070005)
Any help is appreciated.
Access is denied.
The code is below:
set cn = server.CreateObject("adodb.connection")
cn.connectionstring = "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=C:\Program Files\Microsoft
Office\OFFICE11\SAMPLES\Northwind.mdb;Persist Security Info=False"
cn.open
'CREATE XML FILE
dim xmlDoc
set xmlDoc = server.CreateObject("MSXML2.DOMDocument.4.0")
if (xmlDoc.childNodes.length = 0) then
set root = xmldoc.createNode("element", "Northwind", "")
xmldoc.appendchild(root)
set rs = cn.Execute("spGetEmployees")
while not rs.eof
set onode = xmldoc.createNode("element", "Employee", "")
xmldoc.documentElement.appendchild(onode)
set inode = xmldoc.createNode("element", "ID", "")
inode.text = rs.fields(0)
onode.appendchild(inode)
set inode = xmldoc.createNode("element", "FirstName", "")
inode.text = rs.fields(1)
onode.appendchild(inode)
set inode = xmldoc.createNode("element", "LastName", "")
inode.text = rs.fields(2)
onode.appendchild(inode)
rs.movenext
wend
set rs = nothing
end if
strPath = Server.MapPath("/tstsvr/")
xmldoc.save strPath & "saved.xml" Tag: Virtual Path Error 0x80004005 Tag: 185093
(null) 0x8000500D crash on LastLogin
My script crashes on various users whose account apparently are in some
states that's cause LDAP a problem. I query like:
Set cLanAccounts = GetObject("LDAP://server/cn=Name, OU=name, dc=name,
dc=name")
cLanAccounts.Filter= Array("user")
for each oUser in cLANAccounts
wscript.echo oUser.LastLogin
.
.
No matter how I hit LastLogin (TypeName, IsNull, etc) they all crash and
produce the same error for some users. I have ON ERROR RESUME NEXT set but
it still crashes.
Any ideas how to detect this state and avoid the crash? Tag: Virtual Path Error 0x80004005 Tag: 185092
VB Script Error Message
I just started receiving an error message in my VB Script. It seems to be
working on some servers, but not on others. The purpose of the script is to
archive security logs from servers. On other servers it fails and I'm
wondering what the issue could be.
Error Message:
D:\Brandon\Double_B\newscript.vbs(38, 3) SWbemObjectEx: Access denied
Script:
'set desired values here:
'remoteDumpFile = "C:\" & Date() & ".evt" 'dump file path on each remote
machine
Dim strDate
strDate = CStr(Date())
strDate = Replace(strDate, "/", "-")
remoteDumpFile = "C:\" & strDate & ".evt" 'dump file path on each remote
machine
centralDumpPath = "\\TROSSDB01\Logfiles"
'Create a FileSystemObject
Set oFS = CreateObject("Scripting.FileSystemObject")
'Open a text file of computer names ON LOCAL MACHINE WHERE SCRIPT'S RUNNING
'with one computer name per line
Set oTS = oFS.OpenTextFile("C:\Double_B\servers.txt")
'go through the text file
Do Until oTS.AtEndOfStream
'get next computer
sComputer = oTS.ReadLine
'connect to the WMI provider
Set oWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate,(Security,Backup)}!\\" & _
sComputer & "\root\cimv2")
'query the Security logs
Set cLogFiles = oWMIService.ExecQuery _
("Select * from Win32_NTEventLogFile where " & _
"LogFileName='Security'")
'go through the collection of logs
For Each oLogfile in cLogFiles
'back up the log to a file LOCAL ON THAT REMOTE MACHINE
errBackupLog = oLogFile.BackupEventLog(remoteDumpFile)
'see if an error occured
If errBackupLog <> 0 Then
'one did - display an error
Wscript.Echo "Couldn't get log from " & sComputer & ". Error code: " &
errBackupLog
Else
'no error - safe to clear the Log
oLogFile.ClearEventLog()
'now copy dump file from remote machine to central store
oFS.CopyFile "\\" & sComputer & "\" & Replace(remoteDumpFile, ":", "$"),
centralDumpPath & "\" & sComputer & "\" & strDate & ".evt"
'delete dump file from remote machine
oFS.Deletefile "\\" & sComputer & "\" & Replace(remoteDumpFile, ":", "$")
End If
Next
Loop
'close the input file
oTS.Close Tag: Virtual Path Error 0x80004005 Tag: 185089
IIS6 configuration with vbs, set "Recyling working processes" prop
Hi,
I have a vbs script wich makes a new application pool in IIS6, named test:
Option Explicit
dim basepath : basepath = "IIS://localhost/w3svc/1/root"
dim AppPoolName : AppPoolName = "test"
if CreateNewAppPool(AppPoolName) = false then
WScript.Echo "Error creating AppPool "
WScript.Quit
end if
function CreateNewAppPool(AppPoolName)
dim AppPools, newAppPool
set AppPools = GetObject("IIS://localhost/w3svc/AppPools")
set newAppPool = AppPools.Create("IIsApplicationPool", AppPoolName)
newAppPool.LogonMethod =1
newAppPool.AppPoolIdentityType=3
newAppPool.SetInfo
if err = 0 then
CreateNewAppPool = True
else
CreateNewAppPool = false
end if
end function
How is it possible to set the pool
"Recycle workin processes" to some value eg. 60 minutes with vbs script ?
Regards
Jarmo Tag: Virtual Path Error 0x80004005 Tag: 185088
Speeding up a XCOPY batch job???
(not really sure which forum this goes under, so.....)
Setting up a new server. I need to move about ~40GB of users files to the
new server. I could use a tape or NAS backup to copy the files to the new
server, or use a XCOPY script I wrote as a simple batch file.
Now my question is this: If I run the XCOPY script from a faster machine
(than the destination server), will the process complete quicker? Or does
the actual XCOPY process run on the source server? We have a quad-Xenon
server I could run the batch file off of, but the source server & destination
server are P3 machines.
Thanks for any help/suggestions Tag: Virtual Path Error 0x80004005 Tag: 185087
Detecting logoff?
I needed a simple way to log the start and end time of an application
that users start using a shortcut. So I made a little VBScript which
logs the start time and username, then launches the application and
waits until it closes, then logs the close time and exits. This works
if the users close the application themselves, but fails to log the
close event if the session is terminated due to any other reason (e.g.,
timeout: this is on a Citrix server.)
I know there are several other ways of achieving what I am trying,
especially facilities provided by Citrix, but I'm just wondering how to
make my simple approach work. It seems to me that at the time of a
session logoff, Windows doesn't kill the running processes in a
bottom-up manner. If the launched application had ended before the
mshta session, then maybe the script would have been able to log the
close event also. Can you suggest some approach that can make this
work? If you need to see the script, I can post it after some changes.
Thanks in advance. Tag: Virtual Path Error 0x80004005 Tag: 185083
xmlhttp headers possible?
Hi All,
Is it possible to simulate posting data between a html form page and an asp
page using the following:
1. xmlhttp get to pull down the html data and header information (using
getAllResponseHeaders)
2. xmlhttp setRequestHeader to set header info for variables pulled in step
1 in prep for the post
3. xmlhttp post to simulate the actual filling out of the form
TIA for any info.
-John Tag: Virtual Path Error 0x80004005 Tag: 185072
Uptime
Greetings all,
I got the following script from this group a while ago. I have two
questions. First, how can I have it run against a csv or txt file with
computer names and login info, also, I would like the data to be output
to a file that I can then manipulate.
Thanks for the help.
aaron
strComputer = "." ' "." for local computer
On Error Resume Next
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer _
& "\root\cimv2")
If Err.Number = 0 Then
On Error Goto 0
strQuery = "select * from Win32_PerfRawData_PerfOS_System"
Set colObjects = objWMIService.ExecQuery(strQuery)
For Each objWmiObject In colObjects
intPerfTimeStamp = objWmiObject.Timestamp_Object
intPerfTimeFreq = objWmiObject.Frequency_Object
intCounter = objWmiObject.SystemUpTime
Next
' Calculation in seconds:
'Calculations for Raw Counter Data:PERF_ELAPSED_TIME
'http://msdn.microsoft.com/library/en-us/perfmon/base/perf_elapsed_tim...
iUptimeInSec = (intPerfTimeStamp - intCounter)/intPerfTimeFreq
WScript.Echo "Uptime in seconds: " & iUptimeInSec \ 1
' convert the seconds
sUptime = ConvertTime(iUptimeInSec)
WScript.Echo "Uptime: " & sUptime
Else
Wscript.Echo "Could not connect to computer with WMI: " _
& strComputer
End If
Function ConvertTime(seconds)
ConvSec = seconds Mod 60
ConvMin = (seconds Mod 3600) \ 60
ConvHour = (seconds Mod (3600 * 24)) \ 3600
ConvDays = seconds \ (3600 * 24)
ConvertTime = ConvDays & " days " & ConvHour & " hours " _
& ConvMin & " minutes " & ConvSec & " seconds "
End Function Tag: Virtual Path Error 0x80004005 Tag: 185070
How to monitor file creation on a remote server?
I'm using the code from 'Hey Scripting Guy' that explains how to
"Automatically Run a Script Any Time a File is Added to a Folder":
http://www.microsoft.com/technet/scriptcenter/resources/qanda/oct04/hey1011.mspx
I've tweaked it a bit to suit my needs, and it works great - if I run
it locally on a remote server that I'm logged into. I need to have it
run on the remote server when I'm not logged in; perhaps as a scheduled
task. I need it to check every 5 minutes to see if any new files have
been added to the folder.
Any help would be greatly appreciated. Thanks!
(watch for word wrap)
===== BEGIN Monitor_Build_Folder.vbs ====================
Const OverwriteExisting = TRUE
SourceFolder = "D:\Projects\Gateway\DevRev.2.2.1\Build"
SourceFolder = Replace(SourceFolder, "\", "\\\\")
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceCreationEvent WITHIN 300 WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=""" & SourceFolder & """'")
Do
Set objLatestEvent = colMonitoredEvents.NextEvent
' Extract just the new file name
arrFilePath = Split(objLatestEvent.TargetInstance.PartComponent,
"\\")
strFileName = arrFilePath(UBound(arrFilePath))
' Remove quotes from the new file name
If Right(strFileName, 1) = """" Then
strFileName = Left(strFileName, Len(strFileName) - 1)
End If
SourceFolder = "D:\Projects\AgencyGateway\DevRev.2.2.1\Build\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile SourceFolder & strFileName ,
"D:\Projects\Gateway\DevRev.2.2\Build\", OverwriteExisting
Loop
===== END Monitor_Build_Folder.vbs ==================== Tag: Virtual Path Error 0x80004005 Tag: 185065
Enumerate Digital Certificates with vbscript?
Is it possible to do this? I can't find any reference to this anywhere.
Looks like there is a class that can be called from VB, but not
vbscript. Basically I'd like to query remote web servers and see what
certificates they have installed.
Thanks,
Chris Bodnar Tag: Virtual Path Error 0x80004005 Tag: 185064
HTML tables and APS help PLEASE!!
Ok here is the problem there are 8 root ids, and then there are a bunch
of categories for each root. Now when you diplay catagories the user
has the option to narrow down the catagories.
My problem is when i reach to the point where there is only 3 roots
that diplay the ending section of my table doesn't display..
Code..
If session("end_root") = "false" Then
Response.write "<BR><B>Category Matches</B>"
response.write "<table CLASS=tableA border = 1 >"
response.write "<tr>"
Do While Not rsRoot.EOF AND NOT current_root = rsRoot("description")
count = 0
current_root = rsRoot("description")
Set objCat = NEW taxonomyclass
Set rsCat = objCat.ShowCat(CInt(rsRoot("taxid")))
seperate_cat_count = 0
'response.write "<BR>rsRoot.recordcount = " &rsRoot.RecordCount&
"<BR>"
Do While Not rsCat.EOF
If not CInt(rsCat("taxid")) = find_in_array(CInt(rsCat("taxid")))
AND NOT rsCat.RecordCount = 0 AND NOT rsCat("Taxid") =
request("taxstring") Then
If NOT rsCat.RecordCount = 0 AND count = 0 Then
IF root_count MOD 4=0 THEN
end_table = 1
response.write "<TD VALIGN=TOP>"
response.write "<BR>1st-Start<BR>"
'response.write "<table CLASS=tableA border = 1>"'Middle tables
'response.write "<TR>"
End If
response.write "<BR><B>" &rsRoot("description")& "("
&rsCat.RecordCount& ")</B><BR> "
root_count = root_count + 1
count = 1
End If
Response.write "<B><A
HREF='Directory.asp?TypeSearch=Drill&taxstring=" & rsCat("taxid") &
"'>" & rsCat("name") & "</A></B>("&rsCat("count(taxonomy.taxid)")&")"
response.write "      "
seperate_cat_count = seperate_cat_count + 1
If seperate_cat_count MOD 3 = 0 Then
response.write "<BR>"
End If
If seperate_cat_count = rsCat.RecordCount Then
response.write "<BR>"
End If
recordCount = recordCount + 1
IF root_count MOD 4=0 OR root_count MOD 3=0 OR root_count MOD 2=0
OR root_count MOD 1=0 AND count = 0 Then
IF rsCat.RecordCount = seperate_cat_count THEN
response.write "<BR> 2nd-Stop<BR>"
end_table = 0
'response.write "</TR>"
'response.write "</table>"'Middle table
End If
End If
End If
rsCat.MoveNext
Loop
IF root_count MOD 4=0 THEN
response.write "</TD>"
End If
Set objCat = nothing
Set rsCat = nothing
rsRoot.MoveNext
Loop
response.write "</tr>"
response.write "</table>"
If recordCount = 1 Then
session("end_root") = "true"
End If
response.write "<BR>root_count = "&root_count& "<BR>"
End If
Any help idea will help
-Jimi Tag: Virtual Path Error 0x80004005 Tag: 185060
How do you call com in VBS
hi
in JS i would call a locally installed COM object by
var tst = new ActiveXObject("test.Srv");
and use thus
var myData = tst.GetInfo();
how do I do this in VBScript?
Thanks Tag: Virtual Path Error 0x80004005 Tag: 185052
Retry IP checking script
I wrote this script about a month ago..... seemed to not be able to get
it to work... I need it to check for some IP ranges and do a task.....
But it seems to be defaulting to do the task regardless of whatever
address the workstation is....
Option Explicit
Dim CurrentAddress, strComputer, objWMIService, IPConfigSet, IPConfig,
i, msg, range, ok
msg = "Migration process complete!"
ok = True
prt "Initial value of ok is: " & ok
strComputer = "."
Set objWMIService =
GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer
& "\root\cimv2")
Set IPConfigSet = objWMIService.ExecQuery ("SELECT * FROM
Win32_NetworkAdapterConfiguration WHERE IPEnabled=true")
If IPConfigSet.Count > 0 Then
For Each IPConfig in IPConfigSet
If Not IsNull(IPConfig.IPAddress) Then
For i = 0 to UBound(IPConfig.IPAddress)
CurrentAddress=IpConfig.IPAddress(i)
Select Case True
Case CurrentAddress>="10.150.136.1 "
prt "Case 1 value of ok is " & ok
prt CurrentAddress
range = "a"
case CurrentAddress>="10.150.128.1"
range = "b"
case CurrentAddress>="10.150.120.1"
range = "c"
Case Else
prt "Failed lower boundry out of migration IP range."
ok = False
End Select
prt "Value of ok is: " & ok
if ok Then
prt "Checking upper boundary"
select case range
Case "a"
If CurrentAddress<="10.150.143.254" Then WScript.Echo
CurrentAddress
migrate CurrentAddress
case "b"
if CurrentAddress<="10.150.135.254" then migrate
CurrentAddress
case "c"
if CurrentAddress<="10.150.127.254" then migrate
CurrentAddress
case else
msg = "out of migration IP range."
end select
end if
Next
End If
Next
End If
prt msg
Sub migrate(CurrentAddress)
' put migration code here
prt "Migrating " & CurrentAddress & "..."
End Sub
Sub prt(str)
wscript.echo str
End Sub
Can someone please give some insight or know why......
Thanks in advance..... Tag: Virtual Path Error 0x80004005 Tag: 185050
adding a remote printer
I am trying to add a printer to a remote PC the PC I want to add the printer
to in this instance is called usxp20015. The server that holds the printers
is usprintserver
rundll32 printui.dll,PrintUIEntry /c \\usxp20015 /in /q
/n\\usprintserver\printer-7
When I run the command above it adds a printer-7 on my local PC does anyone
know what I am doing wrong or should I use a different script to do theses
tasks.
thanks for any help
Sammy Tag: Virtual Path Error 0x80004005 Tag: 185046
newbie: Help with basic code please...
Hi, i found this script in scriptomatic to get the status of
MSPower_DeviceEnable property on my network device.
I need to disable it in an array of computers via script...
How i must change the code my friends???
Thank you very much..
On Error Resume Next
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
arrComputers = Array("localhost")
For Each strComputer In arrComputers
WScript.Echo
WScript.Echo "=========================================="
WScript.Echo "Computer: " & strComputer
WScript.Echo "=========================================="
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\WMI")
Set colItems = objWMIService.ExecQuery("SELECT * FROM
MSPower_DeviceEnable", "WQL", _
wbemFlagReturnImmediately +
wbemFlagForwardOnly)
For Each objItem In colItems
WScript.Echo "Active: " & objItem.Active
WScript.Echo "Enable: " & objItem.Enable
WScript.Echo "InstanceName: " & objItem.InstanceName
WScript.Echo
Next
Next Tag: Virtual Path Error 0x80004005 Tag: 185040
Dictionary inside Array inside Dictionary
I wanted to use multiple arrays inside multiple dictionaries.
I get it right to add it in, but I'm having trouble getting it out.
I send the value of tmpArr to a function (getSubs) which returns a
second array. This second array is then added to the first as a
dictionary, etc.
The end result looks like this:
1 = tmpArr = ("a","b","c")
2 = tmpArr = (("d","e","f"), ("d","e","f"),
("d","e","f"))
3 = tmpArr = ((("d","e","f"), ("d","e","f"),
("d","e","f")), (("d","e","f"),
("d","e","f"), ("d","e","f")) ,
(("d","e","f"), ("d","e","f"),
("d","e","f")))
tmpArr = ("a","b","c")
Set tmpSubs = CreateObject("Scripting.Dictionary")
for j = 0 to ubound(tmpArr)-1
tmpArr2 = getSubs(tmpArr(j))
'2--------------
Set tmpSubs2 = CreateObject("Scripting.Dictionary")
for m = 0 to ubound(tmpArr2)-1
tmpArr3 = getSubs(tmpArr2(m))
tmpSubs2.Add tmpArr2(m), tmpArr3
tmpArr2(m) = tmpSubs2.Item(tmpArr2(m))
next
tmpSubs2.RemoveAll
tmpSubs.Add tmpArr(j), tmpArr2
tmpArr(j) = tmpSubs.Item(tmpArr(j))
'2---------------
next
tmpSubs.RemoveAll
userSubs.Add allInfo(0,i), tmpArr
end if
next
function getSubs(nme)
arr = ("d","e","f")
getSubs = arr
end function
To get it out, I'm using the items.
The end result looks like this:
1= 3
2= 3*
3= 0 = True** (True means that there is an array, but with ubound = 0)
a = userSubs.Items
For i = 0 To userSubs.Count -1
response.Write("1= " & ubound(a(i)) & "<BR>")
for j = 0 to ubound(a(i))-1
response.Write("2= " & ubound(a(i)(j)) & "*<BR>")
for k = 0 to ubound(a(i)(j))-1
response.Write("3= " & ubound(a(i)(j)(k)) & " = ")
response.Write(isArray(a(i)(j)(k)) & "**<BR>")
next
next
response.Write("<BR>")
Next
I want to write/get the information out so it looks like:
tmpArr = ((("d","e","f"), ("d","e","f"),
("d","e","f")), (("d","e","f"),
("d","e","f"), ("d","e","f")) ,
(("d","e","f"), ("d","e","f"),
("d","e","f")))
I used "d,e,f", but the array will depend on database values, so I
cannot simply call for a("d").
Help will be appreciated. Tag: Virtual Path Error 0x80004005 Tag: 185039
Finding application window
I want to find a particular application window (console session) , activate
that window and then enter text into the window. Can this be achieved with
vbscript? Tag: Virtual Path Error 0x80004005 Tag: 185038
cdo messages to sql srv database
hi,
I use CDO and ASP to read the folders (created during installation) of
IIS5 on windows 2000 under the
Inetpub\mailroot\ folder/
What methods do I need to take to :
-move incoming messages to sql srv database
-save a copy of outgoing message to sql srv database
Doobey Tag: Virtual Path Error 0x80004005 Tag: 185035
Information from multiple computers
The following script is to change the pathes on multiple machines
however it only changes the path on the local machine what am I
missing?
Option Explicit
Dim objFSO, objShell, Environment
Dim strFilter1, strFilter2, strPath, PathEntries
Dim strContainer, strDate, strFilePath, objTextFile, strOutputFile
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = createobject("wscript.shell")
Set Environment = objShell.Environment("System")
strFilter1 = "\\lps18086\hyper$"
strFilter2 = "\\lps18086\hyper$\reporting"
strPath = Environment("Path")
PathEntries = Split(strPath, ";")
strContainer = "dc=domain,dc=int"
strDate = Replace(Date, "/", "")
strFilePath = objFSO.GetAbsolutePathName(".")
Set objTextFile = objFSO.OpenTextFile (strFilePath & "\HyperCheck-" &
strDate & ".txt", ForWriting, True)
strOutputFile = strFilePath & "\HyperCheck-" & strDate & ".txt"
Dim objConnection, objCommand, strQuery, objRecordSet
Dim n, Entry, List
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
On Error Resume Next
objConnection.Provider = ("ADsDSOObject")
objConnection.Open "Active Directory Provider"
If Err <> 0 Then
HandleError Err, "Unable to connect to AD Provider with ADO."
End If
objCommand.ActiveConnection = objConnection
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.Properties("Page Size") = 1000
strQuery = "SELECT CN " _
& "FROM 'LDAP://" & strContainer & "' WHERE objectCategory='computer'"
objCommand.CommandText = strQuery
Set objRecordSet = objCommand.Execute
If Err <> 0 Then
HandleError Err, "Unable to execute ADO query."
End If
WScript.Echo "Gathering data from Active Directory ..."
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
If Left(objRecordSet.Fields("CN").Value, 5) = "wkstn" Then
For n = 0 to UBound(PathEntries)
wscript.echo strpath
Entry = PathEntries(n)
If LCase(Entry) = LCase(strFilter1) Then
PathEntries(n) = ""
ElseIf LCase(Entry) = LCase(strFilter2) Then
PathEntries(n) = ""
ElseIf Trim(Entry) <> "" Then
PathEntries(n) = Entry & ";"
Else
PathEntries(n) = ""
End If
Next
strPath = Join(PathEntries, "")
Environment("Path") = strPath
List = objRecordSet.Fields("CN").Value & vbTab & Environment("Path")
& vbCrLf
'wscript.echo List
End If
objRecordSet.MoveNext
Loop
If Err <> 0 Then
HandleError Err, "Unable to gather data."
End If
WScript.Echo "Writing data to text file ..."
objTextFile.Writeline List
WScript.Echo "Data written to " & strOutputFile
objTextFile.Close
'Handle errors
Sub HandleError(Err, strMsg)
On Error Resume Next
WScript.Echo " " & strMsg & vbCrLf & vbCrLf &_
" Error Number: " & Err.Number & vbCrLf &_
" Source: " & Err.Source & vbCrLf &_
" Description: " & Err.Description
WScript.Quit
End Sub Tag: Virtual Path Error 0x80004005 Tag: 185025
Scripts for uploading/downloading and zipping/unzipping folders
I need a few sample scripts for the following tasks:
- to upload a folder via ftp
- to zip and upload a folder via ftp
- to upload a file via ftp
- to unzip and download a folder via ftp
- to download a file via ftp
- to schedule a script
It's quite urgent and any help would highly be appreciated.
Thank you.
Kam Tag: Virtual Path Error 0x80004005 Tag: 185022