PESEL - makro

Gotowe szablony, skrypty, makropolecenia i rozszerzenia. Tutaj możesz pochwalić i podzielić się swoją twórczością z innymi użytkownikami
Tithen-Firion
Posty: 1
Rejestracja: ndz kwie 11, 2021 1:41 pm

PESEL - makro

Post autor: Tithen-Firion »

Napisałem kilka funkcji, może komuś się przyda.

PESEL_OK - sprawdza czy podany PESEL jest poprawny
(funkcje poniżej nie sprawdzają poprawności PESELu!)
PESEL_DATA - zwraca datę urodzenia z podanego numeru PESEL
PESEL_PLEC - zwraca płeć, K (kobieta) albo M (mężczyzna)
PESEL_K - zwraca prawdę jeśli pesel należy do kobiety
PESEL_M - zwraca prawdę jeśli pesel należy do mężczyzny

Żeby je dodać do arkusza wybierz:
Narzędzia > Makra > Zarządzaj makrami > Basic
Wybierz swój plik, kliknij "Nowy", "OK", zastąp tekst kodem poniżej, zapisz makro (Plik > Zapisz) i zamknij okno.

Kod: Zaznacz cały

Function PESEL_OK(pesel As String) As Boolean
	Dim i%, i2%, cyfra%, suma%, wagi (10) as Integer
	If Len(pesel) = 11 Then
		wagi = Array(1, 3, 7, 9, 1, 3, 7, 9, 1, 3, 1)
		suma=0
		i2=1
		For i = LBound(wagi) To UBound(wagi)
			cyfra=Mid(pesel, i2, 1)
			suma=suma+(cyfra*wagi(i))
			i2=i2+1
		Next
		PESEL_OK=(suma MOD 10) = 0
	Else
		PESEL_OK=False
	End If
End Function

Function PESEL_DATA(pesel As String) As Date
	On Error GoTo ErrorHandler
	Dim stulecie%, rok%, miesiac%, dzien%, rok2%
	rok=Mid(pesel, 1, 2)
	miesiac=Mid(pesel, 3, 2)
	dzien=Mid(pesel, 5, 2)
	stulecie=1
	While miesiac > 20
		miesiac=miesiac-20
		stulecie=stulecie+1
	Wend
	rok2=Choose(stulecie, 1900, 2000, 2100, 2200, 1800)
	If miesiac = 0 Then miesiac=1
	If dzien = 0 Then dzien=1
	PESEL_DATA=DateSerial(rok+rok2, miesiac, dzien)
	Exit Function
ErrorHandler:
	PESEL_DATA=DateSerial(0, 1, 1)
End Function

Function PESEL_K(pesel As String) As Boolean
	Dim cyfra%
	cyfra=Mid(pesel, 10, 1)
	PESEL_K=(cyfra MOD 2) = 0
End Function

Function PESEL_M(pesel As String) As Boolean
	PESEL_M=Not PESEL_K(pesel)
End Function

Function PESEL_PLEC(pesel As String) As String
	If PESEL_K(pesel) Then PESEL_PLEC="K" Else PESEL_PLEC="M"
End Function
LibreOffice 6.4 na Windows 10
Awatar użytkownika
Jermor
Posty: 1814
Rejestracja: sob paź 12, 2013 11:09 am
Kontakt:

Re: PESEL - makro

Post autor: Jermor »

Tak jak napisałeś, może się komuś przydadzą. Chciałbym jednak zwrócić ci uwagę na sposób budowania makr, ze względu na ich przeznaczenie. Napisałem o tym nieco w tym opracowaniu https://yestok.pl/lbo/y61.php (akurat kod PESEL-u wykorzystałem jako przykład).
O ile w pierwszej zacytowanej funkcji sprawdzasz długość kodu, to nie robisz tego już w następnych makrach. Jeśli więc użytkownik pomyli się i wpisze krótszy kod, to np. funkcje dotyczące płci nie wykonają się poprawnie.
Ponadto wydaje mi się, że powinieneś jednak kontrolować czy to, co wpisał użytkownik, jako argument funkcji, może zostać uznane za PESEL.
Może, zamiast kilku funkcji, utworzyć jedną, z drugim parametrem określającym, jaka wartość ma zostać zwrócona.
AOO 4.1.12, LO 7.2.7 (x64) na Windows 10 64bit
Ważne!
Jeśli twój problem został rozwiązany, wróć do swojego pierwszego postu, przejdź do edycji i dopisz [SOLVED] w temacie.
Inni, którzy mają podobny problem, będą wiedzieli, że istnieje jego rozwiązanie.
Awatar użytkownika
Rafkus
Posty: 437
Rejestracja: czw kwie 12, 2018 10:26 pm

Re: PESEL - makro

Post autor: Rafkus »

Ostatnio w dziale Base był poruszony temat sprawdzenia poprawności numeru pesel w formularzu (zobaczysz go tutaj), wczytałem się w ten problem i mam uwagi odnośnie kodu pozostawionego przez @Tithen-Firion:

Kod: Zaznacz cały

	If Len(pesel) = 11 Then
Test czy pesel składa się z 11 znaków, można by jeszcze sprawdzić czy składa się on wyłącznie z cyfr.

Kod: Zaznacz cały

	rok2=Choose(stulecie, 1900, 2000, 2100, 2200, 1800)
Basic nie obsługuje funkcji Choose, więc dostarczone makro wykłada się na tym poleceniu.

Kod: Zaznacz cały

	If miesiac = 0 Then miesiac=1
	If dzien = 0 Then dzien=1
