Herkese iyi günler bu siteye yeni kaydoldum emeği geçen herkezden ALLAH razı olsun. Sorunuma gelince
Combobox ların açılır liste olayını commandbutton a atadım iyi çalısıyor fakat kodlardada göreceğiniz üzere yeni cari ekleme yada
cari silme işleminden sonra combobox açılır liste kilitleniyor yani liste açılmıyor bir türlü çözemedim sorunu ilgili arkadaşlardan ricam kodlara bir göz atmaları eğer dosya eklemem gerekirse onuda eklerim. Unutmayınız combobox acılır liste commandbutton aracılığı ile çalışıyor şimdiden teşekkürler.
Private Sub CommandButton23_Click()
With UserForm1.ComboBox3
ComboBox3.Clear
.AddItem "Cari Kayıtları"
.AddItem "Yeni Cari Ekle"
.AddItem "Cari Düzenle"
.AddItem "Cari Bilgileri"
.AddItem "Cari İşlemlerini Raporla"
.AddItem "Cari Sil"
ComboBox3.DropDown
End With
End Sub
Private Sub ComboBox3_Change()
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Kayıtları"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
UserForm7.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Yeni Cari Ekle"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
UserForm6.Show
Unload Me
UserForm1.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Düzenle"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
If UserForm1.ComboBox1.Value = "" Then
MsgBox ("(Önce Düzenlemek İstediğiniz Cariyi Seçmelisiniz)")
Exit Sub
End If
UserForm10.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Sil"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
If ComboBox1.Value = "" Then
MsgBox ("(Önce Silmek İsediğiniz Cariyi Seçmelisiniz)")
Exit Sub
End If
sifre = InputBox("Cariyi Silmek İçin Şifreyi Giriniz Lütfen", _
"Uyarı")
If sifre = "1231" Then
Else
On Error Resume Next
MsgBox "Hatalı Şifre İşlem Başarısız Oldu"
Cancel = True
Exit Sub
End If
Worksheets(UserForm1.ComboBox1.Text).Delete
UserForm1.Show
Unload Me
UserForm1.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Bilgileri"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
If ComboBox1.Value = "" Then
MsgBox ("(Önce Bilgilerini Görmek İstedğiniz Cariyi Seçmelisiniz)")
Exit Sub
End If
UserForm4.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari İşlemlerini Raporla"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
On Error Resume Next
If UserForm1.ComboBox1 = "" Then
MsgBox "(Önce Raporunu Almak İstediğiniz Cariyi Seçmelisiniz)"
Exit Sub
End If
say = ActiveSheet.Range("A65536").End(3).Row
ActiveSheet.PageSetup.PrintArea = "$A$1:$E$" & say
Application.DisplayAlerts = False
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Çıkmak İçin Tamam Tuşuna Basınız", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Belirlediğiniz Konumda Aynı Belgeden Var Değiştirilsinmi?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Çıkmak İçin Tamam Tuşuna Basınız", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Çıkmak İçin Tamam Tuşuna Basınız", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
With xEmailObj
On Error Resume Next
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
MsgBox "(Cari Raporu Belirlediğiniz Yere kaydedildi)", vbCritical, ActiveSheet.Name
Else
End If
End If
End If
End If
End If
End If
End Sub
Combobox ların açılır liste olayını commandbutton a atadım iyi çalısıyor fakat kodlardada göreceğiniz üzere yeni cari ekleme yada
cari silme işleminden sonra combobox açılır liste kilitleniyor yani liste açılmıyor bir türlü çözemedim sorunu ilgili arkadaşlardan ricam kodlara bir göz atmaları eğer dosya eklemem gerekirse onuda eklerim. Unutmayınız combobox acılır liste commandbutton aracılığı ile çalışıyor şimdiden teşekkürler.
Private Sub CommandButton23_Click()
With UserForm1.ComboBox3
ComboBox3.Clear
.AddItem "Cari Kayıtları"
.AddItem "Yeni Cari Ekle"
.AddItem "Cari Düzenle"
.AddItem "Cari Bilgileri"
.AddItem "Cari İşlemlerini Raporla"
.AddItem "Cari Sil"
ComboBox3.DropDown
End With
End Sub
Private Sub ComboBox3_Change()
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Kayıtları"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
UserForm7.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Yeni Cari Ekle"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
UserForm6.Show
Unload Me
UserForm1.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Düzenle"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
If UserForm1.ComboBox1.Value = "" Then
MsgBox ("(Önce Düzenlemek İstediğiniz Cariyi Seçmelisiniz)")
Exit Sub
End If
UserForm10.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Sil"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
If ComboBox1.Value = "" Then
MsgBox ("(Önce Silmek İsediğiniz Cariyi Seçmelisiniz)")
Exit Sub
End If
sifre = InputBox("Cariyi Silmek İçin Şifreyi Giriniz Lütfen", _
"Uyarı")
If sifre = "1231" Then
Else
On Error Resume Next
MsgBox "Hatalı Şifre İşlem Başarısız Oldu"
Cancel = True
Exit Sub
End If
Worksheets(UserForm1.ComboBox1.Text).Delete
UserForm1.Show
Unload Me
UserForm1.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari Bilgileri"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
If ComboBox1.Value = "" Then
MsgBox ("(Önce Bilgilerini Görmek İstedğiniz Cariyi Seçmelisiniz)")
Exit Sub
End If
UserForm4.Show
Else
On Error Resume Next
Kullanici = ComboBox3
metin = Kullanici
Sec = "Cari İşlemlerini Raporla"
If Sec = metin Then
evn = True
txtid = ""
txtpass = ""
On Error Resume Next
If UserForm1.ComboBox1 = "" Then
MsgBox "(Önce Raporunu Almak İstediğiniz Cariyi Seçmelisiniz)"
Exit Sub
End If
say = ActiveSheet.Range("A65536").End(3).Row
ActiveSheet.PageSetup.PrintArea = "$A$1:$E$" & say
Application.DisplayAlerts = False
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Çıkmak İçin Tamam Tuşuna Basınız", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Belirlediğiniz Konumda Aynı Belgeden Var Değiştirilsinmi?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Çıkmak İçin Tamam Tuşuna Basınız", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Çıkmak İçin Tamam Tuşuna Basınız", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
With xEmailObj
On Error Resume Next
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
MsgBox "(Cari Raporu Belirlediğiniz Yere kaydedildi)", vbCritical, ActiveSheet.Name
Else
End If
End If
End If
End If
End If
End If
End Sub