I am experiencing some slowness problems is trying to refresh my datagrid with this code,
What I'm trying to do is manipulate the columns ACROSS variable (selltype_code).
objConn.Open()
Dim sqlConn As String = ("SELECT item_code, item_name, item_quantity, selltype_code, item_selldetail FROM qa_items")
Dim objDataAdapter As New MySqlDataAdapter(sqlConn, objConn)
Dim ds As New DataSet
objDataAdapter.Fill(ds, "items")
'Fill datagridview with FOR CICLE
For i As Int16 = 0 To ds.Tables("items").Rows.Count - 1
If ds.Tables("items").Rows(i).Item("selltype_code") = 1 Then
With Me.resultitems_seach_item
.Item(3, i).Style.ForeColor = ColorTranslator.FromOle(RGB(39, 74, 109)) 'Color para Precio
.Item(3, i).Value = ds.Tables("items").Rows(i).Item("item_selldetail") 'Valor para Precio
.Item(4, i).Style.ForeColor = Color.DarkGray
.Item(4, i).Value = "---"
.Item(5, i).Style.ForeColor = Color.DarkGray
.Item(5, i).Value = "---"
.Item(6, i).Style.ForeColor = Color.DarkGray
.Item(6, i).Value = "---"
End With
ElseIf ds.Tables("items").Rows(i).Item("selltype_code") = 2 Then
With Me.resultitems_seach_item
.Item(3, i).Style.ForeColor = Color.DarkGray
.Item(3, i).Value = "---"
.Item(4, i).Style.ForeColor = Color.DarkGray
.Item(4, i).Value = "---"
.Item(5, i).Style.ForeColor = ColorTranslator.FromOle(RGB(39, 74, 109)) 'Color para Precio
.Item(5, i).Value = ds.Tables("items").Rows(i).Item("item_selldetail")
.Item(6, i).Style.ForeColor = Color.DarkGray
.Item(6, i).Value = "---"
End With
ElseIf ds.Tables("items").Rows(i).Item("selltype_code") = 3 Then
With Me.resultitems_seach_item
.Item(3, i).Style.ForeColor = Color.DarkGray
.Item(3, i).Value = "---"
.Item(4, i).Style.ForeColor = ColorTranslator.FromOle(RGB(39, 74, 109)) 'Color para Precio
.Item(4, i).Value = ds.Tables("items").Rows(i).Item("item_selldetail")
.Item(5, i).Style.ForeColor = Color.DarkGray
.Item(5, i).Value = "---"
.Item(6, i).Style.ForeColor = Color.DarkGray
.Item(6, i).Value = "---"
End With
Else
With Me.resultitems_seach_item
.Item(3, i).Style.ForeColor = Color.DarkGray
.Item(3, i).Value = "---"
.Item(4, i).Style.ForeColor = Color.DarkGray
.Item(4, i).Value = "---"
.Item(5, i).Style.ForeColor = Color.DarkGray
.Item(5, i).Value = "---"
.Item(6, i).Style.ForeColor = ColorTranslator.FromOle(RGB(39, 74, 109)) 'Color para Precio
.Item(6, i).Value = ds.Tables("items").Rows(i).Item("item_selldetail")
End With
End If
Next i
objConn.Close()
Be sure you turn off any autoresize settings for grid columns. That slows down fetches considerably. Set the Grid AutoresizeMode to NONE before doing the refresh.
Related
The script takes photos from the indicated folder and places them on slides according to the limit imposed by the user, e.g. 1000 photos / presentation. After that it has to create a new presentation.
It was working. But he stopped. Now I stop with a PowerPoint VBA error: "No currently active document window" at the moment when the script is to close the PowerPoint file and open a new one in which to continue saving the presentation.
Saving and closing a newly created presentation
Application.DisplayAlerts = ppAlertsNone
ActivePresentation.Save
ActiveWindow.Close <----- error here
Application.DisplayAlerts = ppAlertsAll
How to eliminate this error for the script to continue running?
All Code:
Option Explicit
Option Base 1
Option Private Module
Private il_plik As Integer
Private dostep_do_zdjec As Variant
Private tablica() As Variant
'Dla odwiedzających forum elektroda.pl - jeśli im się na coś przyda :)
Sub a_Dodaj_zdjecia_do_ppt()
Dim ogranicznik As Integer, roz_cznk_prw_str As Integer, roz_cznk_przezr As Integer
Dim plik As Integer, indeks As Integer, prezent As Integer, maks_zdj_prez As Integer
Dim maks_prez As Double
Dim cznk_prw_str As String, cznk_przezr As String, filterek As String, dostep_do_prez As String
Dim nazwa_prezent As String, nazwa_zdj As String, opis_zdj As String, prw_str As String
Dim opis_nagl_calej_prez As String, data_zdj As String, godzina_zdj As String
Dim info01 As String, info02 As String, info03 As String, info04 As String, info05 As String, info06 As String
Dim stempel_daty As Date
Dim il_zdj_w_prez As Variant
Dim nPrzezPrez As Object
'On Error GoTo koniec_blad
'-----------------------------------------------------------------------------------------------------------------------
'Ograniczenie maksymalnej ilości zdjęć na jedną prezentację
ogranicznik = 3000
'Ustawienia czcionki strony przewodniej - można sobie zmieniać poprzez tę zmienną
cznk_prw_str = "Arial" 'oryginalnie było "Calibri" - jednak ta czcionka z polskimi ą, ę, itd. nie wyświetlała się u mnie najlepiej
roz_cznk_prw_str = 36 '40
'Ustawienia czcionki strony przezrocza - można sobie zmieniać poprzez tę zmienną
cznk_przezr = "Arial" 'oryginalnie było "Calibri" - jednak ta czcionka z polskimi ą, ę, itd. nie wyświetlała się u mnie najlepiej
roz_cznk_przezr = 16 '18
'
'-----------------------------------------------------------------------------------------------------------------------
'
'Określenie opisu w nagłówku pojedynczej prezentacji - domyślne dla całej prezentacji
opis_nagl_calej_prez = Trim(InputBox("Proszę podać treść nagłówka dla przezroczy w prezentacji", "Treść nagłówka w prezentacji", "Zdjęcie wykonane w Kluczborku"))
'Określenie ilości zdjęć w pojedynczej prezentacji - domyślnie 500 szt.
il_zdj_w_prez = InputBox("Proszę podać ilość zdjęć na 1 prezentację", "Ilość zdjęć do umieszczenia w prezentacji", 500)
'Jeśli podano złą wartość
If il_zdj_w_prez = "" Or Not IsNumeric(Trim(il_zdj_w_prez)) Then
MsgBox "Podano złą wartość lub w ogóle jej nie podano" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
'Jeśli podano dobrą wartość, ale w 'granicach przyzwoitości' typu Integer dla zmiennej 'ogranicznik'
il_zdj_w_prez = Abs(CInt(Trim(il_zdj_w_prez)))
If il_zdj_w_prez > ogranicznik Then
MsgBox "Przekroczono wartość graniczną" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
'Określenie dostępu do katalogu ze zdjęciami
With Application.FileDialog(msoFileDialogFolderPicker)
filterek = ActivePresentation.Path
.AllowMultiSelect = False
.ButtonName = "Wybierz"
.InitialFileName = filterek
.Title = "Proszę wybrać katalog ze zdjęciami"
If .Show = -1 Then
dostep_do_zdjec = .SelectedItems(1)
Else
MsgBox "Nie podano dostępu do katalogu zdjęć" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
End With
'Określenie dostępu do katalogu zapisywanych prezentacji
With Application.FileDialog(msoFileDialogFolderPicker)
filterek = ActivePresentation.Path
.AllowMultiSelect = False
.ButtonName = "Wybierz"
.InitialFileName = filterek
.Title = "Proszę podać miejsce zapisu prezentacji"
If .Show = -1 Then
dostep_do_prez = .SelectedItems(1)
Else
MsgBox "Nie podano dostępu do katalogu prezentacji" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
End With
'Początek obróbki
MsgBox "Teraz rozpocznie się pobieranie nazw zdjęć" & vbCrLf & vbCrLf & "Może to trochę potrwać, zależnie od ich ilości", vbOKOnly, "Uwaga !"
'Pozyskanie nazw plików oraz ich posortowanie, wzrastająco, według daty utworzenia
'Pobrane zostaną tylko zdjęcia z rozszerzeniami: '*.bmp', '*.gif', '*.jpg', '*.jpeg', '*.png'
Call b_Lista_plikow_w_katalogu(dostep_do_zdjec)
Call c_sortowanie_babelkowe(tablica)
'Korekta liczby zdjęć w prezentacji, jeśli zadeklarowano większą ich ilość niż liczba wszystkich zdjęć do obróbki
If il_zdj_w_prez > il_plik Then il_zdj_w_prez = il_plik
'Określenie ilości prezentacji, jaka zostanie utworzona,
'w oparciu o ogólną ilość zdjęć i tych, przypadających na pojedynczą prezentację
maks_prez = (il_plik / il_zdj_w_prez) - Fix(il_plik / il_zdj_w_prez)
If maks_prez > 0 And maks_prez < 0.5 Then
maks_prez = Round(il_plik / il_zdj_w_prez, 0) + 1
Else
maks_prez = Round(il_plik / il_zdj_w_prez, 0)
End If
'Wartości początkowe zmiennych wyznaczających zakres 'od-do' zdjęć w prezentacji
maks_zdj_prez = il_zdj_w_prez
plik = 1
For prezent = 1 To maks_prez
'Utworzenie nazwy nowopowstającej prezentacji
Select Case prezent
Case Is <= 9: nazwa_prezent = "Prez_" & "000" & prezent & ".ppt"
Case Is <= 99: nazwa_prezent = "Prez_" & "00" & prezent & ".ppt"
Case Is <= 999: nazwa_prezent = "Prez_" & "0" & prezent & ".ppt"
Case Else: nazwa_prezent = "Prez_" & "" & prezent & ".ppt"
End Select
'Utworzenie i zapisanie na dysku nowopowstającej prezentacji - okno prezentacji widoczne - 'msoTrue'
Presentations.Add(WithWindow:=msoTrue).SaveAs dostep_do_prez & "\" & nazwa_prezent
'Zmiana wielkości okna programu
'ActiveWindow.View.Zoom = 75
'Wartość początkowa zmiennej ustalającej położenie danego przezrocza w prezentacji
indeks = 0
For plik = plik To maks_zdj_prez
'Wydzielenie nazwy kopiowanego zdjęcia oraz daty i godziny jego utworzenia
nazwa_zdj = Mid(tablica(plik), InStr(1, tablica(plik), ";", 1) + 1, Len(tablica(plik)) - InStr(1, tablica(plik), ";", 1))
stempel_daty = CDate(Mid(tablica(plik), 1, InStr(1, tablica(plik), ";", 1) - 1))
data_zdj = Format(stempel_daty, "dd.mm.yyyy")
godzina_zdj = Format(stempel_daty, "hh:mm")
'Zmienna na ewentualny, dodatkowy opis w nagłówku przezrocza pobrany z tablicy - tu niewykorzystana
opis_zdj = "Opis dodatkowy"
'Dodanie nowego przezrocza
indeks = indeks + 1
ActivePresentation.Slides.Add Index:=indeks, Layout:=ppLayoutBlank
'Przypisanie obiektu przezrocza do zmiennej - skrócenie zapisu obiektu
Set nPrzezPrez = ActivePresentation.Slides(indeks)
'Wkopiowanie zdjęcia
'LinkToFile:=msoFalse - teoretycznie uniezależnia wkopiowane zdjęcie od 'zdjęcia macierzystego' pobranego z katalogu
nPrzezPrez.Shapes.AddPicture FileName:=dostep_do_zdjec & "\" & nazwa_zdj, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=28, Top:=40, Width:=665, Height:=460
'Skalowanie wkopiowanego zdjęcia - zmianą liczby przy 'ScaleHeight' i 'ScaleWidth'
With nPrzezPrez.Shapes(1)
.LockAspectRatio = msoTrue
'.ScaleHeight 1.4, msoTrue, msoScaleFromMiddle 'msoScaleFromTopLeft 'msoScaleFromMiddle 'msoScaleFromBottomRight
'.ScaleWidth 1.4, msoTrue, msoScaleFromMiddle
.Width = 665
.Height = 460
End With
'Dodanie nagłówka
nPrzezPrez.Shapes.AddShape(msoShapeWave, 8.5, 9#, 703#, 62.38).TextFrame.TextRange.Text = "Zdjęcie nr " & Format(plik, "#,##0") & ": " & opis_nagl_calej_prez
'nPrzezPrez.Shapes.AddShape(msoShapeWave, 8.5, 9#, 703#, 62.38).TextFrame.TextRange.Text = "Zdjęcie nr " & Format(plik, "#,##0") & " (" & nazwa_zdj & ")"
'Inny układ opisu nagłówka - "Zdjęcie nr " & Format(plik, "#,##0") & ": " & nazwa_zdj & " - " & opis_zdj
'Formatowanie nagłówka
With nPrzezPrez.Shapes(2)
With .TextFrame
.AutoSize = ppAutoSizeNone
.WordWrap = msoFalse
With .TextRange
.ParagraphFormat.Alignment = ppAlignLeft
With .Font
.Name = cznk_przezr: .Size = roz_cznk_przezr: .Bold = msoTrue
.Color.RGB = RGB(0, 0, 0)
'.Color.SchemeColor = ppForeground
End With
End With
End With
With .Fill
.ForeColor.RGB = RGB(215, 228, 189)
.Solid
.Transparency = 0#
.Visible = msoTrue
End With
With .Line
.BackColor.RGB = RGB(255, 255, 255)
.ForeColor.RGB = RGB(79, 98, 40)
.Visible = msoTrue
End With
End With
'Dodanie stopki
nPrzezPrez.Shapes.AddShape(msoShapeWave, 8.5, 472#, 703#, 62.38).TextFrame.TextRange.Text = "DATA: " & data_zdj & ", godzina " & godzina_zdj
'Formatowanie stopki
With nPrzezPrez.Shapes(3)
With .TextFrame
.AutoSize = ppAutoSizeNone
.WordWrap = msoFalse
With .TextRange
.ParagraphFormat.Alignment = ppAlignLeft
With .Font
.Name = cznk_przezr: .Size = roz_cznk_przezr: .Bold = msoTrue
.Color.RGB = RGB(0, 0, 0)
'.Color.SchemeColor = ppForeground
End With
End With
End With
With .Fill
.ForeColor.RGB = RGB(215, 228, 189)
.Solid
.Transparency = 0#
.Visible = msoTrue
End With
With .Line
.BackColor.RGB = RGB(255, 255, 255)
.ForeColor.RGB = RGB(79, 98, 40)
.Visible = msoTrue
End With
End With
'Usunięcie dotychczasowych przypisań do zmiennych
Set nPrzezPrez = Nothing
nazwa_zdj = ""
stempel_daty = #1/1/1980#
data_zdj = ""
godzina_zdj = ""
opis_zdj = ""
'Co każde 1000 zdjęć 'odpuść' odrobinę na inne czynności - 'Niepraktyczne' w tym zadaniu
'If plik Mod 1000 = 0 Then DoEvents
Next plik
'Zmienna z tytułem prezentacji do strony przewodniej
prw_str = "PREZENTACJE" & vbCrLf & vbCrLf & "TYTUŁ" & vbCrLf & vbCrLf & "ILOŚĆ ZDJĘĆ: " & Format(indeks, "#,##0") & vbCrLf & vbCrLf & "OSTATNIA AKTUALIZACJA:" & vbCrLf & Format(Now(), "dd.mm.yyyy")
'Wstawienie strony przewodniej
ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutTitleOnly
'Sformatowanie strony przewodniej
With ActivePresentation.Slides(1).Shapes(1)
.Left = 54#
.Top = 167.75
.Width = 612.12
.Height = 115.62
With .TextFrame
.AutoSize = ppAutoSizeNone
.WordWrap = msoTrue
With .TextRange
.ParagraphFormat.Alignment = ppAlignCenter
.Text = prw_str
With .Font
.Name = cznk_prw_str: .Size = roz_cznk_prw_str
.Color.RGB = RGB(0, 0, 0)
'.Color.SchemeColor = ppForeground
End With
End With
End With
With .Fill
.Solid
.Transparency = 0#
.Visible = msoFalse
End With
With .Line
.Visible = msoFalse
End With
End With
'Zapis i zamknięcie nowoutworzonej prezentacji
Application.DisplayAlerts = ppAlertsNone
ActivePresentation.Save
' ActiveWindow.Close
ActivePresentation.Close
Application.DisplayAlerts = ppAlertsAll
'Czyszczenie zmiennej z tytułem prezentacji do strony przewodniej - na wszelki wypadek
prw_str = ""
'Jeśli przekroczono dopuszczalne wartości zmiennych, określone na początku, to korekta
'Można tu zastosować zmienną 'indeks'
maks_zdj_prez = il_zdj_w_prez + plik - 1
If maks_zdj_prez > il_plik Then maks_zdj_prez = il_plik
Next prezent
'Komunikat końcowy
info01 = "Procedura zakończona" & vbCrLf & vbCrLf
info02 = "Utworzono " & Format(maks_prez, "#,##0") & " prezentacje(-ę/-i) w: " & vbCrLf & vbCrLf
info03 = dostep_do_prez & vbCrLf & vbCrLf
info04 = "z " & Format(il_plik, "#,##0") & " zdjęć, po maksimum " & Format(il_zdj_w_prez, "#,##0") & " w każdej," & vbCrLf & vbCrLf
info05 = "pobranych z:" & vbCrLf & vbCrLf
info06 = dostep_do_zdjec
MsgBox info01 & info02 & info03 & info04 & info05 & info06, vbOKOnly, "Uwaga !"
Exit Sub
'Wykonaj jeśli w trakcie obróbki pojawił się jakiś błąd
koniec_blad:
On Error GoTo 0: On Error Resume Next
Application.DisplayAlerts = ppAlertsNone
With Presentations(nazwa_prezent)
.Saved = True: .Close
End With
Application.DisplayAlerts = ppAlertsAll
Set nPrzezPrez = Nothing
'Wykonaj po błędzie wyboru katalogu lub odwołaniu operacji ustalającej ilość zdjęć w prezentacji
koniec:
End
End Sub
Sub b_Lista_plikow_w_katalogu(dostep_do_zdjec As Variant)
Dim igt As Integer
Dim dlg As Integer, poz As Integer, licz As Integer
Dim rozsz_pliku As String
Dim ciag_prw As String, ciag_odtw As String, znak As String
Dim plik As Variant
Dim apli As Object, katalog As Object
On Error GoTo koniec
Set apli = CreateObject("Shell.Application")
Set katalog = apli.Namespace(dostep_do_zdjec)
'Inicjalizacja tablicy przechowującej dane o plikach zdjęć
ReDim tablica(1)
igt = 0
'Wpisanie informacji o plikach do tablicy
For Each plik In katalog.Items
'Wykonaj jeśli ma rozszerzenie
If InStrRev(plik, ".", -1, 1) <> 0 Then
rozsz_pliku = LCase(Mid(plik, InStrRev(plik, ".", -1, 1), 5))
'Pobierane będą dane tylko niektórych plików
If rozsz_pliku = ".jpg" Or rozsz_pliku = ".jpeg" Then
ciag_prw = CStr(katalog.GetDetailsOf(plik, 12))
'Dziwna wartość po wykonaniu <<katalog.GetDetailsOf(plik, 12)>>, tj. "?01-?03-?2017 ??19:21"
'Poniżej odtworzenie zapisu daty
dlg = Len(ciag_prw)
poz = 0
For licz = 1 To dlg
poz = poz + 1
znak = Mid(ciag_prw, poz, 1)
If Asc(znak) <> 63 Then ciag_odtw = ciag_odtw & znak
Next licz
If ciag_odtw = "" Then ciag_odtw = "01-01-1980 00:00"
igt = igt + 1
ReDim Preserve tablica(igt)
tablica(igt) = ciag_odtw & ";" & katalog.GetDetailsOf(plik, 0)
ciag_odtw = ""
Else
ciag_prw = CStr(katalog.GetDetailsOf(plik, 3))
If ciag_prw = "" Then ciag_prw = "01-01-1980 00:00"
igt = igt + 1
ReDim Preserve tablica(igt)
tablica(igt) = ciag_prw & ";" & katalog.GetDetailsOf(plik, 0)
ciag_prw = ""
End If
End If
Next plik
'Wstawia do zmiennej modułowej informację o ilości plików w tablicy
il_plik = igt
Set apli = Nothing
Set katalog = Nothing
Exit Sub
koniec:
Set apli = Nothing
Set katalog = Nothing
End Sub
Sub c_sortowanie_babelkowe(tablica As Variant)
Dim pocz As Integer, koniec As Integer
Dim i As Integer, j As Integer
Dim przech As Variant
On Error GoTo koniec
pocz = LBound(tablica)
koniec = UBound(tablica)
For i = pocz To koniec - 1
For j = i + 1 To koniec
If tablica(i) > tablica(j) Then
przech = tablica(j)
tablica(j) = tablica(i)
tablica(i) = przech
End If
Next j
Next i
Exit Sub
koniec:
End Sub
Edit://
I found a temporary solution to this. I fired this code, without the patch you wrote about on another computer, where I literally closed all windows in the window. Only the powerpoint was opened. The window with the script was on top. I didn't touch anything and the script worked fine on a large batch of photos (> 10k), creating a total of 11 presentation files. Can you explain to me as someone who is into programming and certainly VB programming does not know why this is happening and how to "remove" this problem?
Attempted to read or write protected memory. This is often an indication that other memory is corrupt.
I got this error when I filter my datagridview by date and save it as .dat file.
Dim sv As New SaveFileDialog()
sv.FilterIndex = 2
sv.RestoreDirectory = True
sv.FileName = ""
sv.Filter = "Text Document |*.dat"
sv.Title = "Save as"
Dim mm As String = DateTimePicker1.Value.Month
Dim yy As String = DateTimePicker1.Value.Year
Dim dd As String = mm & yy
sv.FileName = "123456789" & "P" & dd
If sv.ShowDialog = DialogResult.OK Then
Dim writer As TextWriter = New System.IO.StreamWriter(sv.FileName)
writer.Write("H,P," & "123456789" & "," & "ABC CORP" & "," & "DELA CRUZ" & "," & "JUAN POGI" & "," & "MADLANGTUTA" & "," & "ABC CORP TRADENAME" & "," & "BATANGAS CITY" & "," & "BATANGAS PROVINCE" & " " & "4200" & "," & totalExempt & "," & totalZeroRated & "," & totalServices & "," & totalCapitalGoods & "," & totalGoodsOther & "," & totalInputTax & "," & Creditable & "," & totalNonCreditable & "," & "058" & "," & DateTimePicker1.Text & "," & "12")
writer.WriteLine("")
For i As Integer = 0 To DataGridView1.Rows.Count - 1 Step +1
writer.Write("D,P" & ",")
For j As Integer = 0 To 12
writer.Write(DataGridView1.Rows(i).Cells(j).Value.ToString() & ",")
Next
writer.Write("123456789" & "," & DateTimePicker1.Text)
writer.WriteLine("")
Next
writer.Close()
MsgBox("Generated Successfully", MsgBoxStyle.Information, "Transaction Complete")
End If
https://drive.google.com/file/d/18lODhowILSuyl7zKZyJ55cH9U9DvL393/view
here is the screen recording of my project
enter code here
'' this is my code for filter
Call connectDB()
Try
con.Open()
cmd = New OleDbCommand("select colDate, colSupplierTin, ColSupplierName, colLastName, colFirstName, colMiddleName, colAddress1, colAddress2, colExempt, colZeroRated,colDomesticServices,colCapitalGood, colDomesticGoods, colInputTax,colNetofvat from tblPurchases where colDate like '%" + DateTimePicker1.Text + "%'", con)
adp = New OleDbDataAdapter(cmd)
Dim table As New DataTable()
adp.Fill(table)
DataGridView1.DataSource = table
Dim src As New BindingSource
src.DataSource = DataGridView1.DataSource
DataGridView1.Columns(0).HeaderText = "DATE"
DataGridView1.Columns(0).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleCenter
DataGridView1.Columns(0).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(1).HeaderText = "SUPPLIER TIN"
DataGridView1.Columns(1).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(1).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleCenter
DataGridView1.Columns(1).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(2).HeaderText = "SUPPLIER NAME"
DataGridView1.Columns(2).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(2).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(3).HeaderCell.Value = "LAST NAME"
DataGridView1.Columns(3).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(3).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(3).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleCenter
DataGridView1.Columns(4).HeaderCell.Value = "FIRST NAME"
DataGridView1.Columns(4).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(4).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(4).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleLeft
DataGridView1.Columns(5).HeaderCell.Value = "MIDDLE NAME"
DataGridView1.Columns(5).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(5).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(5).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleLeft
DataGridView1.Columns(6).HeaderCell.Value = "BARANGAY / SUBSTREET"
DataGridView1.Columns(6).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(6).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(6).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleLeft
DataGridView1.Columns(7).HeaderCell.Value = "CITY / PROVINCE"
DataGridView1.Columns(7).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(7).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(8).HeaderCell.Value = "EXEMPT PURCHASES"
DataGridView1.Columns(8).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(8).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(9).HeaderCell.Value = "ZERO-RATED PURCHASES"
DataGridView1.Columns(9).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(9).DefaultCellStyle.Alignment = DataGridViewContentAlignment.BottomCenter
DataGridView1.Columns(9).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(10).HeaderCell.Value = "DOMESTIC SERVICES"
DataGridView1.Columns(10).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(10).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleRight
DataGridView1.Columns(10).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(11).HeaderCell.Value = "CAPITAL GOODS"
DataGridView1.Columns(11).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(11).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleRight
DataGridView1.Columns(11).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(12).HeaderCell.Value = "GOODS OTHER THAN CAPITAL GOODS"
DataGridView1.Columns(12).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(12).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleRight
DataGridView1.Columns(12).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(13).HeaderCell.Value = "TOTAL INPUT TAX"
DataGridView1.Columns(13).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(13).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleRight
DataGridView1.Columns(13).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(14).HeaderCell.Value = "TAXABLE NET OF VAT"
DataGridView1.Columns(14).AutoSizeMode = DataGridViewAutoSizeColumnMode.AllCells
DataGridView1.Columns(14).DefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleRight
DataGridView1.Columns(14).SortMode = DataGridViewColumnSortMode.Programmatic
DataGridView1.Columns(14).DefaultCellStyle.Format = "c"
Catch ex As Exception
MsgBox(ex.Message)
End Try
Call Computation()
con.Close()
My macro in VBA Word 2016 (Win10) is verys slow for a 3-page document. What can I do to make it faster? Or is there another way I may count characters in paragraphs of different styles? I need to know how many characters are written in Normal style, H1-style etc.
Sub avsnittsteller()
'Optimize Code
Application.ScreenUpdating = False
'Rydd opp i formateringen
'Call stilFinner
intTittel = ActiveDocument.CustomDocumentProperties("malTittel").Value
intTittelI = ActiveDocument.CustomDocumentProperties("malTittelI").Value
intTittelX = ActiveDocument.CustomDocumentProperties("malTittelX").Value
intIngress = ActiveDocument.CustomDocumentProperties("malIngress").Value
intNormal = ActiveDocument.CustomDocumentProperties("malNormal").Value
'sett variablene til 0 før de avsnittene telles
Dim mlm(10) As String
tittel = 0
ingress = 0
mlm(1) = 0
mlm(2) = 0
mlm(3) = 0
mlm(4) = 0
mlm(5) = 0
mlm(6) = 0
mlm(7) = 0
' TELLE TEGN I ALLE AVSNITT
Dim Doc As Document
Set Doc = ActiveDocument
Dim para As Paragraph
Dim i As Long: i = 0
Dim j As Long: j = 0
Dim k As Long: k = 0
For Each para In Doc.Paragraphs
If para.Style = Doc.Styles("instruksjon") Or _
para.Style = Doc.Styles("Bildetekst") Or _
para.Style = Doc.Styles("Byline") Or _
para.Style = Doc.Styles("Byline email") Or _
para.Style = Doc.Styles("Fakta punkt") Or _
para.Style = Doc.Styles("tittel") Then
Else
If para.Style = Doc.Styles(wdStyleHeading1) Then
tittel = para.Range.Characters.Count - 1
Else
If para.Style = Doc.Styles(wdStyleHeading2) Then
ingress = para.Range.Characters.Count - 1
Else
If para.Style = Doc.Styles(wdStyleHeading3) Then
i = i + 1
mlm(i) = para.Range.Characters.Count - 1
Else
If para.Style = Doc.Styles(wdStyleNormal) Then
j = j + para.Range.Characters.Count - 1
End If 'N
End If 'H3
End If 'H2
End If 'H1
End If 'alle andre stiler
Next para
normal = j
'MsgBox "Tittelen din har " & tittel & " tegn" & vbCrLf & " ingress " & ingress & vbCrLf & " mlm-3 " & mlm(3) & vbCrLf & " mlm-4 " & mlm(4) & vbCrLf & "Alle normal " & normal
'MsgBox "Dokumentet blir nå lagret og antall tegn du har skrevet blir oppdatert øverst i dokumentet."
'MsgBox ActiveDocument.Paragraphs.Count
'DEFINER DOC PROPERTIES VARIABLENE
ActiveDocument.CustomDocumentProperties("tittel").Value = tittel
ActiveDocument.CustomDocumentProperties("ingress").Value = ingress
ActiveDocument.CustomDocumentProperties("mlm1").Value = mlm(1)
ActiveDocument.CustomDocumentProperties("mlm2").Value = mlm(2)
ActiveDocument.CustomDocumentProperties("mlm3").Value = mlm(3)
ActiveDocument.CustomDocumentProperties("mlm4").Value = mlm(4)
ActiveDocument.CustomDocumentProperties("mlm5").Value = mlm(5)
ActiveDocument.CustomDocumentProperties("mlm6").Value = mlm(6)
ActiveDocument.CustomDocumentProperties("mlm7").Value = mlm(7)
ActiveDocument.CustomDocumentProperties("normal").Value = j
ActiveDocument.Fields.Update 'OPPDATER ALLE FELT nb, virker ikke i bunn og topptekst
'MsgBox intTittelX
'Farg tittel og ingress rød om de er for lange, blå om de er passe korte
If tittel > intTittelX Then
With ActiveDocument.Styles(wdStyleHeading1).Font
.Color = wdColorRed
End With
Else
With ActiveDocument.Styles(wdStyleHeading1).Font
.Color = -738148353
End With
End If
If ingress > intIngress Then
With ActiveDocument.Styles(wdStyleHeading2).Font
.Color = wdColorRed
End With
Else
With ActiveDocument.Styles(wdStyleHeading2).Font
.Color = -738148353
End With
End If
'Optimize Code
Application.ScreenUpdating = True
End Sub
Try loading it into memory first, then taking action after the data has been loaded to an array. I just did a test with about 60 pages, it is taking about 8 seconds to populate the various attributes to an array. Once it's in the array, then manipulate it from there.
Here's the code:
Option Explicit
Public Sub test()
Debug.Print Now()
Dim doc As Document: Set doc = ActiveDocument
Dim i As Long
Dim myArr As Variant: ReDim myArr(1, 0 To doc.Paragraphs.Count - 1)
Dim para As Paragraph
For Each para In doc.Paragraphs
myArr(0, i) = para.Style
myArr(1, i) = para.Range.Characters.Count
i = i + 1
Next
Debug.Print Now()
Debug.Print myArr(0, 0), myArr(1, 0)
End Sub
I'm not sure if this is the proper way of doing this, but at least it works! I hope this code may help someone else looking for a way to loop through paragraphs and count the characters. Thank you Ryan!
Option Explicit
Public Sub avsnittsteller()
'http://stackoverflow.com/questions/42390551/vba-slow-macro-looping-through-paragraphs
Debug.Print Now()
Application.ScreenUpdating = True
'Rydd opp i formateringen
Call stilFinner
'deklarere variablene
Dim doc As Document: Set doc = ActiveDocument
Dim i As Long
Dim j As Long
Dim k As Long
Dim H1 As Long
Dim H2 As Long
Dim H3 As Long
Dim N As Long
Dim myArr As Variant: ReDim myArr(1, 0 To doc.Paragraphs.Count - 1)
Dim mlm(10) As String
Dim para As Paragraph
'Hent fram verdier i globale variabler som angir riktig lengde
intTittel = ActiveDocument.CustomDocumentProperties("malTittel").Value
intTittelI = ActiveDocument.CustomDocumentProperties("malTittelI").Value
intTittelX = ActiveDocument.CustomDocumentProperties("malTittelX").Value
intIngress = ActiveDocument.CustomDocumentProperties("malIngress").Value
intNormal = ActiveDocument.CustomDocumentProperties("malNormal").Value
'sett variablene til 0 før de avsnittene telles
tittel = 0
ingress = 0
mlm(1) = 0
mlm(2) = 0
mlm(3) = 0
mlm(4) = 0
mlm(5) = 0
mlm(6) = 0
mlm(7) = 0
'Lag en matrise (array) i minnet og kjør søket fra den
'Debug.Print doc.Paragraphs.Count
For Each para In doc.Paragraphs
myArr(0, i) = para.Style
myArr(1, i) = para.Range.Characters.Count - 1 'ComputeStatistics(wdStatisticCharacters)
i = i + 1
Next
'For hvert avsnitt fra 0 til antall avsnitt i dokumentet
For j = 0 To doc.Paragraphs.Count - 1
'Hvis avsnittets stil er Normal eller en av overskriftene så legg sammen alle tegnene
If myArr(0, j) = "Normal" Then
N = N + myArr(1, j)
'Debug.Print j, myArr(0, j), myArr(1, j)
End If
If myArr(0, j) = "Overskrift 1" Or myArr(0, j) = "Heading 1" Then
H1 = H1 + myArr(1, j)
'Debug.Print j, myArr(0, j), myArr(1, j)
End If
If myArr(0, j) = "Overskrift 2" Or myArr(0, j) = "Heading 2" Then
H2 = H2 + myArr(1, j)
'Debug.Print j, myArr(0, j), myArr(1, j)
End If
If myArr(0, j) = "Overskrift 3" Or myArr(0, j) = "Heading 3" Then
'Alle avsnitt med H3 telles ett og ett, summeres ikke
k = k + 1
mlm(k) = myArr(1, j)
Debug.Print j, myArr(0, j), myArr(1, j)
End If
Next j 'Neste avsnitt
'Debug.Print N & " " & H1 & " " & H2
'Debug.Print mlm(1) & " " & mlm(2) & " " & mlm(3) & " " & mlm(4) & " " & mlm(5)
'DEFINER DOC PROPERTIES VARIABLENE
ActiveDocument.CustomDocumentProperties("tittel").Value = H1
ActiveDocument.CustomDocumentProperties("ingress").Value = H2
ActiveDocument.CustomDocumentProperties("mlm1").Value = mlm(1)
ActiveDocument.CustomDocumentProperties("mlm2").Value = mlm(2)
ActiveDocument.CustomDocumentProperties("mlm3").Value = mlm(3)
ActiveDocument.CustomDocumentProperties("mlm4").Value = mlm(4)
ActiveDocument.CustomDocumentProperties("mlm5").Value = mlm(5)
ActiveDocument.CustomDocumentProperties("mlm6").Value = mlm(6)
ActiveDocument.CustomDocumentProperties("mlm7").Value = mlm(7)
ActiveDocument.CustomDocumentProperties("normal").Value = N
ActiveDocument.Fields.Update 'OPPDATER ALLE FELT nb, virker ikke i bunn og topptekst
'Farg tittel og ingress rød om de er for lange, blå om de er passe korte
If tittel > intTittelX Then
With ActiveDocument.Styles(wdStyleHeading1).Font
.Color = wdColorRed
End With
Else
With ActiveDocument.Styles(wdStyleHeading1).Font
.Color = -738148353
End With
End If
If ingress > intIngress Then
With ActiveDocument.Styles(wdStyleHeading2).Font
.Color = wdColorRed
End With
Else
With ActiveDocument.Styles(wdStyleHeading2).Font
.Color = -738148353
End With
End If
Application.ScreenUpdating = True
Debug.Print Now()
End Sub
I have some problem with Excel macro...
When I run this script I received
error runtime 1004: method save as of object _workbook failed
One month ago this macro worked good.... Where is the problem?
I did not do a program this script, I found it already used in the station of my old colleague, and so far has ever given no problem ....
Thanks for help
Sub StampaVodafone()
Dim i, j As Integer
Dim Fogliotmp As Worksheet
Dim ContoVodafone As String
Dim FoglioElenco As Worksheet
Dim Percorsofile As String
Dim PercorsoSalva As String
Dim ValCell As Variant
Dim strTesto As String
strTesto = "Vuoi procedere con la stampa ?" & vbCr & "SI - Per procedere con la stampa dei dettagli telefonici" & _
vbCr & "NO - Per andare alla procedura successiva"
If MsgBox(strTesto, 68, "Avvio StampaVodafone") = vbYes Then
'Procedura di stampa documenti
i = 1
Do
Set Fogliotmp = ActiveWorkbook.Worksheets(i)
If UCase(Mid(Fogliotmp.Name, 1, 3)) = "TEL" Or UCase(Mid(Fogliotmp.Name, 1, 3)) = "LA " Then
'Trovo dove sta la fine pagina
j = 15
ValCell = Mid(CStr(Fogliotmp.Cells(j, 1).Value), 1, 12)
Do While (UCase(ValCell) <> "TOTALE COSTI")
j = j + 1
ValCell = Mid(CStr(Fogliotmp.Cells(j, 1).Value), 1, 12)
Loop
With Fogliotmp.PageSetup
.LeftMargin = 0
.RightMargin = 0
.TopMargin = 0
.BottomMargin = 0
.PrintArea = "$A$1:$P$" & CStr(j)
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Fogliotmp.PrintOut
End If
i = i + 1
Set Fogliotmp = Nothing
Loop While (i < ActiveWorkbook.Worksheets.Count + 1)
MsgBox "Ho terminato di stampare", vbExclamation, "MACRO SONIA"
'Fine procedura stampa
End If
'--
strTesto = "Vuoi procedere con l'estrazione dei file XLSX da spedire agli utenti?" & vbCr & _
"SI - Inizia la generazione dei file XLSX" & vbCr & _
"NO - Termina la macro"
If MsgBox(strTesto, 68, "Genera XLS") = vbYes Then
'Inizio estrazione
Percorsofile = "H:\Vodafone\ElencoCellEstrazione.xlsx"
PercorsoSalva = "H:\Vodafone\Estratti\"
ContoVodafone = Application.ActiveWorkbook.Name
'--
Set FoglioElenco = Workbooks.Open(Percorsofile).Worksheets(1)
'--
i = 1
Do
Windows(ContoVodafone).Activate
Set Fogliotmp = ActiveWorkbook.Worksheets(i)
If UCase(Mid(Fogliotmp.Name, 1, 3)) = "TEL" Then
strTesto = Trim(Mid(Fogliotmp.Name, 4, Len(Fogliotmp.Name)))
'Cerco il nome della persona
j = 2
ValCell = Trim(CStr(FoglioElenco.Cells(j, 1).Value))
Do While (UCase(ValCell) <> UCase(strTesto) And UCase(ValCell) <> "END LIST")
j = j + 1
ValCell = Trim(CStr(FoglioElenco.Cells(j, 1).Value))
Loop
If UCase(ValCell) <> "END LIST" Then
'Ho il nome dell'intestatario del telefono
ValCell = Trim(CStr(FoglioElenco.Cells(j, 2).Value))
strTesto = PercorsoSalva & ValCell
'Salvo il documento
Windows(ContoVodafone).Activate
Sheets(Fogliotmp.Name).Select
Sheets(Fogliotmp.Name).Copy
ActiveWorkbook.SaveAs Filename:=strTesto, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Windows(ContoVodafone).Activate
End If
End If
'--
i = i + 1
Set Fogliotmp = Nothing
Windows(ContoVodafone).Activate
Loop While (i < ActiveWorkbook.Worksheets.Count + 1)
MsgBox "Ho terminato gli export XlsX", vbExclamation, "MACRO SONIA"
End If
End Sub
You should debug the value of strTesto. Check if it's not null and if it has the extension correct (.xlsm)
TIP: How to debug in
excel
I have one excel with 90.000 rows, but when i filter my Column "H1" by "Sample Shop", i have 2000 rows. I want to read 2000 rows not 90000. How set a filter before i read excel file in vb.net?
My code is:
Do While currentWorksheet.Cells(i, 1).Value <> Nothing
If workBook.Worksheets.Count > 0 Then
Name = currentWorksheet.Cells(i, 1).Value
DataSo = currentWorksheet.Cells(i, 33).Value
Try
Dim Conv As Double = Double.Parse(DataSo)
Variable = DateTime.FromOADate(Conv).ToString("MMMM/dd/yyyy")
Catch ex As Exception
End Try
Data1 = Convert.ToDateTime(BOX_Data1.Text)
Data2 = Convert.ToDateTime(BOX_Data2.Text)
If (currentWorksheet.Cells(i, 4).Value) = "Completed" And (currentWorksheet.Cells(i, 8).Value) = "RBT SAMPLE SHOP" Then
If Variable >= Data1 And Variable <= Data2 Then
If currentWorksheet.Cells(i, 35).Value <> Nothing Or currentWorksheet.Cells(i, 35).Value = "0.00" Then
'a = String.Format("{0:N2}", Double.Parse(a))
a = a + currentWorksheet.Cells(i, 35).Value
x1 = x1 + 1
End If
If currentWorksheet.Cells(i, 38).Value <> Nothing Or currentWorksheet.Cells(i, 38).Value = "0.00" Then
'b = String.Format("{0:N2}", Double.Parse(b))
b = b + currentWorksheet.Cells(i, 38).Value
x2 = x2 + 1
End If
If currentWorksheet.Cells(i, 41).Value <> Nothing Or currentWorksheet.Cells(i, 41).Value = "0.00" Then
'c = String.Format("{0:N2}", Double.Parse(c))
c = c + currentWorksheet.Cells(i, 41).Value
x3 = x3 + 1
End If
End If
End If
i = i + 1
Loop
You can use a similar code:
Dim oledbConnectionString As String = "PROVIDER=Microsoft.Jet.OLEDB.4.0;" _
& "DATA SOURCE=YourExcelFilePath.xls;" _
& "EXTENDED PROPERTIES='Excel 8.0;HDR=No'"
Dim oledbConn As New OleDbConnection(oledbConnectionString)
oledbConn.Open()
Dim oledbCommand As OleDbCommand = oledbConn.CreateCommand()
oledbCommand.CommandText = "SELECT * " _
& "FROM [YourExcelSheetName$] " _
& "WHERE [F8] LIKE #filter + '%'"
oledbCommand.Parameters.Add("#filter", OleDbType.VarChar).Value = "sample shop"
Dim oledaXLSDaCaricare As New OleDbDataAdapter(oledbCommand)
Dim dtTest As New DataTable
Try
oledaXLSDaCaricare.Fill(dtTest)
Catch ex As Exception
MsgBox(ex.Message, MsgBoxStyle.Critical)
End Try
oledbConn.Close()
oledbConn.Dispose()
Some notes:
HDR=No indicates that the first row doesn't contains column names; maybe you have to change it in HDR=Yes
[F8] is a reference to the eigth column in the sheet, so H column