I have used the following code to get bandwidth
It works but i have following doubts
1.I need Total Internet Data transferred in MB, how do i convert?, total data transferred (download+upload) varies with other bandwidth monitoring applications. how do i get exact data transferred?
2.I need to exclude file transfer in local LAN in Data Transfer, The follwoing method includes internet data transfer + Local file transfer
Option Explicit
Public Enum OperationalStates
MIB_IF_OPER_STATUS_NON_OPERATIONAL = 0
MIB_IF_OPER_STATUS_UNREACHABLE = 1
MIB_IF_OPER_STATUS_DISCONNECTED = 2
MIB_IF_OPER_STATUS_CONNECTING = 3
MIB_IF_OPER_STATUS_CONNECTED = 4
MIB_IF_OPER_STATUS_OPERATIONAL = 5
End Enum
Public Enum InterfaceTypes
MIB_IF_TYPE_OTHER = 1
MIB_IF_TYPE_ETHERNET = 6
MIB_IF_TYPE_TOKENRING = 9
MIB_IF_TYPE_FDDI = 15
MIB_IF_TYPE_PPP = 23
MIB_IF_TYPE_LOOPBACK = 24
MIB_IF_TYPE_SLIP = 28
End Enum
Public Enum AdminStatuses
MIB_IF_ADMIN_STATUS_UP = 1
MIB_IF_ADMIN_STATUS_DOWN = 2
MIB_IF_ADMIN_STATUS_TESTING = 3
End Enum
Private Const MAXLEN_IFDESCR As Integer = 256
Private Const MAXLEN_PHYSADDR As Integer = 8
Private Const MAX_INTERFACE_NAME_LEN As Integer = 256
Private Const ERROR_NOT_SUPPORTED As Long = 50
Private Const ERROR_SUCCESS As Long = 0
Private Type MIB_IFROW
wszName(0 To 511) As Byte
dwIndex As Long '// index of the interface
dwType As Long '// type of interface
dwMtu As Long '// max transmission unit
dwSpeed As Long '// speed of the interface
dwPhysAddrLen As Long '// length of physical address
bPhysAddr(0 To 7) As Byte '// physical address of adapter
dwAdminStatus As Long '// administrative status
dwOperStatus As Long '// operational status
dwLastChange As Long
dwInOctets As Long '// octets received
dwInUcastPkts As Long '// unicast packets received
dwInNUcastPkts As Long '// non-unicast packets received
dwInDiscards As Long '// received packets discarded
dwInErrors As Long '// erroneous packets received
dwInUnknownProtos As Long
dwOutOctets As Long '// octets sent
dwOutUcastPkts As Long '// unicast packets sent
dwOutNUcastPkts As Long '// non-unicast packets sent
dwOutDiscards As Long '// outgoing packets discarded
dwOutErrors As Long '// erroneous packets sent
dwOutQLen As Long '// output queue length
dwDescrLen As Long '// length of bDescr member
bDescr(0 To 255) As Byte '// interface description
End Type
Private m_lngBytesReceived As Long
Private m_lngBytesSent As Long
Private Declare Function GetIfTable _
Lib "IPhlpAPI" (ByRef pIfRowTable As Any, _
ByRef pdwSize As Long, _
ByVal bOrder As Long) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (ByRef pDest As Any, _
ByRef pSource As Any, _
ByVal Length As Long)
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Public Property Get BytesReceived() As Long
BytesReceived = m_lngBytesReceived
End Property
Public Property Get BytesSent() As Long
BytesSent = m_lngBytesSent
End Property
Public Function InitInterfaces() As Boolean
Dim arrBuffer() As Byte
Dim lngSize As Long
Dim lngRetVal As Long
Dim Name As String
Dim lngRows As Long
Dim lngRow As Long
Dim i As Integer
Dim j As Integer
Dim IfRowTable As MIB_IFROW
On Error GoTo err
lngSize = 0
m_lngBytesReceived = 0
m_lngBytesSent = 0
lngRetVal = GetIfTable(ByVal 0&, lngSize, 0)
If lngRetVal = ERROR_NOT_SUPPORTED Then
Exit Function
End If
ReDim arrBuffer(0 To lngSize - 1) As Byte
lngRetVal = GetIfTable(arrBuffer(0), lngSize, 0)
If lngRetVal = ERROR_SUCCESS Then
CopyMemory lngRows, arrBuffer(0), 4
If lngRows >= 1 Then
For lngRow = 1 To lngRows
CopyMemory IfRowTable, arrBuffer(4 + (lngRow - 1) * Len(IfRowTable)), Len(IfRowTable)
For i = 0 To 25
Name = Name & Chr(IfRowTable.bDescr(i))
If IfRowTable.bDescr(i) = Chr(0) Then GoTo ok
Next
ok:
If Not InStr(1, Name, "loop", vbTextCompare) > 0 Then
With IfRowTable
m_lngBytesReceived = m_lngBytesReceived + .dwInOctets
m_lngBytesSent = m_lngBytesSent + .dwOutOctets
End With 'IFROWTABLE
'Set IfRowTable = Nothing
InitInterfaces = True
End If
Name = vbNullString
Next
Erase arrBuffer
End If
End If
On Error GoTo 0
Exit Function
err:
Call GErrorHandler(err.Number, err.Description, "CIPHelper:InitInterfaces:" & err.Source, True)
End Function
Private Sub GetBandwidth()
Dim c As New CIpHelper, R As Double, s As Double
Dim r1 As Double, c1 As Double, SendBytes1 As Double, ReceivedBytes1 As Double
On Error GoTo errh:
c.InitInterfaces
If FirstTime Then
FirstTime = False
SendBytes = Format(c.BytesSent / 1024, ".0")
ReceivedBytes = Format(c.BytesReceived / 1024, ".0")
SendBytes1 = c.BytesSent
ReceivedBytes1 = c.BytesReceived
Else 'FIRSTTIME = FALSE/0
R = ((c.BytesReceived / 1024) - ReceivedBytes)
s = ((c.BytesSent / 1024) - SendBytes)
End If
lblBandwidthUsed = R+s
OldR = R
OldS = s
On Error GoTo 0
Exit Sub
errh:
Call GErrorHandler(err.Number, err.Description, "ScreenBlock:GetBandwidth:" & err.Source, True)
End Sub
1) 1024 bytes = 1 kB and 1024 kB = 1 MB. In other words, divide the number of kilobytes by 1024.
2) I assume if you don't want to monitor LAN traffic, you want to monitor Wireless traffic. That might be a little tricky to do as a generic solution, but if you know the MAC address of your lan network card, you can exclude it in the calculations which looks like the "bPhysAddr" variable to me.
You can get the MAC address of a PC executing the command in the command line:
ipconfig /all
Related
After consulting
How to use webcam capture on a Microsoft Access form,
I have a program where the user presses a button on an Excel form to open an Access form and take before & after photos using built-in webcam then save them to a predetermined folder. This works fine on several laptops including mine but when I try to run it on a tablet with front and back camera, it prompts me to choose between UNICAM Rear and UNICAM Front, which I presume means the code works fine and is connecting to the driver. However, the chosen camera doesn't connect; WM_CAP_DRIVER_CONNECT returns False and I get a black screen in the picture frame.
The tablet is an Acer One 10 running Win10 Home 32-bit and Access 365 Runtime. The I've tested the program using Access Runtime through Command Prompt on my laptop and it worked fine, I've checked that other apps are allowed to access the camera, nothing else is using the camera, tested 0 to 9 for WM_CAP_CONNECT parameters, changed LongPtr back to Long (which by the way still makes it work on win10 Pro 64-bit) and it still doesn't work.
I suspect it's an issue with the tablet and not the code since it's a company tablet and there are two cameras, perhaps I may be missing some permissions to connect to the camera via Access or the code doesn't work with two cameras, but I have no idea where to begin checking these.
I'm currently trying to find a laptop with two cameras to test the program on and in the meantime I'm totally lost and would appreciate suggestions for anything I could try to fix this problem, whether related to the code or not - though I would like to avoid running executables like CommandCam, seeing as I'm using company computers.
This is the part of my Excel code that affects opening Access:
Private Sub mainBtn_Click()
Dim LCategoryID As Long
Dim ShellCmd, LPath As String
Dim wsMain, wsRec As Worksheet
Set wsMain = Sheets("Main")
Set wsRec = Sheets("Records")
mainBtn.Enabled = False
LPath = ThisWorkbook.Path + "\Database1.accdb"
If mainBtn.Caption <> "Record" Then
If Dir(PathToAccess) <> "" And oApp Is Nothing Then
ShellCmd = """" & PathToAccess & """ """ & LPath & """"
VBA.Shell ShellCmd
If oApp Is Nothing Then Set oApp = GetObject(LPath)
' Set oApp = CreateObject("Access.Application")
End If
Application.Wait (Now + TimeValue("00:00:05"))
On Error Resume Next
oApp.OpenCurrentDatabase LPath
oApp.Visible = False
On Error GoTo 0
'passing a value through a sub on Access
oApp.Run "getName", wsMain.Range("F5").Value
End If
'before photo
If mainBtn.Caption = "Before Photo" Then
oApp.DoCmd.openform "Before Photo"
mainBtn.Caption = "After Photo"
mainBtn.Enabled = True
This is my code in Access:
Option Compare Database
Const WS_CHILD As Long = &H40000000
Const WS_VISIBLE As Long = &H10000000
Const WM_USER As Long = &H400
Const WM_CAP_START As Long = WM_USER
Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50
Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Private Declare PtrSafe Function capCreateCaptureWindow _
Lib "avicap32.dll" Alias "capCreateCaptureWindowA" _
(ByVal lpszWindowName As String, ByVal dwStyle As Long _
, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long _
, ByVal nHeight As Long, ByVal hwndParent As LongPtr _
, ByVal nID As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long _
, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Sub sapiSleep Lib "kernel32" _
Alias "Sleep" _
(ByVal dwMilliseconds As Long)
Dim hCap As LongPtr
Dim i As Integer
Private Sub cmd4_click()
' take picture
Dim sFileName, sFileNameSub, dateNow, timeNow As String
i = i + 1
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
dateNow = DateValue(Now)
timeNow = TimeValue(Now)
sFileName = CurrentProject.Path + "\dbimages\Before Change " + CStr(Year(dateNow)) + "." + CStr(Month(dateNow)) + "." + CStr(Day(dateNow)) + " " + CStr(Hour(timeNow)) + "h" + CStr(Minute(timeNow)) + "m" + CStr(Second(timeNow)) + "s.jpg"
Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
If i = 4 Then
MsgBox "4 pictures taken. Exiting"
DoCmd.Close
Else
MsgBox "Picture " + CStr(i) + " Taken"
End If
End Sub
Private Sub Cmd3_Click()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End Sub
Private Sub cmd1_click()
' Dim connectAttempts As Integer
Dim i As Integer
hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hWnd, 0)
If hCap <> 0 Then
'Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
' For i = 0 To 9
If CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)) = False Then
' connectAttempts = connectAttempts + 1
MsgBox "Failed to connect Camera"
Else
' Exit For
End If
' Next i
Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 45, 0&)
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End If
End Sub
Private Sub Cmd2_Click()
'back to excel
'Dim temp As Long
'temp = SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
DoCmd.Close
End Sub
Private Sub Form_Close()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
'DoCmd.ShowToolbar "Ribbon", acToolbarYes
End Sub
Private Sub Form_Load()
'DoCmd.ShowToolbar "Ribbon", acToolbarNo
i = 0
cmd1.Caption = "Start Cam"
cmd2.Caption = "Done"
cmd3.Caption = "dummy"
cmd4.Caption = "Tak&e Picture"
DoCmd.RunCommand acCmdAppMinimize
DoCmd.Maximize
If stnName = "Head 1" Or stnName = "Head 2" Then
Pic1.Picture = CurrentProject.Path + "\images\head_s.jpeg"
ElseIf stnName = "Marriage Head" Or stnName = "Plus Clip Head" Then
Pic1.Picture = CurrentProject.Path + "\images\marriage_s.jpeg"
Else
Pic1.Picture = CurrentProject.Path + "\images\6pair_s.jpeg"
End If
cmd1_click
On Error Resume Next
CurrentProject.Application.Visible = True
End Sub
Private Sub sSleep(lngMilliSec As Long)
If lngMilliSec > 0 Then
Call sapiSleep(lngMilliSec)
End If
End Sub
EDIT: Camera app works fine on tablet but I get a black screen in picture box when trying to use it through Access.
EDIT2: Code for WM_CAP_GET_STATUS
Added the following line in main module:
Const WM_CAP_GET_STATUS = WM_CAP_START + 54
Added the following in another module:
Type CAPSTATUS
uiImageWidth As Long
uiImageHeight As Long
fLiveWindow As Long
fOverlayWindow As Long
fScale As Long
ptScroll As POINTAPI
fUsingDefaultPalette As Long
fAudioHardware As Long
fCapFileExists As Long
dwCurrentVideoFrame As Long
dwCurrentVideoFramesDropped As Long
dwCurrentWaveSamples As Long
dwCurrentTimeElapsedMS As Long
hPalCurrent As Long
fCapturingNow As Long
dwReturn As Long
wNumVideoAllocated As Long
wNumAudioAllocated As Long
End Type
New code for starting camera:
Private Sub cmd1_click()
Dim bool1, bool2, bool3 As Boolean
Dim o As Integer
Dim u As Integer
Dim s As CAPSTATUS
Open CurrentProject.Path + "\output.txt" For Output As #1
i = 0 'global variable
hCap = capCreateCaptureWindow("Take a Camera Shot", ws_child Or ws_visible, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hwnd, 0)
sSleep 5000
If hCap <> 0 Then
For i = 0 To 9
Print #1, hCap
bool1 = CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, i, 0))
Print #1, bool1
bool3 = SendMessage(hCap, WM_CAP_GET_STATUS, LenB(s), s)
Print #1, bool3
For u = 1 To 4
If bool1 = True Then
bool1 = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, i, 0&)
End If
o = u * 7
bool1 = CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, i, 0))
Print #1, Tab(o); bool1
bool3 = SendMessage(hCap, WM_CAP_GET_STATUS, LenB(s), s)
Print #1, Tab(o); bool3
Next u
Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 45, 0&)
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
Next i
End If
Close #1
End Sub
Hey all I am trying to figure out how to get the following to work or replace in order to make work:
Module1:
Private oTest As Class1
Private InitDone As Boolean
Private Map1(0 To 63) As Byte
Private Map2(0 To 127) As Byte
#If VBA7 Then
Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If
Private Declare Sub CopyMemoryByref Lib "Kernel32.dll" & _
Alias "RtlMoveMemory" (ByRef dest As Integer, ByRef & _
source As Integer, ByVal numBytes As Integer)
Private Declare Function VarPtr Lib "vb40032.dll" & _
Alias "VarPtr" (lpObject As Integer) As Long
Public Function EncryptData(ByRef bytMessage() As Byte, ByRef bytPassword() As Byte) As Byte()
Dim bytKey(31) As Byte
Dim bytIn() As Byte
Dim bytOut() As Byte
Dim bytTemp(31) As Byte
Dim lCount, lLength As Integer
Dim lEncodedLength, lPosition As Integer
Dim bytLen(3) As Byte
If Not IsInitialized(bytMessage) Then Exit Function
If Not IsInitialized(bytPassword) Then Exit Function
For lCount = 0 To UBound(bytPassword)
bytKey(lCount) = bytPassword(lCount) : If lCount = 31 Then Exit For
Next lCount
gentables()
gkey(8, 8, bytKey)
lLength = UBound(bytMessage) + 1 : lEncodedLength = lLength + 4
If lEncodedLength Mod 32 <> 0 Then lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
ReDim bytIn(lEncodedLength - 1) : ReDim bytOut(lEncodedLength - 1)
Try
CopyMemory(VarPtr(bytIn(0)), VarPtr(lLength), 4)
Catch ex As Exception
MessageBox.Show(ex.Message)
End Try
For lCount = 0 To lEncodedLength - 1 Step 32
CopyMemory(VarPtr(bytTemp(0)), VarPtr(bytIn(lCount)), 32)
Encrypt(bytTemp)
CopyMemory(VarPtr(bytOut(lCount)), VarPtr(bytTemp(0)), 32)
Next lCount
End Function
UserForm:
Private Sub Command1_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Command1.Click
Dim sTemp, sPassword As String
sTemp = "this is a test"
Debug.Print(" To encrypt: " & sTemp)
sPassword = "blk#vjdii:5#fAB5"
Debug.Print(StrReverse(sPassword))
sPassword = Str2Hex(strEncrypt(sPassword, StrReverse(sPassword)))
Debug.Print(" Secret key: " & sPassword)
sTemp = Str2Hex(strEncrypt(sTemp, sPassword))
Debug.Print(" Encrypt: " & sTemp)
sTemp = Base64EncodeString(sTemp)
Debug.Print("Encrypt w/ Base64: " & sTemp)
sTemp = Base64DecodeString(sTemp)
Debug.Print("Decrypt w/ Base64: " & sTemp)
sTemp = Hex2Str(sTemp)
Debug.Print(" Decrypt: " & strDecrypt(sTemp, sPassword))
End Sub
This code works just fine when using it within the VBA excel code. This is the VB6 output:
To encrypt: this is a test
Secret key: F050C1C2B61E8DCC349DC498D9993F8D11330F12D9E0071B4B83D172FEBE5AED
Encrypt: F899ABA853D21B20F889CFD18BB42C472187B4E1CF613139370313DFD8A492DE
Encrypt w/ Base64:
Rjg5OUFCQTg1M0QyMUIyMEY4ODlDRkQxOEJCNDJDNDcyMTg3QjRFMUNGNjEzMTM5MzcwMzEzREZEOEE
0OTJERQ==
Decrypt w/ Base64: F899ABA853D21B20F889CFD18BB42C472187B4E1CF613139370313DFD8A492DE
Decrypt: this is a test
However, when converting it over to .net I get the error of:
Arithmetic operation resulted in an overflow.
on the line CopyMemory(VarPtr(bytIn(0)), VarPtr(lLength), 4).
How can I re-write this in order for it to work so both VB.net and VB6 can share the code base in order to encrypt/decrypt string messages back and forth?
Use the Array.Copy Method in VB.NET. VB.NET has a completely different memory model than VB6. You cannot apply VB6 functions from VB6 DLLs in VB.NET! .NET has its own encryption system. See: System.Security.Cryptography Namespace
Array.Copy(bytTemp, 0, bytIn, lCount, 32)
VB.NET is not just a VB7. VB.NET is a completely new language with a completely new type system, new libraries, new DLL and EXE structures, new runtime infrastructure, new ... (well almost everything is new)
As Hans Passant already hinted at: it is almost impossble to have a common code base for VB6 and VB.NET
Public Function StrToByte(ByRef strInput As String) As Byte()
Dim lPntr As Integer
Dim bTmp() As Byte
Dim bArray() As Byte
If Len(strInput) = 0 Then Exit Function
'999999999---------------------------------------LenB()strInput
ReDim bTmp(LenB(strInput) - 1) 'Memory length
'Dim size As Integer = System.Runtime.InteropServices.Marshal.SizeOf(strInput) - 1
ReDim bArray(Len(strInput) - 1) 'String length
'999999999=---------------------------------------- CopyMemory(strInput, lPntr, 0)
CopyMemory(StrPtr(strInput), System.Runtime.InteropServices.Marshal.SizeOf(strInput))
' CopyMemory(strInput, lPntr, 0)
'Examine every second byte
For lPntr = 0 To UBound(bArray)
If bTmp(lPntr * 2 + 1) > 0 Then
'bArray(lPntr) = Asc(Mid$(strInput, lPntr + 1, 1))
StrToByte = CopyArra(bTmp) ' StrToByte = System.Array.Copy(strInput, lPntr + 1, 1)
Exit Function
Exit Function
Else
bArray(lPntr) = bTmp(lPntr * 2)
End If
Next lPntr
StrToByte = CopyArray(bArray)
End Function
I have 2 concerns, if someone can assist. I am new to VBA. I have a command print button on my excel sheet and I added the code listed below. When I click on the print button, I have the first page print twice but the rest of the pages print single which is what I want. How do I fix the code so it only prints once.
The other thing is when the print manager window opens for me to select a printer, I would like to have the code select single page print and not duplex printing. The printer default settings are set for duplex and I dont want to change that setting through windows but for the code to automatically select single sided prints.
Thank you,
Private Sub PrintAll_Click()
Dim rngOffenders As Range
Set rngOffenders = Worksheets("Names").Range("A2", Worksheets("Names").Range("A2").End(xlDown))
Dim willPrint As Boolean
willPrint = Application.Dialogs(xlDialogPrint).Show
If Not willPrint Then Exit Sub
Dim rng As Range
For Each rng In rngOffenders.Cells
Worksheets("Template").Range("LastName").Value = rng.Value
Calculate
Worksheets("Template").PrintOut
Next rng
End Sub
Regarding the duplicate printing, my guess, without testing, is that by Show the print dialog, you're invoking print against the first/active sheet once you press "OK". Then, as you iterate over rngOffenders.Cells, you're printing that sheet again. So, you could start at the second cell in rngOffenders to avoid that.
Dim i As Long
For i = 2 To rngOffenders.Cells.Count
Worksheets("Template").Range("LastName").Value = rngOffenders.Cells(i).Value
Calculate
Worksheets("Template").PrintOut
Next rng
For the printer settings, that is more complicated. See here:
The best way of doing this is by using API calls. The following article gives you a VB code sample which does this:
Q230743
Only one “problem” with this code: It is written for VB and uses Printer.DeviceName to return the name of the currently selected printer. In Word VBA, you need to substitute this with ActivePrinter. The problem is that the strings returned by these commands are slightly different, even though they both get the name of the printer from the name assigned in Control Panel | Printers. For instance.:
ActivePrinter: HP LaserJet 6L PCL on LPT1:
Printer.DeviceName: HP LaserJet 6L PCL
So you'll need to test and modify the code sample accordingly.
If you don't want to use API calls, however, you can install a duplicate printer driver with the duplex property set and print to that (by changing the ActivePrinter).
The linked KB article demonstrates (at length) how to set the printer to duplex printing. Most of the same code should be used for the inverse operation, you'd just need to figure out what value to pass for that property.
Test Procedure:
Place this in a standard module. Note the possible need to adjust the length of printer string (removing the port component e.g., "HP Ink Jet Fantastico on LP02", etc.)
Option Explicit
Sub test()
Dim pName As String
pName = ActivePrinter
' Note you may need to adjust this value to remove the port string component
pName = Left(pName, (Len(pName) - 9))
SetPrinterDuplex pName, 1 '1 = NOT duplex printing.
'Here you might want to actually print something, for example:
Worksheets("Template").PrintOut
End Sub
In a separate module, place all of the printer-related code. NB: I am on a machine with no printer access, so I am unable to test or further debug this solution.
Option Explicit
Public Type PRINTER_DEFAULTS
pDatatype As Long
pDevmode As Long
DesiredAccess As Long
End Type
Public Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pLocation As Long
pDevmode As Long ' Pointer to DEVMODE
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type
Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type
Public Const DM_DUPLEX = &H1000&
Public Const DM_IN_BUFFER = 8
Public Const DM_OUT_BUFFER = 2
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)
Public Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Public Declare Function DocumentProperties Lib "winspool.drv" _
Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
ByVal hPrinter As Long, ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, ByVal pDevModeInput As Long, _
ByVal fMode As Long) As Long
Public Declare Function GetPrinter Lib "winspool.drv" Alias _
"GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As PRINTER_DEFAULTS) As Long
Public Declare Function SetPrinter Lib "winspool.drv" Alias _
"SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal Command As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)
' ==================================================================
' SetPrinterDuplex
'
' Programmatically set the Duplex flag for the specified printer
' driver's default properties.
'
' Returns: True on success, False on error. (An error will also
' display a message box. This is done for informational value
' only. You should modify the code to support better error
' handling in your production application.)
'
' Parameters:
' sPrinterName - The name of the printer to be used.
'
' nDuplexSetting - One of the following standard settings:
' 1 = None
' 2 = Duplex on long edge (book)
' 3 = Duplex on short edge (legal)
'
' ==================================================================
Public Function SetPrinterDuplex(ByVal sPrinterName As String, _
ByVal nDuplexSetting As Long) As Boolean
Dim hPrinter As Long
Dim pd As PRINTER_DEFAULTS
Dim pinfo As PRINTER_INFO_2
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim yPInfoMemory() As Byte
Dim nBytesNeeded As Long
Dim nRet As Long, nJunk As Long
On Error GoTo cleanup
'#### I removed this block because it was preventing you from changing the duplex settings
' If (nDuplexSetting < 1) Or (nDuplexSetting > 3) Then
' MsgBox "Error: dwDuplexSetting is incorrect."
' Exit Function
' End If
'####
pd.DesiredAccess = PRINTER_ALL_ACCESS
nRet = OpenPrinter(sPrinterName, hPrinter, pd)
If (nRet = 0) Or (hPrinter = 0) Then
If Err.LastDllError = 5 Then
MsgBox "Access denied -- See the article for more info."
Else
MsgBox "Cannot open the printer specified " & _
"(make sure the printer name is correct)."
End If
Exit Function
End If
nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (nRet < 0) Then
MsgBox "Cannot get the size of the DEVMODE structure."
GoTo cleanup
End If
ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Cannot get the DEVMODE structure."
GoTo cleanup
End If
Call CopyMemory(dm, yDevModeData(0), Len(dm))
If Not CBool(dm.dmFields And DM_DUPLEX) Then
MsgBox "You cannot modify the duplex flag for this printer " & _
"because it does not support duplex or the driver " & _
"does not support setting it from the Windows API."
GoTo cleanup
End If
dm.dmDuplex = nDuplexSetting
Call CopyMemory(yDevModeData(0), dm, Len(dm))
nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), _
DM_IN_BUFFER Or DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Unable to set duplex setting to this printer."
GoTo cleanup
End If
Call GetPrinter(hPrinter, 2, 0, 0, nBytesNeeded)
If (nBytesNeeded = 0) Then GoTo cleanup
ReDim yPInfoMemory(nBytesNeeded + 100) As Byte
nRet = GetPrinter(hPrinter, 2, yPInfoMemory(0), nBytesNeeded, nJunk)
If (nRet = 0) Then
MsgBox "Unable to get shared printer settings."
GoTo cleanup
End If
Call CopyMemory(pinfo, yPInfoMemory(0), Len(pinfo))
pinfo.pDevmode = VarPtr(yDevModeData(0))
pinfo.pSecurityDescriptor = 0
Call CopyMemory(yPInfoMemory(0), pinfo, Len(pinfo))
nRet = SetPrinter(hPrinter, 2, yPInfoMemory(0), 0)
If (nRet = 0) Then
MsgBox "Unable to set shared printer settings."
End If
SetPrinterDuplex = CBool(nRet)
cleanup:
If (hPrinter <> 0) Then Call ClosePrinter(hPrinter)
End Function
You can print the first page twice like this:
Dim i As Long, k As Long
Dim lpc As Long
lpc = ActiveSheet.HPageBreaks.Count
For i = 1 To lpc + 1
If i = 1 Then
k = 2
Else
k = 1
End If
ActiveSheet.PrintOut from:=i, To:=i, Copies:=k
Next
below is my vb6 code
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Property Let Key(New_Value As String)
Dim i As Long
Dim j As Long
Dim K As Long
Dim dataX As Long
Dim datal As Long
Dim datar As Long
Dim Key() As Byte
Dim KeyLength As Long
'Do nothing if the key is buffered
If (m_KeyValue = New_Value) Then Exit Property
m_KeyValue = New_Value
'Convert the new key into a bytearray
KeyLength = Len(New_Value)
Key() = StrConv(New_Value, vbFromUnicode)
'Create key-dependant p-boxes
j = 0
For i = 0 To (ROUNDS + 1)
dataX = 0
For K = 0 To 3
Call CopyMem(ByVal VarPtr(dataX) + 1, dataX, 3) 'the problem is here
dataX = (dataX Or Key(j))
j = j + 1
If (j >= KeyLength) Then j = 0
Next
m_pBox(i) = m_pBox(i) Xor dataX
Next
End Property
CopyMem sub lib how do i use it in vb.net
now here is my vb.net code for the same
Private Declare Sub CopyMem Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal pDst As Object, ByVal pSrc As Object, ByVal ByteLen As Integer)
Public WriteOnly Property Key() As String
Set(ByVal Value As String)
Dim i As Long
Dim j As Long
Dim K As Long
Dim dataX As Long
Dim datal As Long
Dim datar As Long
Dim Key() As Byte
Dim KeyLength As Long
'Do nothing if the key is buffered
If (m_KeyValue = Value) Then Exit Property
m_KeyValue = Value
'Convert the new key into a bytearray
KeyLength = Len(Value)
Key = System.Text.Encoding.Unicode.GetBytes(Value)
'Create key-dependant p-boxes
j = 0
For i = 0 To (ROUNDS + 1)
dataX = 0
For K = 0 To 3
CopyMem(VarPtr(dataX) + 1, dataX, 3) ' the problem is here
dataX = (dataX Or Key(j))
j = j + 1
If (j >= KeyLength) Then j = 0
Next
m_pBox(i) = m_pBox(i) Xor dataX
Next
End Property
here is code for VarPtr
Public Function VarPtr(ByVal e As Object) As Object
Dim GC As GCHandle = GCHandle.Alloc(e, GCHandleType.Pinned)
Dim GC2 As Integer = GC.AddrOfPinnedObject.ToInt32
GC.Free()
Return GC2
End Function
i have refered to Equivalent of CopyMemory in .NET
but still i am not getting this
please somebody help!!!
If you want to access data using pointers in .NET then you need to keep them pinned during the whole operation. The VarPtr method pins the object while getting the address to it, but then it unpins the object. That means that the object can be moved while you are doing the CopyMem call. Most of the time the object isn't moved, so it would seem to work fine, but when it is moved the CopyMem operation could change some other data. That could make any object in your application behave strangely, or crash the application.
Anyhow, using memory copy is definitely overkill for moving a few bits in an integer. (The Long data type in VB 6 corresponds to the Integer data type in VB.NET by the way.)
You can convert the integer to a byte array, use the Array.Copy method, and then convert it back:
Dim temp As Byte() = BitConverter.GetBytes(dataX)
Array.Copy(temp, 0, temp, 1, 3)
dataX = BitConverter.ToInt32(temp, 0)
You can also do it using bit operations:
dataX = (dataX And &HFF) Or (dataX << 8)
Side note: The Encoding.Unicode is for the UTF-16 encoding. That means that the byte array that GetBytes returns will be twice the length of the string, so you will be using only half of the string.
I have the code below which works fine, steps through the rows pinging each host and updating the sheet.
Sub Do_ping()
Set output = ActiveWorkbook.Worksheets(1)
With ActiveWorkbook.Worksheets(1)
Set pinger = CreateObject("WScript.Shell")
pings = 1
pingend = "FALSE"
output.Cells(2, 4) = pings
output.Cells(2, 5) = pingend
Do
Row = 2
Do
If .Cells(Row, 1) <> "" Then
result = pinger.Run("%comspec% /c ping.exe -n 1 -w 250 " _
& output.Cells(Row, 1).Value & " | find ""TTL="" > nul 2>&1", 0, True)
If (result = 0) = True Then
result = "TRUE"
Else
result = "FALSE"
End If
' result = IsConnectible(.Cells(Row, 1), 1, 1000)
output.Cells(Row, 2) = result
End If
Row = Row + 1
Loop Until .Cells(Row, 1) = ""
waitTime = 1
Start = Timer
While Timer < Start + waitTime
DoEvents
Wend
output.Cells(2, 4) = pings
output.Cells(2, 5) = pingend
pings = pings + 1
Loop Until pingend = "TRUE"
End With
End Sub
But suppose I have 50 devices and 40 of them are down. Because it is sequential I have to wait for the pings to time out on these devices and so a single pass can take a long time.
Can I in VBA create an object that I can create multiply instances of, each pinging a separate host, and then simple cycle though the objects pulling back a true/false property from them.
I don't know how possible this is or how you deal with classes in VBA.
I want some thing like
set newhostping = newobject(pinger)
pinger.hostname = x.x.x.x
to set up the object then object would have the logic
do
ping host x.x.x.x
if success then outcome = TRUE
if not success then outcome = FALSE
wait 1 second
loop
so back in the main code I could just use
x = pinger.outcome
to give me the current state of the host, with out needing to wait for the current ping operation to complete. It would just return the result of the last completed attempt
Does any one have any code or ideas they could share?
Thank you
DevilWAH
You could use the ShellAndWait function below to run those calls asynchronously (i.e. in parallel). See my example with a simple tracert command which generally takes a few seconds to run. It opens 50 command windows running at the same time.
Option Explicit
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const STATUS_PENDING = &H103&
Private Const PROCESS_QUERY_INFORMATION = &H400
Public Sub test()
Dim i As Long
For i = 1 To 50
ShellandWait "tracert www.google.com", vbNormalFocus, 1
Next i
End Sub
Public Function ShellandWait(parProgramName As String, Optional parWindowStyle As VbAppWinStyle = vbMinimizedNoFocus, _
Optional parTimeOutValue As Long = 0) As Boolean
'source: http://www.freevbcode.com/ShowCode.Asp?ID=99
'Time out value in seconds
'Returns true if the program closes before timeout
Dim lInst As Long
Dim lStart As Long
Dim lTimeToQuit As Long
Dim sExeName As String
Dim lProcessId As Long
Dim lExitCode As Long
Dim bPastMidnight As Boolean
On Error GoTo ErrorHandler
lStart = CLng(Timer)
sExeName = parProgramName
'Deal with timeout being reset at Midnight
If parTimeOutValue > 0 Then
If lStart + parTimeOutValue < 86400 Then
lTimeToQuit = lStart + parTimeOutValue
Else
lTimeToQuit = (lStart - 86400) + parTimeOutValue
bPastMidnight = True
End If
End If
lInst = Shell(sExeName, parWindowStyle)
lProcessId = OpenProcess(PROCESS_QUERY_INFORMATION, False, lInst)
Do
Call GetExitCodeProcess(lProcessId, lExitCode)
DoEvents
If parTimeOutValue And Timer > lTimeToQuit Then
If bPastMidnight Then
If Timer < lStart Then Exit Do
Else
Exit Do
End If
End If
Loop While lExitCode = STATUS_PENDING
If lExitCode = STATUS_PENDING Then
ShellandWait = False
Else
ShellandWait = True
End If
Exit Function
ErrorHandler:
ShellandWait = False
End Function