Option Explicit
Dim sn_uzunluk As String
Dim sn As Integer
Const pi = 22 / 7
Private Sub Form_Load()
sn_uzunluk = Form1.ScaleWidth / 2
End Sub
Private Sub Timer1_Timer()
sn = Format(Time, "s")
saniye.X2 = Sin(2 * pi * ((sn * pi / 30) / (2 * pi))) * sn_uzunluk + saniye.X1
saniye.Y2 = -Cos(2 * pi * ((sn * pi / 30) / (2 * pi))) * sn_uzunluk + saniye.Y1
End Sub

Dim ad As String: Dim tekrak As Integer
tekra = 0
ad = InputBox("adınızı giriniz")
Do Until ad = "uğur"
tekrar = tekrar + 1
If tekrar = 3 Then
MsgBox ("üzgünüm deneme hakkın dolmuştur")
Exit Do
End If
MsgBox ("yanlış isim girdiniz")
ad = InputBox("adınızı giriniz")
Loop
msgbox("doğru isim")

Private Sub Command1_Click()
On Error Resume Next
a = 0
b = 0
For i = 0 To 255
crypt(i) = b & a
enscrypt(i) = (Chr(i))
b = b + 1
If (a <> "a" And a <> "b" And a <> "c" And a <> "d" And a <> "e" And a <> "f") Then
a = a + 1
b = b - 1
End If
If (a = 10) Or a = "a" Or a = "b" Or a = "c" Or a = "d" Or a = "e" Or a = "f" Then
Select Case a
Case "a": a = "b"
b = b - 1
Case "b": a = "c"
b = b - 1
Case "c": a = "d"
b = b - 1
Case "d": a = "e"
b = b - 1
Case "e": a = "f"
b = b - 1
Case "f": a = "0"
Case Else:
a = "a"
End Select
End If
If b = 9 Then
b = 0
End If
If b = 9 Then
c = 0
End If
DoEvents
Next
'buraya kadar olan kısımda dizi değişkenlere hash ve karakter değerlerini atadık
'bundan sonrası hashi çözmekte
Text2 = "" 'text2 nin içeriğini sildik
wq = InStr(1, Text1, "\u00") 'hasin başladığı karakteri aratıp "wq" değişkenine atıyoruz
For i = (wq + 3) To wq + Len(Text1) Step 6 'hash standart olduğundan her karakter arası 6
Text1.SelStart = i
Text1.SelLength = 2 'hashler 2 karakterde gizli :)
For t = 0 To 255
If crypt(t) = Text1.SelText Then
inar = t
Text2 = Text2 & (enscrypt(t))
Exit For
End If
Next
DoEvents
Next
End Sub
Private Sub Command2_Click()
On Error Resume Next
a = 0
b = 0
For i = 0 To 255
crypt(i) = b & a
enscrypt(i) = (Chr(i))
b = b + 1
If (a <> "a" And a <> "b" And a <> "c" And a <> "d" And a <> "e" And a <> "f") Then
a = a + 1
b = b - 1
End If
If (a = 10) Or a = "a" Or a = "b" Or a = "c" Or a = "d" Or a = "e" Or a = "f" Then
Select Case a
Case "a": a = "b"
b = b - 1
Case "b": a = "c"
b = b - 1
Case "c": a = "d"
b = b - 1
Case "d": a = "e"
b = b - 1
Case "e": a = "f"
b = b - 1
Case "f": a = "0"
Case Else:
a = "a"
End Select
End If
If b = 9 Then
b = 0
End If
If b = 9 Then
c = 0
End If
DoEvents
Next
'buraya kadar olan kısım olmsı gerktiği gibi aynısı
Text1 = "<script type=" & Chr(34) & "text/javascript" & Chr(34) & ">document.write(" & Chr(39) 'browser'ın okuyabilmesi için js açılış tag'ı
For i = 0 To Len(Text2)
Text2.SelStart = i
Text2.SelLength = 1 'her bir karakteri crypt edeceğiz
For t = 0 To 255
If enscrypt(t) = Text2.SelText Then
Text1 = Text1 & "\u00" & (crypt(t))
Exit For
End If
Next
DoEvents
Next
Text1 = Text1 & "')</script>" 'html kodu içinde çalışabilmesi için kapatma js tag'ı
End Sub

Option Explicit
'API Kullanici tanitma
Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