Jeśli miesiąc lub dzień według pesla wynosi zero to dokonuje podmiany na wartość 1. Uważam, że tutaj powinien być komunikat o błędnym numerze.


Poprawiłem makro przedstawione w dziale BASE i jeśli ktoś chce może użyć tej funkcji:

Kod: Zaznacz cały

Function Sprawdz_Pesel(optional Nr_PESEL As Variant, optional Opcja As Byte)As Variant
' Funkcja zwraca wartość Null jeżeli Nr_PESEL jest pusty
' W zależności od wartości drugiego parametru funkcja zwraca:
' 0  lub brak - wszystkie poniższe wartości (!formuła macierzowa w CALC)
' 1 - True lub False poprawności PESELa
' 2 - datę urodzenia danej osoby lub null jeśli pesel jest błędny
' 3 - płeć osoby (K dla kobiety, M dla mężczyzny) lub null jeśli pesel jest błędny
' 4 - komentarz tekstowy o dostarczonym numerze

	If IsMissing(Nr_PESEL) Or Len(Nr_PESEL) = 0 Then
		Sprawdz_Pesel = Null
		Exit Function
	elseIf IsMissing(Opcja) then
		Opcja = 0	
	End If
Dim Waga() As Byte		'waga jest używana do weryfikacji prawidłowości numeru PESEL
	Waga = Array(1,3,7,9,1,3,7,9,1,3,1)
Dim lata() as byte		'pierwsze dwie cyfry roku
	lata = Array(19,20,21,22,18)
Dim Sumakontrolna As Integer, i As Integer, rok as Integer
Dim mies as Byte, dzien as Byte, iledni As Byte
Dim Cyfrakontrolna As string
Dim wynik(3) as variant

	wynik(0) = false
	wynik(3) = "Podany numer nie jest Peslem"
	If Len(Nr_PESEL) <> 11 or Not IsNumeric(Nr_PESEL) Then
		If IsNumeric(Nr_PESEL) Then
			wynik(3) = "Numer PESEL składa się z 11 cyfr."
		Else
			wynik(3) = "Używaj tylko cyfr. Numer PESEL składa się z 11 cyfr."
		EndIf
	else
		i = val(Mid(Nr_PESEL,3,1))\2		'dzielenie całkowite
		rok = lata(i) & Left(Nr_PESEL,2)	'rok	urodzin
		mies = val(Mid(Nr_PESEL,3,2))-i*20	'miesiąc urodzin
		dzien = Mid(Nr_PESEL,5,2)	'dzień	urodzin
		select case mies		'ile dany miesiąc ma dni
			case 1,3,5,7,8,10,12 :	iledni = 31	'te miesiące maja 31 dni
			case 4,6,9,11 :			iledni = 30
			case 2	
				if ((rok mod 4)=0 and (rok mod 100)<>0) or (rok mod 400) = 0 then 	'czy rok przestępny
					iledni = 29
				else iledni = 28
				endif
			case else	'obliczona wartość mies jest spoza przedziału (1...12)
				iledni = 0	'miesiąc jest błędny
		end select
	'kontrola daty
		if dzien=0 or dzien>iledni then		'jeśli data jest błędna (nieistniejący miesiąc lub dzień)
			wynik(3) = "Błędna sekwencja cyfr odpowiadających dacie"
		elseif DateSerial(rok, mies, dzien) > Date then		'kontrola urodzenia; czy data ur. > dziś
			wynik(3) = "Według podanego numeru ta osoba jeszcze się nie urodziła."
		else 		'gdy data jest poprawna
			Sumakontrolna = 0
			for i=1 to 10
				Sumakontrolna = Sumakontrolna + val(Mid(Nr_PESEL, i, 1)) * Waga(i-1)
			next i
			Cyfrakontrolna = Right(10 - (Sumakontrolna Mod 10), 1)
			if Right(Nr_PESEL,1) = Cyfrakontrolna then 
				wynik(0) = true
				wynik(1) = DateSerial(rok, mies, dzien)
				wynik(2) = iif((val(Mid(Nr_PESEL, 10, 1)) mod 2) , "M" , "K")
				wynik(3) = "Podany numer jest Peslem"
			end if
		endif			
	Endif

'Wypisanie wynikówów
	select case Opcja
		case 0 		'zwróci wszystkie wyniki (użyj formuły macierzowej w CALC)
			Sprawdz_Pesel = wynik
		case 1, 4	'ma zwrócić informację o poprawności PESELa (logiczną lub tekstową)
			Sprawdz_Pesel = wynik(Opcja-1)
		case 2, 3	'te wyniki ma podać tylko w przypadku prawidłowego pesla		 
			if wynik(0) = false then
				Sprawdz_Pesel = null
			else	'2 zwraca datę urodzenia, 3 informację o płci
				Sprawdz_Pesel = wynik(Opcja-1)
			endif
		case else	'jeśli podano błędny parametr
			Sprawdz_Pesel = "Wpisano błędny opcjonalny parametr funkcji, spodziewana wartość to 0,1,2,3 lub brak."
	end select
End Function
Jak widać jest ona zgodna z sugestią:
Jermor pisze: Może, zamiast kilku funkcji, utworzyć jedną, z drugim parametrem określającym, jaka wartość ma zostać zwrócona.
LibreOffice 7.1.6 (preferowany) oraz OpenOffice 4.1.6. Widows 10
OpenOffice 4.1.3. oraz Libre 4.2.5.2 Windows XP
ODPOWIEDZ