I have 'Applications.PrevInstance' in VB 6 code that I am trying to upgrade to .NET using VS 2008. Apparently this code is no longer valid. Does anyone have any ideas about upgraded solution? TIA
See here:
http://www.knowdotnet.com/articles/previnstance.html
Public Sub Main()
If PrevInstance() Then Exit Sub
' continue with your application
UserName = Environ("UserName")
ComputerName = Environ("COMPUTERNAME")
End Sub
Function PrevInstance() As Boolean
If UBound(Diagnostics.Process.GetProcessesByName _
(Diagnostics.Process.GetCurrentProcess.ProcessName)) _
> 0 Then
Return True
Else
Return False
End If
End Function
Function PrevInstance() As Boolean
If UBound(Diagnostics.Process.GetProcessesByName(Diagnostics.Process.GetCurrentProcess.ProcessName)) > 0 Then
PrevInstance = True
Else
UserName = Environ("UserName")
Computername = Environ("COMPUTERNAME")
PrevInstance = False
End If
Dim i, n As Integer, RepForm As String
For i = My.Application.OpenForms.Count - 1 To 1 Step -1
RepForm = My.Application.OpenForms.Item(i).Name
For n = My.Application.OpenForms.Count - 1 To 1 Step -1
If My.Application.OpenForms.Item(n).Name = My.Application.OpenForms.Item(i).Name And n > i Then
My.Application.OpenForms(i).Close()
PrevInstance = True
Exit Function
End If
Next n
Next i
End Function
Related
I try to export to Excel with the fpsread plugin, but there really is no information on how, I have searched the manual but they only show me how to do it with .net
Will someone have an idea?
I managed to do it was very simple, but wanting to import the titles was the heaviest, but here I leave the code in case any work
Private Sub CmdImportar_Click()
Call Export_Excel(cdgExcel, sprFacturas)
Call HacerBusqueda
End Sub
Public Sub Export_Excel(cdgExcel As CommonDialog, Spread As fpSpread)
Dim Header() As String
Dim I As Integer
Dim j As Integer
Dim x As Integer
With cdgExcel
.CancelError = False
.InitDir = "C:/:"
.Filter = "Excel(*.xls)|*.xls"
.ShowSave
If .filename <> "" Then
Spread.Redraw = False
For I = 1 To Spread.ColHeaderRows
ReDim Header(Spread.MaxCols) As String
Spread.Row = SpreadHeader + (I - 1)
For j = 1 To Spread.MaxCols
Spread.Col = j
Header(j) = Spread.Text & ""
Next j
Spread.MaxRows = Spread.MaxRows + 1
Spread.Row = I
Spread.Action = ActionInsertRow
For j = 1 To Spread.MaxCols
Spread.Col = j
Spread.CellType = Spread.CellType
Spread.TypeHAlign = Spread.TypeHAlign
Spread.TypeVAlign = Spread.TypeVAlign
Spread.Text = Header(j) & ""
Next j
Next I
x = Spread.ExportToExcel(.filename, "Sheet1", "")
For I = 1 To Spread.ColHeaderRows
Spread.Row = 1
Spread.Action = ActionDeleteRow
Next I
If x = True Then
MsgBox .filename & vbNewLine & "Se ha Importado el archivo", vbInformation, "Resultado"
Else
MsgBox "No se ha podido exportar el archivo", vbCritical, "Error"
End If
End If
End With
End Sub
I got this function from the internet. It's doing well when counting days so far, but when the dates is from different year, the result is wrong.
Example:
dateFrom = "2017-12-26"
dateTo = "2018-01-02"
the result will be 28 days, when it supposed to be 6 days.
Here is the function:
Public Function NetWorkdays(dtStartDate, dtEndDate, arrHolidays)
Dim lngDays
Dim lngSaturdays
Dim lngSundays
Dim lngHolidays
Dim lngAdjustment
Dim dtTest
Dim i, x
lngDays = DateDiff("d", dtStartDate, dtEndDate)
lngSundays = DateDiff("ww", dtStartDate, dtEndDate, vbSunday)
lngSaturdays = DateDiff("w", IIf(Weekday(dtStartDate, vbSunday) = vbSaturday, dtStartDate, dtStartDate - Weekday(dtStartDate, vbSunday)), dtEndDate)
For x = LBound(arrHolidays) To UBound(arrHolidays)
For i = 0 To lngDays
dtTest = DateAdd("d", i, dtStartDate)
If arrHolidays(x) = dtTest And Weekday(dtTest) <> 1 And Weekday(dtTest) <> 7 Then
lngHolidays = lngHolidays + 1
End If
Next
Next
If Weekday(dtStartDate, vbSunday) = vbSunday Or Weekday(dtStartDate, vbSunday) = vbSaturday Then
lngAdjustment = 0
Else
lngAdjustment = 1
End If
NetWorkdays = lngDays - lngSundays - lngSaturdays - lngHolidays + lngAdjustment
End Function
Public Function IIf(expr, truepart, falsepart)
If expr Then IIf = truepart Else IIf = falsepart
End function
Can anybody point it out anything to repair?
dateFrom = #2017-12-26#
dateTo = #2018-01-02#
Msgbox Dateto - datefrom,, "Result"
returns
---------------------------
Result
---------------------------
7
---------------------------
OK
---------------------------
As indiated by the type prefixes in the prototype:
Public Function NetWorkdays(dtStartDate, dtEndDate, arrHolidays)
the function expects Dates, not Strings. Evidence:
Option Explicit
(copy of function)
Dim dp, n
For Each dp In Array(Array("2017-12-26", "2018-01-02"))
On Error Resume Next
n = NetWorkdays(dp(0), dp(1), Array())
If Err Then n = Err.Description
On Error GoTo 0
WScript.Echo TypeName(dp(0)), dp(0), dp(1), n
dp(0) = CDate(dp(0))
dp(1) = CDate(dp(1))
WScript.Echo TypeName(dp(0)), dp(0), dp(1), NetWorkdays(dp(0), dp(1), Array())
Next
output (german locale):
cscript 47921079.vbs
String 2017-12-26 2018-01-02 Typenkonflikt
Date 26.12.2017 02.01.2018 6
Depending on versions, locales and the phase of the moon, you may have to replace the CDate() call with something more reliable.
I have my below code and outer array is not comparing each value with the inner array. Outer array is comparing with the one value from the inside and moving to the next value in it.
testdata = {25,27,81,104,33,34,56,78,99,84}
testdata1 = {81,104}
For i = 0 To UBound(testdata) - 1
For j = 0 To UBound(testdata1) - 1
If testdata(i) = testdata1(j) Then
isFound = True
Call DB_Connectionwisdataflagupdation(sQuery,Para2,Para3,Para4,sValue)
'c=c+1
Exit for
End If
'isFound = True
isFound = False
Next
Next
Please help me to get the solution on this.
I made a couple minor changes to your code, mainly adjusting the indices on your For loops:
Dim i As Integer
Dim j As Integer
Dim isFound As Boolean
For i = LBound(testdata) To UBound(testdata)
For j = LBound(testdata1) To UBound(testdata1)
If testdata(i) = testdata1(j) Then
isFound = True
'Call DB_Connectionwisdataflagupdation(sQuery, Para2, Para3, Para4, sValue)
MsgBox testdata(i)
Exit For
End If
isFound = False
Next
Next
Thank you for anyone that helps me with this.
I have written some VBA on a PC, but my copywriters use a mac and the Macros do not work. I get a run time error 13 on the following code:
If Range("Home_EPIC_Flag_Count").Value = 0 Then
is what gets highlighted yellow when I debug
Private Sub Worksheet_Calculate()
' EPIC flag conditional testing macros
If Range("Home_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Home_EPIC_Flag").Visible = False
Else
Me.Shapes("Home_EPIC_Flag").Visible = True
End If
If Range("Rooms_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Rooms_EPIC_Flag").Visible = False
Else
Me.Shapes("Rooms_EPIC_Flag").Visible = True
End If
If Range("Dining_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Dining_EPIC_Flag").Visible = False
Else
Me.Shapes("Dining_EPIC_Flag").Visible = True
End If
If Range("Spa_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Spa_EPIC_Flag").Visible = False
Else
Me.Shapes("Spa_EPIC_Flag").Visible = True
End If
If Range("Golf_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Golf_EPIC_Flag").Visible = False
Else
Me.Shapes("Golf_EPIC_Flag").Visible = True
End If
If Range("LocalArea_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("LocalArea_EPIC_Flag").Visible = False
Else
Me.Shapes("LocalArea_EPIC_Flag").Visible = True
End If
If Range("Business_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Business_EPIC_Flag").Visible = False
Else
Me.Shapes("Business_EPIC_Flag").Visible = True
End If
A little refactoring will make your code more manageable (once you fix the named range issue)
Private Sub Worksheet_Calculate()
Dim arr, x As Long
arr = Array("Home", "Rooms", "Dining", "Spa", "Golf", "LocalArea", "Business")
For x = LBound(arr) To UBound(arr)
Me.Shapes(arr(x) & "_EPIC_Flag").Visible = _
(Range(arr(x) & "_EPIC_Flag_Count").Value > 0)
Next x
End Sub
My j is the problem. VB is asking me to declare it but thats not what i want. Im trying to add all if not already in a listbox from combo box. And at the end saying how many i have added.
'Delcare
Dim bolItemFound As Boolean
Dim intCounter As Integer
'Adding all items not already listed
For i = 0 To lstToPackItems.Items.Count - 1
For j() = 0 To cboStandardToPackItems.Items.Count - 1
If lstToPackItems.Items.Count < 0 Then
lstToPackItems.Items.Add(cboStandardToPackItems.Items)
End If
Exit Sub
If lstToPackItems.Items(i).ToString.ToUpper = cboStandardToPackItems.Items(j).ToString.ToUpper Then
bolItemFound = True
End If
Exit Sub
Next
If bolItemFound = False Then
'add item
intCounter += 1
lstToPackItems.Items.Add(cboStandardToPackItems.Items(j))
MsgBox("You have successfuly added " & intCounter & " item(s) to your list box!")
End If
Next
In this line:
For j() = 0 To cboStandardToPackItems.Items.Count - 1
you should not have parentheses after the j.