Private Declare Function GetLastError Lib "kernel32" () _
As Long

Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" (ByVal dwFlags As Long, _
lpSource As Any, ByVal dwMessageId As Long, ByVal _
dwLanguageId As Long, ByVal lpBuffer As String, _
ByVal nSize As Long, Arguments As Long) As Long
'API windows u kapama
Private Declare Function ExitWindows Lib "User32" Alias _
"ExitWindowsEx" (ByVal dwOptions As Long, ByVal _
dwReserved As Long) As Long

Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2

Private Sub Form_Load()
Dim User$
User = Chr$(34) & User_Name & Chr$(34)
If Len(User) > 2 Then Option1.Caption = User & " Cikis"
End Sub
Private Function User_Name() As String
Dim L&,Sonuc&,Hata&
Dim User$, Puffer$

'Kullanici ismine erisim
User = Space(255)
L = 255
Ergebnis = GetUserName(User, L)

If Ergebnis <> 0 Then
User_Name = Left$(User, L - 1)
Else
User_Name = ""
End If
End Function


Private Sub Command1_Click()
If Option1.Value Then
'Kullanici degistirme
ExitWindows EWX_LOGOFF, &HFFFF
Unload Me
ElseIf Option2.Value Then
'Yeniden baslatma
ExitWindows EWX_REBOOT, &HFFFF
Else
'Kapatma
ExitWindows EWX_SHUTDOWN, &HFFFF
End If
End Sub
Private Sub Command2_Click()
MsgBox "Neden simdi ?"
Unload Me
End Sub
Private Sub Command3_Click()
MsgBox "Artik yardimci olamam !"
Unload Me
End Sub
 
Excel tablolarının MySQL'e aktarılması
 
Excel Dosyalarını MySQL'e aktarma
Merhaba
 
MySQL ve Visual Basic makalelerimin 3'üçüncüsünde Excel dosyalarını MySQL'e aktarmayı anlatmaya çalışacağım
Visual Basic'te yeni bir proje açın ve 3 adet Form ekleyin.
Form1'in adını ExcelToMysqlAnafrm olarak değiştirin.
Form2'nin adını ExcelToMysqltablosecfrm olarak degistirin
Form3'ün adını ExcelToMysqlprogressfrm olarak degistirin
ExcelToMysqlAnafrm formuna 4 adet Button, 5 adet Text kutusu ve 1 adet Commondialog nesnesi yerleştirin.
ExcelToMysqlprogressfrm formuna 1 adet label(adı:labeldurum), ve 1 adet progressbar(adı:progress) yerleştirin.
Text kutularından birisini txtMessage olarak değiştirin ve aşağıdaki kodları birinci forma yani ExcelToMysqlanafrm'ye yapıştırın.
Projenizle aynı dizin içerisine odbc_info.txt dosyasını boş olarak açın.İleride içerisine Odbc ayarları kaydedilecek.
'//////////Kod başlangıcı////////////////
Private Enum StepProcess
XLS_SELECTION = 1
ODBC_SETTING = 2
CHECKING_INFO = 3
COMPLETE_PROCESS = 4
End Enum
' Message ayarları
Private Const strTitle = "ExcelToMysql"
Private Const strExitMsg = "Çıkmak istiyormusunuz?"
Private Const strReqDsnMsg = "ODBC ayarlarını girin"
Private Const strReqTableMsg = "Tablo adını girmelisin!"
Private Const strErrNotExistCols = "Excel dosyasındaki sütunlar ile MySQL tablo sütunları uyuşmuyor!"
Private Const strErrNotExistRows = "Excel dosyasındaki satırları ile MySQL tablo satırları uyuşmuyor!"
Private Const strNotExistTable = "Tablo veritabanında yok."
 
' SQL Sorgu
 
Not:Aşağıdaki satırda Html kodunda çizgi yaptığından dolayı ' tırnak koydum. Bu satırdaki tek tırnak işaretlerini kaldırın
Private Const SQL_ORIGINAL = "INSERT INTO '<'TABLENAME'> '('<'FIELDSET'>') VALUES '('<'VALUESET'>')"
 
 
Dim g_step As StepProcess
Dim g_excelFilename As String
Dim g_DSN As String
Dim g_UID As String
Dim g_PWD As String
Dim g_Table As String
Dim g_conn As ADODB.Connection
Dim g_rs As ADODB.Recordset
Dim xl As Excel.Application
Dim xl_worksheet As Excel.Worksheet
Dim xl_workbook As Excel.Workbook
Public strSelectedTablename As String
 
Private Sub Command1_Click()
If g_step = XLS_SELECTION Then
CommonDialog.Filter = "Excel Dosyaları|*.xls"
CommonDialog.ShowOpen
If CommonDialog.FileName = "" Then Exit Sub
g_step = ODBC_SETTING
g_excelFilename = CommonDialog.FileName
Command3.Enabled = True
Call ShowTextMessage
 
ElseIf g_step = ODBC_SETTING Then
g_DSN = Text1.Text
g_UID = Text2.Text
g_PWD = Text3.Text
g_Table = Text4.Text
' boşluklar kaldırılıyor
g_DSN = Trim(g_DSN)
g_UID = Trim(g_UID)
g_PWD = Trim(g_PWD)
g_Table = Trim(g_Table)
If Len(g_DSN) = 0 Then
MsgBox strReqDsnMsg, vbOKOnly, strTitle
Exit Sub
ElseIf Len(g_Table) = 0 Then
MsgBox strReqTableMsg, vbOKOnly, strTitle
Exit Sub
End If
' ODBC ayarları kaydediliyor
Open App.Path & "\odbc_info.txt" For Output As #1
'ODBC_info txt dosyasına ayarlar kaydediliyor. Print #1, g_DSN
Print #1, g_UID
Print #1, g_PWD
Print #1, g_Table
Close #1
g_step = CHECKING_INFO
Call ShowTextMessage
ElseIf g_step = CHECKING_INFO Then
Dim bExistTable As Boolean
Dim source As String
Dim dummy As String
Dim SQL As String
Dim SQL_EXECUTION As String
Dim status As String
Dim cols_count As Long
Dim rows_count As Long
Dim data_value As String
Dim i As Long
Dim j As Long
Dim myTableName As String
source = "DSN=%1%;UID=%2%;PWD=%3%;"
source = Replace(source, "%1%", g_DSN)
source = Replace(source, "%2%", g_UID)
source = Replace(source, "%3%", g_PWD)
' "ADODB" nesnesi oluşturuluyor
Set g_conn = CreateObject("ADODB.Connection")
Set g_rs = CreateObject("ADODB.Recordset")
' ODBCye bağlanılıyor
g_conn.Open source
' tablo kontrol ediliyor
SQL_EXECUTION = "show tables"
g_rs.Open SQL_EXECUTION, g_conn
bExistTable = False
Do While Not g_rs.EOF
myTableName = CStr(g_rs(0))
If UCase(myTableName) = UCase(g_Table) Then
bExistTable = True
Exit Do
End If
g_rs.MoveNext
Loop
g_rs.Close
If bExistTable = False Then
MsgBox strNotExistTable, vbOKOnly, strTitle
xl.ActiveWorkbook.Close savechanges:=False
xl.Quit
g_conn.Close
Set g_rs = Nothing
Set g_conn = Nothing
Exit Sub
End If
 
exceltoMysqlProgressfrm.Show
Set xl = CreateObject("excel.application")
xl.Workbooks.Open g_excelFilename
xl.Visible = False
On Error GoTo handler
'Burası excelin ilk sayfasını dikkate alıyor. Siz sayfa ismi veya başka bir sıra vermek isterseniz xl.(Worksheets(1) kısmını
'sayfa2 veya (2) diye değiştirebilirsiniz.
Set xl_worksheet = xl.Worksheets(1)
cols_count = GetColumnCount
rows_count = GetRowsCount
If cols_count = 0 Then
MsgBox strErrNotExistCols, vbOKOnly, strTitle
xl.ActiveWorkbook.Close savechanges:=False
xl.Quit
Set xl = Nothing
Set xl_worksheet = Nothing
Exit Sub
End If
If rows_count < 2 Then
MsgBox strErrNotExistRows, vbOKOnly, strTitle
xl.ActiveWorkbook.Close savechanges:=False
xl.Quit
Set xl = Nothing
Set xl_worksheet = Nothing
Exit Sub
End If
dummy = ""
For j = 1 To cols_count
dummy = dummy & xl_worksheet.Cells(1, j) & ","
Next
If Not dummy = "" Then
dummy = Left(dummy, Len(dummy) - 1)
End If
SQL = SQL_ORIGINAL
SQL = Replace(SQL, "", g_Table)
Not:Aşağıdaki satırda Html kodunda çizgi yaptığından dolayı ' tırnak koydum. Bu satırdaki
kelimesindeki tek tırnak işaretlerini kaldırın
SQL = Replace(SQL, "
", dummy)
DoEvents
exceltoMysqlProgressfrm.Progress.Min = 2
exceltoMysqlProgressfrm.Progress.Max = rows_count + 1
For i = 2 To rows_count
SQL_EXECUTION = SQL
dummy = ""
For j = 1 To cols_count
Debug.Print "*"
data_value = xl_worksheet.Cells(i, j)
Debug.Print data_value
data_value = Replace(data_value, "'", "''")
dummy = dummy & "'" & data_value & "',"
Next
If Not dummy = "" Then
dummy = Left(dummy, Len(dummy) - 1)
End If
SQL_EXECUTION = Replace(SQL_EXECUTION, "", dummy)
status = SQL_EXECUTION
If Len(status) > 100 Then
status = Left(status, 100)
End If
exceltoMysqlProgressfrm.labeldurum.Caption = "İşlem : " & status
exceltoMysqlProgressfrm.labProgress.Caption = FormatPercent(i / rows_count)
exceltoMysqlProgressfrm.Progress.Value = i + 1
Debug.Print SQL_EXECUTION
g_conn.Execute SQL_EXECUTION
Next
g_conn.Close
Set g_conn = Nothing
Set g_rs = Nothing
xl.ActiveWorkbook.Close savechanges:=False
xl.Quit
Unload exceltoMysqlProgressfrm
'İşlem Tamamlandı
g_step = COMPLETE_PROCESS
Call ShowTextMessage
Command3.Enabled = False
Command1.Caption = "Kapat"
Command2.Visible = False
ElseIf g_step = COMPLETE_PROCESS Then
'End
Unload Me
End If
Exit Sub
handler:
MsgBox Err.Description, vbCritical + vbOKOnly, "Error Message"
xl.ActiveWorkbook.Close savechanges:=False
xl.Quit
Unload exceltoMysqlProgressfrm
End Sub
Private Sub Command2_Click()
If MsgBox(strExitMsg, vbYesNo, strTitle) = vbYes Then
Unload Me
End If
End Sub
Private Sub Command3_Click()
If g_step = ODBC_SETTING Then
Command3.Enabled = False
g_step = XLS_SELECTION
ElseIf g_step = CHECKING_INFO Then
g_step = ODBC_SETTING
ElseIf g_step = COMPLETE_PROCESS Then
g_step = CHECKING_INFO
End If
Call ShowTextMessage
End Sub
Private Sub Command4_Click()
Dim source As String
g_DSN = Text1.Text
g_UID = Text2.Text
g_PWD = Text3.Text
If Len(g_DSN) = 0 Then
MsgBox strReqDsnMsg, vbOKOnly, strTitle
Exit Sub
End If
source = "DSN=%1%;UID=%2%;PWD=%3%;"
source = Replace(source, "%1%", g_DSN)
source = Replace(source, "%2%", g_UID)
source = Replace(source, "%3%", g_PWD)
Load exceltoMysqltablosecfrm
If exceltoMysqltablosecfrm.LoadTableList(source) = True Then
exceltoMysqltablosecfrm.Show 1
Text4.Text = strSelectedTablename
End If
Unload exceltoMysqltablosecfrm
End Sub
Private Sub Form_Load()
g_step = XLS_SELECTION
Call ShowTextMessage
If Not Dir(App.Path & "\odbc_info.txt") = "" Then
Open App.Path & "\odbc_info.txt" For Input As #1
Input #1, g_DSN
Input #1, g_UID
Input #1, g_PWD
Input #1, g_Table
Close #1
Text1.Text = g_DSN
Text2.Text = g_UID
Text3.Text = g_PWD
Text4.Text = g_Table
End If
End Sub
Private Sub ShowTextMessage()
If g_step = XLS_SELECTION Then
txtMessage.Text = "İleri düğmesini tıklayın ve kaynak Excel dosyasını seçin. Not: Excel dosyasının ilk sayfası dikkate alınacaktır."
ElseIf g_step = ODBC_SETTING Then
txtMessage.Text = g_excelFilename & " seçildi. " & vbCrLf & " Şimdi ODBC bağlantı ayarlarını yapın. "
ElseIf g_step = CHECKING_INFO Then
txtMessage.Text = "Bilgilerin doğruluğunu kontrol edin." & vbCrLf & vbCrLf
txtMessage.Text = txtMessage.Text & "Excel : " & g_excelFilename & vbCrLf
txtMessage.Text = txtMessage.Text & "ODBC : Database adı <%1%> / Kullanıcı adı <%2%> / Şifre <%3%>"
txtMessage.Text = txtMessage.Text & vbCrLf & vbCrLf
txtMessage.Text = txtMessage.Text & "İleri düğmesini tıklayın. "
txtMessage.Text = Replace(txtMessage.Text, "%1%", g_DSN)
txtMessage.Text = Replace(txtMessage.Text, "%2%", g_UID)
txtMessage.Text = Replace(txtMessage.Text, "%3%", g_PWD)
ElseIf g_step = COMPLETE_PROCESS Then
txtMessage.Text = "İşlem tamamlandı!"
End If
End Sub
Private Function GetColumnCount() As Long
Dim i As Long
Dim cols_count As Long
Dim xl_worksheet As Excel.Worksheet
Set xl_worksheet = xl.Worksheets(1)
For i = 1 To xl_worksheet.Columns.Count
If Not xl_worksheet.Cells(1, i) = "" Then
cols_count = cols_count + 1
End If
Next
GetColumnCount = cols_count
End Function
Private Function GetRowsCount() As Long
Dim i As Long
Dim cols_count As Long
Dim xl_worksheet As Excel.Worksheet
Set xl_worksheet = xl.Worksheets(1)
For i = 1 To xl_worksheet.Columns.Count
If Not xl_worksheet.Cells(1, i) = "" Then
cols_count = cols_count + 1
End If
Next
Dim j As Long
Dim rows_count As Long
Dim dummy As String
For i = 1 To xl_worksheet.Rows.Count
dummy = ""
For j = 1 To cols_count
dummy = dummy & xl_worksheet.Cells(i, j)
Next
If dummy = "" Then
Exit For
Else
rows_count = rows_count + 1
End If
Next
GetRowsCount = rows_count
End Function

Private Sub Timer1_Timer()
If Me.Visible = True Then
Me.Visible = False
Else
Me.Visible = True
End If
End Sub
Private Sub Command1_Click()
' That value for duration 1000 = 1 second
Timer1.Interval = 1000
End Sub

'Projede Kullanılacak DLL user32.dll
'Function İse SendMessage(),PostMessage
'Projede Kullanılacak sabitler
Public Const WM_COMMAND = &H111
Public Const WM_USER = &H400
Public Const WM_WA_IPC = WM_USER
Public Const IPC_GETVERSION = 0
Public Const IPC_PLAYFILE = 100
Public Const IPC_DELETE = 101
Public Const IPC_STARTPLAY = 102
Public Const IPC_CHDIR = 103
Public Const IPC_ISPLAYING = 104
Public Const IPC_GETOUTPUTTIME = 105
Public Const IPC_JUMPTOTIME = 106
Public Const IPC_WRITEPLAYLIST = 120
Public Const IPC_SETPLAYLISTPOS = 121
Public Const IPC_SETVOLUME = 122
Public Const IPC_SETPANNING = 123
Public Const IPC_GETLISTLENGTH = 124

'Project : MouseOver
'Form : frmMain
'...CommandButton : btnMain
'Module : mdlMain
'Form->Name = frmMain
'CommandButton->Name = btnName
'CommandButton->Style = Graphical
'frmMain Code
'------------
Option Explicit
Private Sub Form_Load()
With Me.btnMain
.BackColor = &H800000&
.Caption = vbNullString
End With
BtnProc = SetWindowLong(Me.btnMain.hWnd, (-4), AddressOf ButtonProc)
End Sub
Private Sub btnMain_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim TMEType As TRACKMOUSEEVENTTYPE
If Button <> 0 Then
Exit Sub
End If
If Me.btnMain.BackColor = &HFFFF& Then
Exit Sub
End If
Me.btnMain.BackColor = &HFFFF&
With TMEType
.cbSize = Len(TMEType)
.dwFlags = TME_LEAVE
.hwndTrack = Me.btnMain.hWnd
End With
TrackMouseEvent TMEType
End Sub
Private Sub Form_Unload(Cancel As Integer)
SetWindowLong Me.btnMain.hWnd, (-4), BtnProc
End Sub
'mdlMain Code
'------------
Option Explicit
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long
Public Const WM_MOUSELEAVE As Long = &H2A3
Public Const TME_LEAVE = &H2
Public Type TRACKMOUSEEVENTTYPE
cbSize As Long
dwFlags As Long
hwndTrack As Long
dwHoverTime As Long
End Type
Public BtnProc As Long
Public Function ButtonProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_MOUSELEAVE Then
frmMain.btnMain.BackColor = &H800000&
End If
ButtonProc = CallWindowProc(BtnProc, hWnd, uMsg, wParam, lParam)
End Function

Private Sub Command1_Click()
Call Shell("calc.exe", 1)
End Sub

Private Const VK_H = 72
Private Const KEYEVENTF_KEYUP = &H2
Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 91 Or KeyCode = 92 Then 'if winkey
keybd_event VK_H, 0, 0, 0 ' press H
keybd_event VK_H, 0, KEYEVENTF_KEYUP, 0 ' release H
End If
End Sub